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, 2009, 2011, 2012, 2014, 2015 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 use Crypt::CBC;
  13 use Digest::HMAC_SHA1 qw(hmac_sha1_hex);
  14
  15 my $blocksize = 8; # A blowfish block is 8 bytes
  16 my $configfile = "/etc/userdir-ldap/userdir-ldap.conf";
  17 #my $configfile = "/home/randolph/html/debian/perl/userdir-ldap.conf";
  18
  19 my %config = &ReadConfigFile;
  20
  21 sub CreateKey {
  22   my $keysize = shift;
  23   my $input;
  24   open (F, "<", "/dev/urandom") || die &HTMLError("No /dev/urandom found!");
  25   read(F, $input, $keysize); # key length is 8 bytes
  26   close F;
  27
  28   return $input;
  29 }
  30
  31 sub CreateCryptSalt {
  32   # CreateCryptSalt(type = 0, skip_header = 0)
  33   # this can create either a DES type salt or a MD5 salt
  34   # 0 for DES, 1 for MD5 salt
  35   # if skip_header is 0, does not add $1$ for md5 salts.
  36   my $md5 = shift; # do we want a MD5 salt?
  37   my $no_crypttype_header = shift;
  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   if ($md5 == 1 && !$no_crypttype_header) { $out = "\$1\$$out\$"; }
  51   return $out
  52 }
  53
  54 sub Encrypt {
  55   my $hexkey = shift;
  56   my $plaintext = shift;
  57
  58   my $cipher = Crypt::CBC->new( -key    => $hexkey, -cipher => 'Blowfish');
  59   my $ciphertext_hex = $cipher->encrypt_hex($plaintext);
  60
  61   return $ciphertext_hex;
  62 }
  63
  64 sub Decrypt {
  65   my $hexkey = shift;
  66   my $ciphertext_hex = shift;
  67
  68   my $cipher = Crypt::CBC->new( -key    => $hexkey, -cipher => 'Blowfish');
  69   my $plaintext = $cipher->decrypt_hex($ciphertext_hex);
  70
  71   return $plaintext;
  72 }
  73
  74 sub SavePasswordToFile {
  75   my $userid = shift;
  76   my $password = shift;
  77
  78   my $authtoken = CreateAuthToken($userid);
  79   UpdateAuthToken($authtoken, $password);
  80   return $authtoken;
  81 }
  82
  83 sub ReadPasswordFromFile {
  84   my $authtoken = shift;
  85
  86   my (undef, $hexkey) = ParseAuthToken($authtoken);
  87   my $fn = GetFNfromAuthToken($authtoken);
  88
  89   my $passwd;
  90   my $time;
  91
  92   # if we couldn't read the password file, assume user is unauthenticated. is this ok?
  93   open (F, "<", $fn) || return undef;
  94   chomp($passwd = <F>);
  95   chomp($time = <F>);
  96   close F;
  97
  98   # check to make sure we read something
  99   return undef if (!$passwd || !$time);
 100
 101   # check to make sure the time is positive, and that the auth token
 102   # has not expired
 103   my $tdiff = (time - $time);
 104   &HTMLError("Your authentication token has expired. Please <a href=\"https://$ENV{SERVER_NAME}/$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
 105
 106   return Decrypt($hexkey, $passwd);
 107 }
 108
 109 # given an authtoken and an unencoded username, check that the username matches the
 110 # encoded and maced username in the authtoken
 111 sub VerifyCryptedUserMatches {
 112   my $authtoken = shift;
 113   my $userid = shift;
 114
 115   my ($crypteduserid, undef) = ParseAuthToken($authtoken);
 116
 117   $crypteduserid =~ y,_,/,; # reversee translation from slashes to underscores
 118   my $res = crypt($userid, $crypteduserid);
 119
 120   HTMLError("Failed to validate user authtoken\n") unless ($res eq $crypteduserid);
 121 }
 122
 123 # given an authtoken and username, update lifetime of the authtoken, if it validates.
 124 sub TouchAuthToken {
 125   my $authtoken = shift;
 126   my $userid = shift;
 127
 128   VerifyCryptedUserMatches($authtoken, $userid);
 129
 130   my $r = ReadPasswordFromFile($authtoken);
 131   if ($r) {
 132     UpdateAuthToken($authtoken, $r);
 133   } else {
 134     ClearAuthToken($authtoken);
 135   }
 136   return $r;
 137 }
 138
 139 # clear an authtoken's file from disk, if it validates.
 140 sub ClearAuthToken {
 141   my $authtoken = shift;
 142
 143   my $fn = GetFNfromAuthToken($authtoken);
 144
 145   unlink $fn || &HTMLError("Error removing authtoken: $!");
 146 }
 147
 148 # Load the base key for our keyed hash function from disk and
 149 # compute a derived key for use in our HMAC function.
 150 sub getAuthTokenHMACkey {
 151   open (F, "<$config{passdir}/key-hmac-$UID") || &Util::HTMLError($!);
 152   my $base_hmac_key = <F>;
 153   close(F);
 154   chomp($base_hmac_key);
 155
 156   my $derived_key_hmac = hmac_sha1_hex("authtoken hmac key", $base_hmac_key);
 157   return $derived_key_hmac;
 158 }
 159
 160 # return a Mac (Message Authentication Code) for data.
 161 sub getDataMac {
 162   my $data = shift;
 163
 164   my $hmac_key = getAuthTokenHMACkey();
 165   my $hmac = hmac_sha1_hex($data, $hmac_key);
 166
 167   return $hmac;
 168 }
 169
 170 # Given a userid, create an authtoken.
 171 #
 172 # The authtoken consists of the encoded username and a key to decrypt the
 173 # password stored on disk.  the authtoken is protected from modification
 174 # by an hmac.
 175 sub CreateAuthToken {
 176   my $userid = shift;
 177
 178   my $cryptuser = crypt($userid, CreateCryptSalt(1));
 179   $cryptuser =~ y,/,_,; # translate slashes to underscores
 180
 181   my $key = &Util::CreateKey($config{blowfishkeylen});
 182   my $hexkey = unpack("H".($config{blowfishkeylen}*2), $key);
 183
 184   my $data = "$cryptuser,$hexkey";
 185   my $hmac = getDataMac($data);
 186   my $authtoken = "$hmac,$data";
 187
 188   return $authtoken;
 189 }
 190
 191 # Parse an authtoken into encoded userid and key information and validate its mac.
 192 sub ParseAuthToken {
 193   my $authtoken = shift;
 194   my ($hmac_got, $data) = split(/,/, $authtoken, 2);
 195   my $hmac_want = getDataMac($data);
 196
 197   HTMLError("Failed to validate authtoken\n") unless ($hmac_got eq $hmac_want);
 198
 199   my ($cryptuserid, $hexkey) = split(/,/, $data, 2);
 200   return ($cryptuserid, $hexkey);
 201 }
 202
 203 # Given an authtoken, return the path to the on-disk encrypted session file
 204 sub GetFNfromAuthToken {
 205   my $authtoken = shift;
 206   my ($cryptuserid, undef) = ParseAuthToken($authtoken);
 207
 208   my $fn = "$config{authtokenpath}/$cryptuserid";
 209   return $fn;
 210 }
 211
 212 # Given an authtoken and a password, write the password to disk encrypted by the authtoken's key.
 213 sub UpdateAuthToken {
 214   my $authtoken = shift;
 215   my $password = shift;
 216   my (undef, $hexkey) = ParseAuthToken($authtoken);
 217
 218   my $secret = Encrypt($hexkey, $password);
 219   my $fn = GetFNfromAuthToken($authtoken);
 220
 221   my $saveumask = umask 077;
 222   open (F, ">", $fn) || &HTMLError("$fn: $!");
 223   print F "$secret\n";
 224   print F time."\n";
 225   close F;
 226   umask $saveumask;
 227
 228   return 1;
 229 }
 230
 231
 232 sub FormatFingerPrint {
 233   my $in = shift;
 234   my $out;
 235
 236   if (length($in) == 32) {
 237     foreach (0..15) {
 238       $out .= substr($in, $_*2, 2)." ";
 239       $out .= "&nbsp;" if ($_ == 7);
 240     }
 241   } else {
 242     foreach (0..int(length($in)/4)) {
 243       $out .= substr($in, $_*4, 4)." ";
 244     }
 245   }
 246   chop $out;
 247   return $out;
 248 }
 249
 250 sub FetchKey {
 251   my $fingerprint = shift;
 252   my $signatures = shift;
 253   my ($out, $keyringparam) = undef;
 254
 255   foreach (split(/:/, $config{keyrings})) {
 256     $keyringparam .= "--keyring $_ ";
 257   }
 258
 259   $fingerprint =~ s/\s//g;
 260   $fingerprint = "0x".$fingerprint;
 261
 262   local $ENV{PATH} = '';
 263   $/ = undef; # just suck it up ....
 264   if ($signatures) {
 265       open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
 266       $out = <FP>;
 267       close FP;
 268   }
 269   open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
 270   $out .= <FP>;
 271   close FP;
 272   $/ = "\n";
 273
 274   return $out;
 275 }
 276
 277 sub FormatTimestamp {
 278   my $in = shift;
 279   $in =~ /^(....)(..)(..)(..)(..)(..)/;
 280
 281   return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
 282 }
 283
 284 sub FormatLastSeen {
 285 # Format:
 286 # [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
 287 # [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>"
 288   my $lastseenpgp = shift;
 289   my $lastseenfrom = shift;
 290   my ($d1, $d2, $lastseen);
 291
 292   return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
 293   $lastseen = $lastseenpgp;
 294   $lastseen = $lastseenfrom if (!$lastseenpgp);
 295
 296   if ($lastseenfrom && $lastseenpgp) {
 297     ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);
 298     ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
 299     $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
 300   }
 301
 302   my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.*?|\-)"\s+"(<.+?>)"/);
 303   $list = "on $list" if ($list);
 304   $date = CGI::escapeHTML($date);
 305   $user = CGI::escapeHTML($user);
 306   $list = CGI::escapeHTML($list);
 307   $msgid = CGI::escapeHTML($msgid);
 308   return "$date $list<br>&nbsp;Message ID: $msgid";
 309 }
 310
 311 sub LookupCountry {
 312   my $in = shift;
 313   my ($abbrev, $country);
 314   open (F, $config{countrylist}) || return uc($in);
 315   while (<F>) {
 316     chomp;
 317     ($abbrev, $country) = split(/\s+/, $_, 2);
 318     if ($abbrev eq $in) {
 319       close F;
 320       return $country;
 321     }
 322   }
 323   close F;
 324   return uc($in);
 325 }
 326
 327 ####################
 328 # Some HTML Routines
 329
 330 my $htmlhdrsent = 0;
 331
 332 sub HTMLSendHeader {
 333   print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
 334   $htmlhdrsent = 1;
 335 }
 336
 337 sub HTMLPrint {
 338   &HTMLSendHeader if (!$htmlhdrsent);
 339   print shift;
 340 }
 341
 342 sub HTMLError {
 343   HTMLPrint(shift);
 344   die "\n";
 345 }
 346
 347 sub CheckLatLong {
 348   my ($lat, $long) = @_;
 349
 350   $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
 351
 352   if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
 353     return ($lat, $long);
 354   } else {
 355     return ("", "");
 356   }
 357 }
 358
 359 sub FixParams {
 360   my $query = shift;
 361   my $key;
 362   my @names = $query->param;
 363
 364   foreach $key (@names) { # web security is a joke ... <sigh>
 365     $_ = $query->param($key);
 366     s/&/&amp;/g;
 367     s/[<\x8B]/&lt;/g;
 368     s/[>\x9B]/&gt;/g;
 369
 370     $query->param($key, $_);
 371   }
 372 }
 373
 374
 375 sub LDAPUpdate {
 376   my $ldap = shift;
 377   my $dn = shift;
 378   my $attr = shift;
 379   my $val = shift;
 380   my $mesg;
 381
 382   if (!$val) {
 383     $mesg = $ldap->modify($dn, delete => { $attr => [] });
 384   } else {
 385     $val = [ $val ] if (!ref($val));
 386     $mesg = $ldap->modify($dn, replace => { $attr => $val });
 387     $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
 388   }
 389 }
 390
 391 ###################
 392 # Config file stuff
 393 sub ReadConfigFile {
 394   # reads a config file and results a hashref with the results
 395   my (%config, $attr, $setting);
 396   open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
 397   while (<F>) {
 398     chomp;
 399     if ((!/^\s*#/) && ($_ ne "")) {
 400       # Chop off any trailing comments
 401       s/#.*//;
 402       /([^=]+)=(.*)/;
 403       ($attr, $setting) = ($1, $2);
 404       $setting =~ s/"//g; #"
 405       $setting =~ s/;$//;
 406       $attr =~ s/^\s+//; $attr =~ s/\s+$//;
 407       $setting =~ s/^\s+//; $setting =~ s/\s+$//;
 408       $config{$attr} = $setting;
 409     }
 410   }
 411   close F;
 412   return %config;
 413 }
 414
 415 sub UpgradeConnection($) {
 416   my ($ldap) = @_;
 417   my $mesg = $ldap->start_tls(
 418                           verify => 'require',
 419                           cafile => $config{sslcafile},
 420                           );
 421   $mesg->sync;
 422   if ($mesg->code != LDAP_SUCCESS) {
 423     print "Content-type: text/html; charset=utf-8\n\n";
 424     print "<html><body><h1>STARTTLS failed: ".$mesg->error."</h1></body></html>\n";
 425     exit(1);
 426   };
 427 };
 428
 429 sub readwrite3($$$$) {
 430   my ($in, $inputfd, $stdoutfd, $stderrfd) = @_;
 431
 432   #Echolot::Log::trace("Entering readwrite_gpg.");
 433
 434   local $INPUT_RECORD_SEPARATOR = undef;
 435   my $sout = IO::Select->new();
 436   my $sin = IO::Select->new();
 437   my $offset = 0;
 438
 439   #Echolot::Log::trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 440
 441   $inputfd->blocking(0);
 442   $stdoutfd->blocking(0);
 443   $stderrfd->blocking(0);
 444   $sout->add($stdoutfd);
 445   $sout->add($stderrfd);
 446   $sin->add($inputfd);
 447
 448   my ($stdout, $stderr) = ("", "", "");
 449
 450   my ($readyr, $readyw);
 451   while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 452     #Echolot::Log::trace("select waiting for ".($sout->count())." fds.");
 453     ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, 42);
 454     #Echolot::Log::trace("ready: write: ".(defined $readyw ? scalar @$readyw : 'none')."; read: ".(defined $readyr ? scalar @$readyr : 'none'));
 455     for my $wfd (@$readyw) {
 456       #Echolot::Log::trace("writing to $wfd.");
 457       my $written = 0;
 458       if ($offset != length($in)) {
 459         $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 460       }
 461       unless (defined ($written)) {
 462         #Echolot::Log::warn("Error while writing to GnuPG: $!");
 463         close $wfd;
 464         $sin->remove($wfd);
 465         $sin = undef;
 466       } else {
 467         $offset += $written;
 468         if ($offset == length($in)) {
 469           #Echolot::Log::trace("writing to $wfd done.");
 470           close $wfd;
 471           $sin->remove($wfd);
 472           $sin = undef;
 473         }
 474       }
 475     }
 476
 477     next unless (defined(@$readyr)); # Wait some more.
 478
 479     for my $rfd (@$readyr) {
 480       if ($rfd->eof) {
 481         #Echolot::Log::trace("reading from $rfd done.");
 482         $sout->remove($rfd);
 483         close($rfd);
 484         next;
 485       }
 486       #Echolot::Log::trace("reading from $rfd.");
 487       if ($rfd == $stdoutfd) {
 488         $stdout .= <$rfd>;
 489         next;
 490       }
 491       if ($rfd == $stderrfd) {
 492         $stderr .= <$rfd>;
 493         next;
 494       }
 495     }
 496   }
 497   #Echolot::Log::trace("readwrite_gpg done.");
 498   return ($stdout, $stderr);
 499 };
 500
 501 sub checkPasswordQuality($$$) {
 502   my ($pw, $oldpw, $ldapelements) = @_;
 503   my ($stdinR, $stdinW) = (IO::Handle->new(), IO::Handle->new());
 504   my ($stdoutR, $stdoutW) = (IO::Handle->new(), IO::Handle->new());
 505   my ($stderrR, $stderrW) = (IO::Handle->new(), IO::Handle->new());
 506   pipe $stdinR, $stdinW;
 507   pipe $stdoutR, $stdoutW;
 508   pipe $stderrR, $stderrW;
 509
 510   my $pid = fork();
 511   unless (defined $pid) {
 512     return (2, "Could not fork: $!");
 513   };
 514   unless ($pid) { # child
 515     $stdinW->close;
 516     $stdoutR->close;
 517     $stderrR->close;
 518     close STDIN;
 519     close STDOUT;
 520     close STDERR;
 521     open (STDIN, "<&".$stdinR->fileno) or warn ("Cannot dup stdinR (fd ".$stdinR->fileno.") as STDIN: $!");
 522     open (STDOUT, ">&".$stdoutW->fileno) or warn ("Cannot dup stdoutW (fd ".$stdoutW->fileno.") as STDOUT: $!");
 523     open (STDERR, ">&".$stderrW->fileno) or warn ("Cannot dup stderrW (fd ".$stderrW->fileno.") as STDERR: $!");
 524     { exec('/usr/lib/userdir-ldap-cgi/password-qualify-check'); }
 525     $stderrW->print("Could not exec password-qualify-check: $!\n");
 526     exit(1);
 527   };
 528   $stdinR->close;
 529   $stdoutW->close;
 530   $stderrW->close;
 531
 532   $oldpw = '' unless defined $oldpw;
 533   my $out = join("\n", $pw, $oldpw, @$ldapelements)."\n";
 534   my ($stdout, $stderr) = readwrite3($out, $stdinW, $stdoutR, $stderrR);
 535   waitpid $pid, 0;
 536
 537   my $exitcode = $? >> 8;
 538   if ($exitcode == 0 && $stdout eq '' && $stderr eq '') {
 539     return (0, "ok");
 540   } elsif ($exitcode == 1 && $stderr eq '') {
 541     return (1, $stdout);
 542   } else {
 543     return (2, "check exited with exit code $exitcode, said '$stdout' on stdout, and '$stderr' on stderr.");
 544   };
 545 };
 546 1;