# -*- 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 Peter Palfrader

package Util;

use strict;
use Date::Manip qw(ParseDate);
use Net::LDAP qw(LDAP_SUCCESS LDAP_PROTOCOL_ERROR);
use English;

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;

my $hascryptix = 1;
eval 'use Crypt::Blowfish';
if ($@) {
  $hascryptix = undef;
}

sub CreateKey {
  my $keysize = shift;
  my $input;
  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 {
  # this can create either a DES type salt or a MD5 salt
  my $md5 = shift; # do we want a MD5 salt?
  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);
}

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);

  # prepend a length byte */
  $input = chr(length($input)).$input;
  $input .= "\001" x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));

  for ($pos = 0; $pos < length($input); $pos += $blocksize) {    
    $output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize))) if ($hascryptix);
  }
  return $output;
}

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, $len);
  
  ((length($input) % $blocksize) == 0) || &HTMLError("Password corrupted"); # should always be true...

  for ($pos = 0; $pos < length($input); $pos += $blocksize*2) {
    $portion = pack("H16", substr($input, $pos, $blocksize*2));
    $output .= $cipher->decrypt($portion) if ($hascryptix);
  }
  
  # check length byte, discard junk
  $len = substr($output, 0, 1);
  $output = substr($output, 1, ord($len));
  return $output;
}

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;
}

sub ReadPasswordFromFile {
  my $userid = shift;
  my $cipher = shift;
  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; 
  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=\"https://$ENV{SERVER_NAME}/$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
  
  return Decrypt($cipher, $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);
  if ($r) {
    UpdateAuthToken("$id,$hrkey", $r);
  } else {    
    ClearAuthToken("$id,$hrkey")
  }
  return $r;
}

sub ClearAuthToken {
  my ($id, $hrkey) = split(/,/, shift, 2);
  $id =~ y/\//_/; # switch / to _
  unlink "$config{authtokenpath}/$id" || &HTMLError("Error removing authtoken: $!");
}

sub UpdateAuthToken {
  my ($id, $hrkey) = split(/,/, shift, 2);
  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: $!");
  print F "$secret\n";
  print F time."\n";
  close F;
  chmod 0600, "$fn" || &HTMLError("$fn: $!");
  return 1;
}

sub FormatFingerPrint {
  my $in = shift;
  my $out;
  
  if (length($in) == 32) {
    foreach (0..15) {
      $out .= substr($in, $_*2, 2)." ";
      $out .= "&nbsp;" if ($_ == 7);
    }      
  } else {
    foreach (0..int(length($in)/4)) {
      $out .= substr($in, $_*4, 4)." ";
    }      
  }
  chop $out;
  return $out;
}

sub FetchKey {
  my $fingerprint = shift;
  my $signatures = shift;
  my ($out, $keyringparam) = undef;
  
  foreach (split(/:/, $config{keyrings})) {
    $keyringparam .= "--keyring $_ ";
  }
  
  $fingerprint =~ s/\s//g;
  $fingerprint = "0x".$fingerprint;

  local $ENV{PATH} = '';
  $/ = undef; # just suck it up ....
  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";
  
  return $out;
}

sub FormatTimestamp {
  my $in = shift;
  $in =~ /^(....)(..)(..)(..)(..)(..)/;
  
  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);
  open (F, $config{countrylist}) || return uc($in);
  while (<F>) {
    chomp;
    ($abbrev, $country) = split(/\s+/, $_, 2);
    if ($abbrev eq $in) {
      close F;
      return $country;
    }
  }
  close F;
  return uc($in);
}

####################
# Some HTML Routines

my $htmlhdrsent = 0;

sub HTMLSendHeader {
  print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
  $htmlhdrsent = 1;
}

sub HTMLPrint {
  &HTMLSendHeader if (!$htmlhdrsent);
  print shift;
}

sub HTMLError {
  HTMLPrint(shift);
  die "\n";
}

sub CheckLatLong {
  my ($lat, $long) = @_;

  $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
  
  if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
    return ($lat, $long);
  } else {
    return ("", "");
  }
}

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 {
  # reads a config file and results a hashref with the results
  my (%config, $attr, $setting);
  open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
  while (<F>) {
    chomp;
    if ((!/^\s*#/) && ($_ ne "")) {
      # Chop off any trailing comments
      s/#.*//;
      /([^=]+)=(.*)/;
      ($attr, $setting) = ($1, $2);
      $setting =~ s/"//g; #"
      $setting =~ s/;$//;
      $attr =~ s/^\s+//; $attr =~ s/\s+$//;
      $setting =~ s/^\s+//; $setting =~ s/\s+$//;      
      $config{$attr} = $setting;
    }
  }
  close F;
  return %config;
}

sub UpgradeConnection($) {
  my ($ldap) = @_;
  my $mesg = $ldap->start_tls(
                          verify => 'require',
                          cafile => '/etc/ssl/certs/spi-cacert-2008.pem'
                          );
  $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 (defined(@$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;
