X-Git-Url: https://git.adam-barratt.org.uk/?p=mirror%2Fuserdir-ldap-cgi.git;a=blobdiff_plain;f=Util.pm;h=c292a1a1e87797b1333f3db474f489088630cc1d;hp=4cbec32fb1bd5c1f0b8f1594ee6b1504e643283b;hb=HEAD;hpb=e6df6b1b8d41c41c712173d0d3ff4cda5f9fa315

diff --git a/Util.pm b/Util.pm
index 4cbec32..c292a1a 100644
--- a/Util.pm
+++ b/Util.pm
@@ -1,155 +1,234 @@
 # -*- perl -*-x
+
+# Copyright (c) 1999-2006  Debian Admin Team Members and Developers    (taken from debian/copyright in 2008 by weasel)
+# Copyright (c) 2002, 2003, 2004, 2008, 2009, 2011, 2012, 2014, 2015 Peter Palfrader
+
 package Util;
 
 use strict;
-use Crypt::Blowfish;
+use Date::Manip qw(ParseDate);
+use Net::LDAP qw(LDAP_SUCCESS LDAP_PROTOCOL_ERROR);
+use English;
+use Crypt::CBC;
+use Digest::HMAC_SHA1 qw(hmac_sha1_hex);
 
 my $blocksize = 8; # A blowfish block is 8 bytes
 my $configfile = "/etc/userdir-ldap/userdir-ldap.conf";
+#my $configfile = "/home/randolph/html/debian/perl/userdir-ldap.conf";
 
 my %config = &ReadConfigFile;
 
 sub CreateKey {
   my $keysize = shift;
   my $input;
-  open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
+  open (F, "<", "/dev/urandom") || die &HTMLError("No /dev/urandom found!");
   read(F, $input, $keysize); # key length is 8 bytes
   close F;
-  
+
   return $input;
 }
 
 sub CreateCryptSalt {
+  # CreateCryptSalt(type = 0, skip_header = 0)
   # this can create either a DES type salt or a MD5 salt
+  # 0 for DES, 1 for MD5 salt
+  # if skip_header is 0, does not add $1$ for md5 salts.
   my $md5 = shift; # do we want a MD5 salt?
+  my $no_crypttype_header = shift;
   my $validstr = './0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
   my @valid = split(//,$validstr);
   my ($in, $out);
-  
+
   my $cryptsaltlen = ($md5 ? 8 : 2);
-  
+
   open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
   foreach (1..$cryptsaltlen) {
     read(F, $in, 1);
     $out .= $valid[ord($in) % ($#valid + 1)];
   }
   close F;
-  return ($md5 ? "\$1\$$out\$" : $out);
+  if ($md5 == 1 && !$no_crypttype_header) { $out = "\$1\$$out\$"; }
+  return $out
 }
 
-sub Encrypt { 
-  # blowfish only encrypts things in blocks of 8 bytes, so we
-  # need a custom routine that handles longer strings....
-  my $cipher = shift;
-  my $input = shift;
-  my ($pos, $output);
+sub Encrypt {
+  my $hexkey = shift;
+  my $plaintext = shift;
 
-  $input .= " " x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));
+  my $cipher = Crypt::CBC->new( -key    => $hexkey, -cipher => 'Blowfish');
+  my $ciphertext_hex = $cipher->encrypt_hex($plaintext);
 
-  for ($pos = 0; $pos < length($input); $pos += $blocksize) {
-    $output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize)));
-  }
-  return $output;
+  return $ciphertext_hex;
 }
 
 sub Decrypt {
-  # like encrypt, needs to deal with big blocks. Note that we assume
-  # trailing spaces are unimportant.
-  my $cipher = shift;
-  my $input = shift;
-  my ($pos, $portion, $output);
-  
-  ((length($input) % $blocksize) == 0) || &HTMLError("Password corrupted"); # should always be true...
+  my $hexkey = shift;
+  my $ciphertext_hex = shift;
 
-  for ($pos = 0; $pos < length($input); $pos += $blocksize*2) {
-    $portion = pack("H16", substr($input, $pos, $blocksize*2));
-    $output .= $cipher->decrypt($portion);
-  }
-    
-  $output =~ s/ +$//;
-  return $output;
+  my $cipher = Crypt::CBC->new( -key    => $hexkey, -cipher => 'Blowfish');
+  my $plaintext = $cipher->decrypt_hex($ciphertext_hex);
+
+  return $plaintext;
 }
 
 sub SavePasswordToFile {
   my $userid = shift;
   my $password = shift;
-  my $cipher = shift;
 
-  my $cryptuser = crypt($userid, &CreateCryptSalt);
-  my $secret = Encrypt($cipher, $password);
-  $cryptuser =~ y/\//_/; # translate slashes to underscores...
-  
-  my $fn = "$config{authtokenpath}/$cryptuser";
-  open (F, ">$fn") || &HTMLError("$fn: $!");
-  print F "$secret\n";
-  print F time."\n";
-  close F;
-  chmod 0600, $fn;
-  return $cryptuser;
+  my $authtoken = CreateAuthToken($userid);
+  UpdateAuthToken($authtoken, $password);
+  return $authtoken;
 }
 
 sub ReadPasswordFromFile {
-  my $userid = shift;
-  my $cipher = shift;
+  my $authtoken = shift;
+
+  my (undef, $hexkey) = ParseAuthToken($authtoken);
+  my $fn = GetFNfromAuthToken($authtoken);
+
   my $passwd;
   my $time;
-  
-  $userid =~ y/\//_/; # translate slashes to underscores...
 
   # if we couldn't read the password file, assume user is unauthenticated. is this ok?
-  open (F, "<$config{authtokenpath}/$userid") || return undef; 
+  open (F, "<", $fn) || return undef;
   chomp($passwd = <F>);
   chomp($time = <F>);
   close F; 
 
   # check to make sure we read something
   return undef if (!$passwd || !$time);
-  
+
   # check to make sure the time is positive, and that the auth token
   # has not expired
   my $tdiff = (time - $time);
-  &HTMLError("Your authentication token has expired. Please <a href=\"$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
-  
-  return Decrypt($cipher, $passwd);
+  &HTMLError("Your authentication token has expired. Please <a href=\"https://$ENV{SERVER_NAME}/$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
+
+  return Decrypt($hexkey, $passwd);
 }
 
-sub CheckAuthToken {
-  my ($id, $hrkey) = split(/:/, shift, 2);
-  return undef if (!$id || !$hrkey);
-  my $key = pack("H".(length($hrkey)), $hrkey);
-  my $cipher = new Crypt::Blowfish $key;
-  my $r = ReadPasswordFromFile($id, $cipher);
+# given an authtoken and an unencoded username, check that the username matches the
+# encoded and maced username in the authtoken
+sub VerifyCryptedUserMatches {
+  my $authtoken = shift;
+  my $userid = shift;
+
+  my ($crypteduserid, undef) = ParseAuthToken($authtoken);
+
+  $crypteduserid =~ y,_,/,; # reversee translation from slashes to underscores
+  my $res = crypt($userid, $crypteduserid);
+
+  HTMLError("Failed to validate user authtoken\n") unless ($res eq $crypteduserid);
+}
+
+# given an authtoken and username, update lifetime of the authtoken, if it validates.
+sub TouchAuthToken {
+  my $authtoken = shift;
+  my $userid = shift;
+
+  VerifyCryptedUserMatches($authtoken, $userid);
+
+  my $r = ReadPasswordFromFile($authtoken);
   if ($r) {
-    UpdateAuthToken("$id:$hrkey", $r);
-  } else {    
-    ClearAuthToken("$id:$hrkey")
+    UpdateAuthToken($authtoken, $r);
+  } else {
+    ClearAuthToken($authtoken);
   }
   return $r;
 }
 
+# clear an authtoken's file from disk, if it validates.
 sub ClearAuthToken {
-  my ($id, $hrkey) = split(/:/, shift, 2);
-  $id =~ y/\//_/; # switch / to _
-  unlink "$config{authtokenpath}/$id" || &HTMLError("Error removing authtoken: $!");
+  my $authtoken = shift;
+
+  my $fn = GetFNfromAuthToken($authtoken);
+
+  unlink $fn || &HTMLError("Error removing authtoken: $!");
+}
+
+# Load the base key for our keyed hash function from disk and
+# compute a derived key for use in our HMAC function.
+sub getAuthTokenHMACkey {
+  open (F, "<$config{passdir}/key-hmac-$UID") || &Util::HTMLError($!);
+  my $base_hmac_key = <F>;
+  close(F);
+  chomp($base_hmac_key);
+
+  my $derived_key_hmac = hmac_sha1_hex("authtoken hmac key", $base_hmac_key);
+  return $derived_key_hmac;
 }
 
+# return a Mac (Message Authentication Code) for data.
+sub getDataMac {
+  my $data = shift;
+
+  my $hmac_key = getAuthTokenHMACkey();
+  my $hmac = hmac_sha1_hex($data, $hmac_key);
+
+  return $hmac;
+}
+
+# Given a userid, create an authtoken.
+#
+# The authtoken consists of the encoded username and a key to decrypt the
+# password stored on disk.  the authtoken is protected from modification
+# by an hmac.
+sub CreateAuthToken {
+  my $userid = shift;
+
+  my $cryptuser = crypt($userid, CreateCryptSalt(1));
+  $cryptuser =~ y,/,_,; # translate slashes to underscores
+
+  my $key = &Util::CreateKey($config{blowfishkeylen});
+  my $hexkey = unpack("H".($config{blowfishkeylen}*2), $key);
+
+  my $data = "$cryptuser,$hexkey";
+  my $hmac = getDataMac($data);
+  my $authtoken = "$hmac,$data";
+
+  return $authtoken;
+}
+
+# Parse an authtoken into encoded userid and key information and validate its mac.
+sub ParseAuthToken {
+  my $authtoken = shift;
+  my ($hmac_got, $data) = split(/,/, $authtoken, 2);
+  my $hmac_want = getDataMac($data);
+
+  HTMLError("Failed to validate authtoken\n") unless ($hmac_got eq $hmac_want);
+
+  my ($cryptuserid, $hexkey) = split(/,/, $data, 2);
+  return ($cryptuserid, $hexkey);
+}
+
+# Given an authtoken, return the path to the on-disk encrypted session file
+sub GetFNfromAuthToken {
+  my $authtoken = shift;
+  my ($cryptuserid, undef) = ParseAuthToken($authtoken);
+
+  my $fn = "$config{authtokenpath}/$cryptuserid";
+  return $fn;
+}
+
+# Given an authtoken and a password, write the password to disk encrypted by the authtoken's key.
 sub UpdateAuthToken {
-  my ($id, $hrkey) = split(/:/, shift, 2);
+  my $authtoken = shift;
   my $password = shift;
-  my $key = pack("H".(length($hrkey)), $hrkey);
-  $id =~ y/\//_/; # switch / to _
-  my $cipher = new Crypt::Blowfish $key;
-  my $secret = Encrypt($cipher, $password);
-  
-  my $fn = "$config{authtokenpath}/$id";
-  open (F, ">$fn") || &HTMLError("$fn: $!");
+  my (undef, $hexkey) = ParseAuthToken($authtoken);
+
+  my $secret = Encrypt($hexkey, $password);
+  my $fn = GetFNfromAuthToken($authtoken);
+
+  my $saveumask = umask 077;
+  open (F, ">", $fn) || &HTMLError("$fn: $!");
   print F "$secret\n";
   print F time."\n";
   close F;
-  chmod 0600, "$fn" || &HTMLError("$fn: $!");
+  umask $saveumask;
+
   return 1;
 }
 
+
 sub FormatFingerPrint {
   my $in = shift;
   my $out;
@@ -160,16 +239,18 @@ sub FormatFingerPrint {
       $out .= "&nbsp;" if ($_ == 7);
     }      
   } else {
-    foreach (0..int(length($in)/2)) {
+    foreach (0..int(length($in)/4)) {
       $out .= substr($in, $_*4, 4)." ";
     }      
   }
+  chop $out;
   return $out;
 }
 
 sub FetchKey {
   my $fingerprint = shift;
-  my ($out, $keyringparam);
+  my $signatures = shift;
+  my ($out, $keyringparam) = undef;
   
   foreach (split(/:/, $config{keyrings})) {
     $keyringparam .= "--keyring $_ ";
@@ -178,11 +259,14 @@ sub FetchKey {
   $fingerprint =~ s/\s//g;
   $fingerprint = "0x".$fingerprint;
 
+  local $ENV{PATH} = '';
   $/ = undef; # just suck it up ....
-  open(FP, "$config{gpg} $keyringparam --list-sigs --fingerprint $fingerprint|");
-  $out = <FP>;
-  close FP;
-  open(FP, "$config{gpg} $keyringparam --export -a $fingerprint|");
+  if ($signatures) {
+      open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
+      $out = <FP>;
+      close FP;
+  }
+  open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
   $out .= <FP>;
   close FP;
   $/ = "\n";
@@ -197,6 +281,33 @@ sub FormatTimestamp {
   return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
 }
 
+sub FormatLastSeen {
+# Format:
+# [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
+# [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>"
+  my $lastseenpgp = shift;
+  my $lastseenfrom = shift;
+  my ($d1, $d2, $lastseen);
+
+  return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
+  $lastseen = $lastseenpgp;
+  $lastseen = $lastseenfrom if (!$lastseenpgp);
+
+  if ($lastseenfrom && $lastseenpgp) {
+    ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);
+    ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
+    $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
+  }
+
+  my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.*?|\-)"\s+"(<.+?>)"/);
+  $list = "on $list" if ($list);
+  $date = CGI::escapeHTML($date);
+  $user = CGI::escapeHTML($user);
+  $list = CGI::escapeHTML($list);
+  $msgid = CGI::escapeHTML($msgid);
+  return "$date $list<br>&nbsp;Message ID: $msgid";
+}
+
 sub LookupCountry {
   my $in = shift;
   my ($abbrev, $country);
@@ -219,7 +330,7 @@ sub LookupCountry {
 my $htmlhdrsent = 0;
 
 sub HTMLSendHeader {
-  print "Content-type: text/html\n\n" if (!$htmlhdrsent);
+  print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
   $htmlhdrsent = 1;
 }
 
@@ -245,6 +356,38 @@ sub CheckLatLong {
   }
 }
 
+sub FixParams {
+  my $query = shift;
+  my $key;
+  my @names = $query->param;
+
+  foreach $key (@names) { # web security is a joke ... <sigh>
+    $_ = $query->param($key);
+    s/&/&amp;/g; 
+    s/[<\x8B]/&lt;/g;
+    s/[>\x9B]/&gt;/g;
+
+    $query->param($key, $_);
+  }
+}   
+
+  
+sub LDAPUpdate {
+  my $ldap = shift;
+  my $dn = shift;
+  my $attr = shift;
+  my $val = shift;
+  my $mesg;
+  
+  if (!$val) {
+    $mesg = $ldap->modify($dn, delete => { $attr => [] });
+  } else {
+    $val = [ $val ] if (!ref($val));
+    $mesg = $ldap->modify($dn, replace => { $attr => $val });
+    $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
+  }
+}
+
 ###################
 # Config file stuff
 sub ReadConfigFile {
@@ -256,11 +399,12 @@ sub ReadConfigFile {
     if ((!/^\s*#/) && ($_ ne "")) {
       # Chop off any trailing comments
       s/#.*//;
-      ($attr, $setting) = split(/=/, $_, 2);
-      $setting =~ s/"//g;
+      /([^=]+)=(.*)/;
+      ($attr, $setting) = ($1, $2);
+      $setting =~ s/"//g; #"
       $setting =~ s/;$//;
-      $attr =~ s/^ +//; $attr =~ s/ +$//;
-      $setting =~ s/^ +//; $setting =~ s/ +$//;      
+      $attr =~ s/^\s+//; $attr =~ s/\s+$//;
+      $setting =~ s/^\s+//; $setting =~ s/\s+$//;      
       $config{$attr} = $setting;
     }
   }
@@ -268,4 +412,135 @@ sub ReadConfigFile {
   return %config;
 }
 
+sub UpgradeConnection($) {
+  my ($ldap) = @_;
+  my $mesg = $ldap->start_tls(
+                          verify => 'require',
+                          cafile => $config{sslcafile},
+                          );
+  $mesg->sync;
+  if ($mesg->code != LDAP_SUCCESS) {
+    print "Content-type: text/html; charset=utf-8\n\n";
+    print "<html><body><h1>STARTTLS failed: ".$mesg->error."</h1></body></html>\n";
+    exit(1);
+  };
+};
+
+sub readwrite3($$$$) {
+  my ($in, $inputfd, $stdoutfd, $stderrfd) = @_;
+
+  #Echolot::Log::trace("Entering readwrite_gpg.");
+
+  local $INPUT_RECORD_SEPARATOR = undef;
+  my $sout = IO::Select->new();
+  my $sin = IO::Select->new();
+  my $offset = 0;
+
+  #Echolot::Log::trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
+
+  $inputfd->blocking(0);
+  $stdoutfd->blocking(0);
+  $stderrfd->blocking(0);
+  $sout->add($stdoutfd);
+  $sout->add($stderrfd);
+  $sin->add($inputfd);
+
+  my ($stdout, $stderr) = ("", "", "");
+
+  my ($readyr, $readyw);
+  while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
+    #Echolot::Log::trace("select waiting for ".($sout->count())." fds.");
+    ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, 42);
+    #Echolot::Log::trace("ready: write: ".(defined $readyw ? scalar @$readyw : 'none')."; read: ".(defined $readyr ? scalar @$readyr : 'none'));
+    for my $wfd (@$readyw) {
+      #Echolot::Log::trace("writing to $wfd.");
+      my $written = 0;
+      if ($offset != length($in)) {
+        $written = $wfd->syswrite($in, length($in) - $offset, $offset);
+      }
+      unless (defined ($written)) {
+        #Echolot::Log::warn("Error while writing to GnuPG: $!");
+        close $wfd;
+        $sin->remove($wfd);
+        $sin = undef;
+      } else {
+        $offset += $written;
+        if ($offset == length($in)) {
+          #Echolot::Log::trace("writing to $wfd done.");
+          close $wfd;
+          $sin->remove($wfd);
+          $sin = undef;
+        }
+      }
+    }
+
+    next unless (@$readyr); # Wait some more.
+
+    for my $rfd (@$readyr) {
+      if ($rfd->eof) {
+        #Echolot::Log::trace("reading from $rfd done.");
+        $sout->remove($rfd);
+        close($rfd);
+        next;
+      }
+      #Echolot::Log::trace("reading from $rfd.");
+      if ($rfd == $stdoutfd) {
+        $stdout .= <$rfd>;
+        next;
+      }
+      if ($rfd == $stderrfd) {
+        $stderr .= <$rfd>;
+        next;
+      }
+    }
+  }
+  #Echolot::Log::trace("readwrite_gpg done.");
+  return ($stdout, $stderr);
+};
+
+sub checkPasswordQuality($$$) {
+  my ($pw, $oldpw, $ldapelements) = @_;
+  my ($stdinR, $stdinW) = (IO::Handle->new(), IO::Handle->new());
+  my ($stdoutR, $stdoutW) = (IO::Handle->new(), IO::Handle->new());
+  my ($stderrR, $stderrW) = (IO::Handle->new(), IO::Handle->new());
+  pipe $stdinR, $stdinW;
+  pipe $stdoutR, $stdoutW;
+  pipe $stderrR, $stderrW;
+
+  my $pid = fork();
+  unless (defined $pid) {
+    return (2, "Could not fork: $!");
+  };
+  unless ($pid) { # child
+    $stdinW->close;
+    $stdoutR->close;
+    $stderrR->close;
+    close STDIN;
+    close STDOUT;
+    close STDERR;
+    open (STDIN, "<&".$stdinR->fileno) or warn ("Cannot dup stdinR (fd ".$stdinR->fileno.") as STDIN: $!");
+    open (STDOUT, ">&".$stdoutW->fileno) or warn ("Cannot dup stdoutW (fd ".$stdoutW->fileno.") as STDOUT: $!");
+    open (STDERR, ">&".$stderrW->fileno) or warn ("Cannot dup stderrW (fd ".$stderrW->fileno.") as STDERR: $!");
+    { exec('/usr/lib/userdir-ldap-cgi/password-qualify-check'); }
+    $stderrW->print("Could not exec password-qualify-check: $!\n");
+    exit(1);
+  };
+  $stdinR->close;
+  $stdoutW->close;
+  $stderrW->close;
+
+  $oldpw = '' unless defined $oldpw;
+  my $out = join("\n", $pw, $oldpw, @$ldapelements)."\n";
+  my ($stdout, $stderr) = readwrite3($out, $stdinW, $stdoutR, $stderrR);
+  waitpid $pid, 0;
+  
+  my $exitcode = $? >> 8;
+  if ($exitcode == 0 && $stdout eq '' && $stderr eq '') {
+    return (0, "ok");
+  } elsif ($exitcode == 1 && $stderr eq '') {
+    return (1, $stdout);
+  } else {
+    return (2, "check exited with exit code $exitcode, said '$stdout' on stdout, and '$stderr' on stderr.");
+  };
+};
 1;