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