Util.pm

   1 # -*- perl -*-x
   2
   3 # Copyright (c) 1999-2006  Debian Admin Team Members and Developers    (taken from debian/copyright in 2008 by weasel)
   4 # Copyright (c) 2002, 2003, 2004, 2008 Peter Palfrader
   5
   6 package Util;
   7
   8 use strict;
   9 use Date::Manip qw(ParseDate);
  10 use Net::LDAP qw(LDAP_SUCCESS LDAP_PROTOCOL_ERROR);
  11 use English;
  12
  13 my $blocksize = 8; # A blowfish block is 8 bytes
  14 my $configfile = "/etc/userdir-ldap/userdir-ldap.conf";
  15 #my $configfile = "/home/randolph/html/debian/perl/userdir-ldap.conf";
  16
  17 my %config = &ReadConfigFile;
  18
  19 my $hascryptix = 1;
  20 eval 'use Crypt::Blowfish';
  21 if ($@) {
  22   $hascryptix = undef;
  23 }
  24
  25 sub CreateKey {
  26   my $keysize = shift;
  27   my $input;
  28   open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
  29   read(F, $input, $keysize); # key length is 8 bytes
  30   close F;
  31
  32   return $input;
  33 }
  34
  35 sub CreateCryptSalt {
  36   # CreateCryptSalt(type = 0, skip_header = 0)
  37   # this can create either a DES type salt or a MD5 salt
  38   # 0 for DES, 1 for MD5 salt
  39   # if skip_header is 0, does not add $1$ for md5 salts.
  40   my $md5 = shift; # do we want a MD5 salt?
  41   my $no_crypttype_header = shift;
  42   my $validstr = './0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
  43   my @valid = split(//,$validstr);
  44   my ($in, $out);
  45
  46   my $cryptsaltlen = ($md5 ? 8 : 2);
  47
  48   open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
  49   foreach (1..$cryptsaltlen) {
  50     read(F, $in, 1);
  51     $out .= $valid[ord($in) % ($#valid + 1)];
  52   }
  53   close F;
  54   if ($md5 == 1 && !$no_crypttype_header) { $out = "\$1\$$out\$"; }
  55   return $out
  56 }
  57
  58 sub Encrypt {
  59   # blowfish only encrypts things in blocks of 8 bytes, so we
  60   # need a custom routine that handles longer strings....
  61   my $cipher = shift;
  62   my $input = shift;
  63   my ($pos, $output);
  64
  65   # prepend a length byte */
  66   $input = chr(length($input)).$input;
  67   $input .= "\001" x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));
  68
  69   for ($pos = 0; $pos < length($input); $pos += $blocksize) {
  70     $output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize))) if ($hascryptix);
  71   }
  72   return $output;
  73 }
  74
  75 sub Decrypt {
  76   # like encrypt, needs to deal with big blocks. Note that we assume
  77   # trailing spaces are unimportant.
  78   my $cipher = shift;
  79   my $input = shift;
  80   my ($pos, $portion, $output, $len);
  81
  82   ((length($input) % $blocksize) == 0) || &HTMLError("Password corrupted"); # should always be true...
  83
  84   for ($pos = 0; $pos < length($input); $pos += $blocksize*2) {
  85     $portion = pack("H16", substr($input, $pos, $blocksize*2));
  86     $output .= $cipher->decrypt($portion) if ($hascryptix);
  87   }
  88
  89   # check length byte, discard junk
  90   $len = substr($output, 0, 1);
  91   $output = substr($output, 1, ord($len));
  92   return $output;
  93 }
  94
  95 sub SavePasswordToFile {
  96   my $userid = shift;
  97   my $password = shift;
  98   my $cipher = shift;
  99
 100   my $cryptuser = crypt($userid, &CreateCryptSalt);
 101   my $secret = Encrypt($cipher, $password);
 102   $cryptuser =~ y/\//_/; # translate slashes to underscores...
 103
 104   my $fn = "$config{authtokenpath}/$cryptuser";
 105   open (F, ">$fn") || &HTMLError("$fn: $!");
 106   print F "$secret\n";
 107   print F time."\n";
 108   close F;
 109   chmod 0600, $fn;
 110   return $cryptuser;
 111 }
 112
 113 sub ReadPasswordFromFile {
 114   my $userid = shift;
 115   my $cipher = shift;
 116   my $passwd;
 117   my $time;
 118
 119   $userid =~ y/\//_/; # translate slashes to underscores...
 120
 121   # if we couldn't read the password file, assume user is unauthenticated. is this ok?
 122   open (F, "<$config{authtokenpath}/$userid") || return undef;
 123   chomp($passwd = <F>);
 124   chomp($time = <F>);
 125   close F;
 126
 127   # check to make sure we read something
 128   return undef if (!$passwd || !$time);
 129
 130   # check to make sure the time is positive, and that the auth token
 131   # has not expired
 132   my $tdiff = (time - $time);
 133   &HTMLError("Your authentication token has expired. Please <a href=\"https://$ENV{SERVER_NAME}/$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
 134
 135   return Decrypt($cipher, $passwd);
 136 }
 137
 138 sub CheckAuthToken {
 139   my ($id, $hrkey) = split(/,/, shift, 2);
 140   return undef if (!$id || !$hrkey);
 141   my $key = pack("H".(length($hrkey)), $hrkey);
 142   my $cipher = new Crypt::Blowfish $key;
 143   my $r = ReadPasswordFromFile($id, $cipher);
 144   if ($r) {
 145     UpdateAuthToken("$id,$hrkey", $r);
 146   } else {
 147     ClearAuthToken("$id,$hrkey")
 148   }
 149   return $r;
 150 }
 151
 152 sub ClearAuthToken {
 153   my ($id, $hrkey) = split(/,/, shift, 2);
 154   $id =~ y/\//_/; # switch / to _
 155   unlink "$config{authtokenpath}/$id" || &HTMLError("Error removing authtoken: $!");
 156 }
 157
 158 sub UpdateAuthToken {
 159   my ($id, $hrkey) = split(/,/, shift, 2);
 160   my $password = shift;
 161   my $key = pack("H".(length($hrkey)), $hrkey);
 162   $id =~ y/\//_/; # switch / to _
 163   my $cipher = new Crypt::Blowfish $key;
 164   my $secret = Encrypt($cipher, $password);
 165
 166   my $fn = "$config{authtokenpath}/$id";
 167   open (F, ">$fn") || &HTMLError("$fn: $!");
 168   print F "$secret\n";
 169   print F time."\n";
 170   close F;
 171   chmod 0600, "$fn" || &HTMLError("$fn: $!");
 172   return 1;
 173 }
 174
 175 sub FormatFingerPrint {
 176   my $in = shift;
 177   my $out;
 178
 179   if (length($in) == 32) {
 180     foreach (0..15) {
 181       $out .= substr($in, $_*2, 2)." ";
 182       $out .= "&nbsp;" if ($_ == 7);
 183     }
 184   } else {
 185     foreach (0..int(length($in)/4)) {
 186       $out .= substr($in, $_*4, 4)." ";
 187     }
 188   }
 189   chop $out;
 190   return $out;
 191 }
 192
 193 sub FetchKey {
 194   my $fingerprint = shift;
 195   my $signatures = shift;
 196   my ($out, $keyringparam) = undef;
 197
 198   foreach (split(/:/, $config{keyrings})) {
 199     $keyringparam .= "--keyring $_ ";
 200   }
 201
 202   $fingerprint =~ s/\s//g;
 203   $fingerprint = "0x".$fingerprint;
 204
 205   local $ENV{PATH} = '';
 206   $/ = undef; # just suck it up ....
 207   if ($signatures) {
 208       open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
 209       $out = <FP>;
 210       close FP;
 211   }
 212   open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
 213   $out .= <FP>;
 214   close FP;
 215   $/ = "\n";
 216
 217   return $out;
 218 }
 219
 220 sub FormatTimestamp {
 221   my $in = shift;
 222   $in =~ /^(....)(..)(..)(..)(..)(..)/;
 223
 224   return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
 225 }
 226
 227 sub FormatLastSeen {
 228 # Format:
 229 # [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
 230 # [Mon, 10 Jan 2000 21:48:19] "9E1E 1052 F8BB A351  0606 5527 50BB 2974 2D59 A7D2" "<debian-devel-changes@lists.debian.org> archive/latest/58632" "<20000110200506.13257.qmail@master.debian.org>"
 231   my $lastseenpgp = shift;
 232   my $lastseenfrom = shift;
 233   my ($d1, $d2, $lastseen);
 234
 235   return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
 236   $lastseen = $lastseenpgp;
 237   $lastseen = $lastseenfrom if (!$lastseenpgp);
 238
 239   if ($lastseenfrom && $lastseenpgp) {
 240     ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);
 241     ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
 242     $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
 243   }
 244
 245   my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.*?|\-)"\s+"(<.+?>)"/);
 246   $list = "on $list" if ($list);
 247   $date = CGI::escapeHTML($date);
 248   $user = CGI::escapeHTML($user);
 249   $list = CGI::escapeHTML($list);
 250   $msgid = CGI::escapeHTML($msgid);
 251   return "$date $list<br>&nbsp;Message ID: $msgid";
 252 }
 253
 254 sub LookupCountry {
 255   my $in = shift;
 256   my ($abbrev, $country);
 257   open (F, $config{countrylist}) || return uc($in);
 258   while (<F>) {
 259     chomp;
 260     ($abbrev, $country) = split(/\s+/, $_, 2);
 261     if ($abbrev eq $in) {
 262       close F;
 263       return $country;
 264     }
 265   }
 266   close F;
 267   return uc($in);
 268 }
 269
 270 ####################
 271 # Some HTML Routines
 272
 273 my $htmlhdrsent = 0;
 274
 275 sub HTMLSendHeader {
 276   print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
 277   $htmlhdrsent = 1;
 278 }
 279
 280 sub HTMLPrint {
 281   &HTMLSendHeader if (!$htmlhdrsent);
 282   print shift;
 283 }
 284
 285 sub HTMLError {
 286   HTMLPrint(shift);
 287   die "\n";
 288 }
 289
 290 sub CheckLatLong {
 291   my ($lat, $long) = @_;
 292
 293   $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
 294
 295   if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
 296     return ($lat, $long);
 297   } else {
 298     return ("", "");
 299   }
 300 }
 301
 302 sub FixParams {
 303   my $query = shift;
 304   my $key;
 305   my @names = $query->param;
 306
 307   foreach $key (@names) { # web security is a joke ... <sigh>
 308     $_ = $query->param($key);
 309     s/&/&amp;/g;
 310     s/[<\x8B]/&lt;/g;
 311     s/[>\x9B]/&gt;/g;
 312
 313     $query->param($key, $_);
 314   }
 315 }
 316
 317
 318 sub LDAPUpdate {
 319   my $ldap = shift;
 320   my $dn = shift;
 321   my $attr = shift;
 322   my $val = shift;
 323   my $mesg;
 324
 325   if (!$val) {
 326     $mesg = $ldap->modify($dn, delete => { $attr => [] });
 327   } else {
 328     $val = [ $val ] if (!ref($val));
 329     $mesg = $ldap->modify($dn, replace => { $attr => $val });
 330     $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
 331   }
 332 }
 333
 334 ###################
 335 # Config file stuff
 336 sub ReadConfigFile {
 337   # reads a config file and results a hashref with the results
 338   my (%config, $attr, $setting);
 339   open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
 340   while (<F>) {
 341     chomp;
 342     if ((!/^\s*#/) && ($_ ne "")) {
 343       # Chop off any trailing comments
 344       s/#.*//;
 345       /([^=]+)=(.*)/;
 346       ($attr, $setting) = ($1, $2);
 347       $setting =~ s/"//g; #"
 348       $setting =~ s/;$//;
 349       $attr =~ s/^\s+//; $attr =~ s/\s+$//;
 350       $setting =~ s/^\s+//; $setting =~ s/\s+$//;
 351       $config{$attr} = $setting;
 352     }
 353   }
 354   close F;
 355   return %config;
 356 }
 357
 358 sub UpgradeConnection($) {
 359   my ($ldap) = @_;
 360   my $mesg = $ldap->start_tls(
 361                           verify => 'require',
 362                           # Cannot specify the server cert, must specify the CA cert
 363                           #cafile => '/etc/ssl/servicecerts/db.debian.org.crt'
 364                           #cafile => '/etc/ssl/certs/UTN_USERFirst_Hardware_Root_CA.pem'
 365                           cafile => '/usr/share/ca-certificates/mozilla/AddTrust_External_Root.crt'
 366                           );
 367   $mesg->sync;
 368   if ($mesg->code != LDAP_SUCCESS) {
 369     print "Content-type: text/html; charset=utf-8\n\n";
 370     print "<html><body><h1>STARTTLS failed: ".$mesg->error."</h1></body></html>\n";
 371     exit(1);
 372   };
 373 };
 374
 375 sub readwrite3($$$$) {
 376   my ($in, $inputfd, $stdoutfd, $stderrfd) = @_;
 377
 378   #Echolot::Log::trace("Entering readwrite_gpg.");
 379
 380   local $INPUT_RECORD_SEPARATOR = undef;
 381   my $sout = IO::Select->new();
 382   my $sin = IO::Select->new();
 383   my $offset = 0;
 384
 385   #Echolot::Log::trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 386
 387   $inputfd->blocking(0);
 388   $stdoutfd->blocking(0);
 389   $stderrfd->blocking(0);
 390   $sout->add($stdoutfd);
 391   $sout->add($stderrfd);
 392   $sin->add($inputfd);
 393
 394   my ($stdout, $stderr) = ("", "", "");
 395
 396   my ($readyr, $readyw);
 397   while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 398     #Echolot::Log::trace("select waiting for ".($sout->count())." fds.");
 399     ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, 42);
 400     #Echolot::Log::trace("ready: write: ".(defined $readyw ? scalar @$readyw : 'none')."; read: ".(defined $readyr ? scalar @$readyr : 'none'));
 401     for my $wfd (@$readyw) {
 402       #Echolot::Log::trace("writing to $wfd.");
 403       my $written = 0;
 404       if ($offset != length($in)) {
 405         $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 406       }
 407       unless (defined ($written)) {
 408         #Echolot::Log::warn("Error while writing to GnuPG: $!");
 409         close $wfd;
 410         $sin->remove($wfd);
 411         $sin = undef;
 412       } else {
 413         $offset += $written;
 414         if ($offset == length($in)) {
 415           #Echolot::Log::trace("writing to $wfd done.");
 416           close $wfd;
 417           $sin->remove($wfd);
 418           $sin = undef;
 419         }
 420       }
 421     }
 422
 423     next unless (defined(@$readyr)); # Wait some more.
 424
 425     for my $rfd (@$readyr) {
 426       if ($rfd->eof) {
 427         #Echolot::Log::trace("reading from $rfd done.");
 428         $sout->remove($rfd);
 429         close($rfd);
 430         next;
 431       }
 432       #Echolot::Log::trace("reading from $rfd.");
 433       if ($rfd == $stdoutfd) {
 434         $stdout .= <$rfd>;
 435         next;
 436       }
 437       if ($rfd == $stderrfd) {
 438         $stderr .= <$rfd>;
 439         next;
 440       }
 441     }
 442   }
 443   #Echolot::Log::trace("readwrite_gpg done.");
 444   return ($stdout, $stderr);
 445 };
 446
 447 sub checkPasswordQuality($$$) {
 448   my ($pw, $oldpw, $ldapelements) = @_;
 449   my ($stdinR, $stdinW) = (IO::Handle->new(), IO::Handle->new());
 450   my ($stdoutR, $stdoutW) = (IO::Handle->new(), IO::Handle->new());
 451   my ($stderrR, $stderrW) = (IO::Handle->new(), IO::Handle->new());
 452   pipe $stdinR, $stdinW;
 453   pipe $stdoutR, $stdoutW;
 454   pipe $stderrR, $stderrW;
 455
 456   my $pid = fork();
 457   unless (defined $pid) {
 458     return (2, "Could not fork: $!");
 459   };
 460   unless ($pid) { # child
 461     $stdinW->close;
 462     $stdoutR->close;
 463     $stderrR->close;
 464     close STDIN;
 465     close STDOUT;
 466     close STDERR;
 467     open (STDIN, "<&".$stdinR->fileno) or warn ("Cannot dup stdinR (fd ".$stdinR->fileno.") as STDIN: $!");
 468     open (STDOUT, ">&".$stdoutW->fileno) or warn ("Cannot dup stdoutW (fd ".$stdoutW->fileno.") as STDOUT: $!");
 469     open (STDERR, ">&".$stderrW->fileno) or warn ("Cannot dup stderrW (fd ".$stderrW->fileno.") as STDERR: $!");
 470     { exec('/usr/lib/userdir-ldap-cgi/password-qualify-check'); }
 471     $stderrW->print("Could not exec password-qualify-check: $!\n");
 472     exit(1);
 473   };
 474   $stdinR->close;
 475   $stdoutW->close;
 476   $stderrW->close;
 477
 478   $oldpw = '' unless defined $oldpw;
 479   my $out = join("\n", $pw, $oldpw, @$ldapelements)."\n";
 480   my ($stdout, $stderr) = readwrite3($out, $stdinW, $stdoutR, $stderrR);
 481   waitpid $pid, 0;
 482
 483   my $exitcode = $? >> 8;
 484   if ($exitcode == 0 && $stdout eq '' && $stderr eq '') {
 485     return (0, "ok");
 486   } elsif ($exitcode == 1 && $stderr eq '') {
 487     return (1, $stdout);
 488   } else {
 489     return (2, "check exited with exit code $exitcode, said '$stdout' on stdout, and '$stderr' on stderr.");
 490   };
 491 };
 492 1;