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