Util.pm

   1 # -*- perl -*-x
   2 package Util;
   3
   4 use strict;
   5 use Date::Manip qw(ParseDate);
   6 use Net::LDAP qw(:all);
   7
   8 my $blocksize = 8; # A blowfish block is 8 bytes
   9 my $configfile = "/etc/userdir-ldap/userdir-ldap.conf";
  10 #my $configfile = "/home/randolph/html/debian/perl/userdir-ldap.conf";
  11
  12 my %config = &ReadConfigFile;
  13
  14 my $hascryptix = 1;
  15 eval 'use Crypt::Blowfish';
  16 if ($@) {
  17   $hascryptix = undef;
  18 }
  19
  20 sub CreateKey {
  21   my $keysize = shift;
  22   my $input;
  23   open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
  24   read(F, $input, $keysize); # key length is 8 bytes
  25   close F;
  26
  27   return $input;
  28 }
  29
  30 sub CreateCryptSalt {
  31   # this can create either a DES type salt or a MD5 salt
  32   my $md5 = shift; # do we want a MD5 salt?
  33   my $validstr = './0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
  34   my @valid = split(//,$validstr);
  35   my ($in, $out);
  36
  37   my $cryptsaltlen = ($md5 ? 8 : 2);
  38
  39   open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
  40   foreach (1..$cryptsaltlen) {
  41     read(F, $in, 1);
  42     $out .= $valid[ord($in) % ($#valid + 1)];
  43   }
  44   close F;
  45   return ($md5 ? "\$1\$$out\$" : $out);
  46 }
  47
  48 sub Encrypt {
  49   # blowfish only encrypts things in blocks of 8 bytes, so we
  50   # need a custom routine that handles longer strings....
  51   my $cipher = shift;
  52   my $input = shift;
  53   my ($pos, $output);
  54
  55   # prepend a length byte */
  56   $input = chr(length($input)).$input;
  57   $input .= "\001" x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));
  58
  59   for ($pos = 0; $pos < length($input); $pos += $blocksize) {
  60     $output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize))) if ($hascryptix);
  61   }
  62   return $output;
  63 }
  64
  65 sub Decrypt {
  66   # like encrypt, needs to deal with big blocks. Note that we assume
  67   # trailing spaces are unimportant.
  68   my $cipher = shift;
  69   my $input = shift;
  70   my ($pos, $portion, $output, $len);
  71
  72   ((length($input) % $blocksize) == 0) || &HTMLError("Password corrupted"); # should always be true...
  73
  74   for ($pos = 0; $pos < length($input); $pos += $blocksize*2) {
  75     $portion = pack("H16", substr($input, $pos, $blocksize*2));
  76     $output .= $cipher->decrypt($portion) if ($hascryptix);
  77   }
  78
  79   # check length byte, discard junk
  80   $len = substr($output, 0, 1);
  81   $output = substr($output, 1, ord($len));
  82   return $output;
  83 }
  84
  85 sub SavePasswordToFile {
  86   my $userid = shift;
  87   my $password = shift;
  88   my $cipher = shift;
  89
  90   my $cryptuser = crypt($userid, &CreateCryptSalt);
  91   my $secret = Encrypt($cipher, $password);
  92   $cryptuser =~ y/\//_/; # translate slashes to underscores...
  93
  94   my $fn = "$config{authtokenpath}/$cryptuser";
  95   open (F, ">$fn") || &HTMLError("$fn: $!");
  96   print F "$secret\n";
  97   print F time."\n";
  98   close F;
  99   chmod 0600, $fn;
 100   return $cryptuser;
 101 }
 102
 103 sub ReadPasswordFromFile {
 104   my $userid = shift;
 105   my $cipher = shift;
 106   my $passwd;
 107   my $time;
 108
 109   $userid =~ y/\//_/; # translate slashes to underscores...
 110
 111   # if we couldn't read the password file, assume user is unauthenticated. is this ok?
 112   open (F, "<$config{authtokenpath}/$userid") || return undef;
 113   chomp($passwd = <F>);
 114   chomp($time = <F>);
 115   close F;
 116
 117   # check to make sure we read something
 118   return undef if (!$passwd || !$time);
 119
 120   # check to make sure the time is positive, and that the auth token
 121   # has not expired
 122   my $tdiff = (time - $time);
 123   &HTMLError("Your authentication token has expired. Please <a href=\"https://$ENV{SERVER_NAME}/$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
 124
 125   return Decrypt($cipher, $passwd);
 126 }
 127
 128 sub CheckAuthToken {
 129   my ($id, $hrkey) = split(/,/, shift, 2);
 130   return undef if (!$id || !$hrkey);
 131   my $key = pack("H".(length($hrkey)), $hrkey);
 132   my $cipher = new Crypt::Blowfish $key;
 133   my $r = ReadPasswordFromFile($id, $cipher);
 134   if ($r) {
 135     UpdateAuthToken("$id,$hrkey", $r);
 136   } else {
 137     ClearAuthToken("$id,$hrkey")
 138   }
 139   return $r;
 140 }
 141
 142 sub ClearAuthToken {
 143   my ($id, $hrkey) = split(/,/, shift, 2);
 144   $id =~ y/\//_/; # switch / to _
 145   unlink "$config{authtokenpath}/$id" || &HTMLError("Error removing authtoken: $!");
 146 }
 147
 148 sub UpdateAuthToken {
 149   my ($id, $hrkey) = split(/,/, shift, 2);
 150   my $password = shift;
 151   my $key = pack("H".(length($hrkey)), $hrkey);
 152   $id =~ y/\//_/; # switch / to _
 153   my $cipher = new Crypt::Blowfish $key;
 154   my $secret = Encrypt($cipher, $password);
 155
 156   my $fn = "$config{authtokenpath}/$id";
 157   open (F, ">$fn") || &HTMLError("$fn: $!");
 158   print F "$secret\n";
 159   print F time."\n";
 160   close F;
 161   chmod 0600, "$fn" || &HTMLError("$fn: $!");
 162   return 1;
 163 }
 164
 165 sub FormatFingerPrint {
 166   my $in = shift;
 167   my $out;
 168
 169   if (length($in) == 32) {
 170     foreach (0..15) {
 171       $out .= substr($in, $_*2, 2)." ";
 172       $out .= "&nbsp;" if ($_ == 7);
 173     }
 174   } else {
 175     foreach (0..int(length($in)/4)) {
 176       $out .= substr($in, $_*4, 4)." ";
 177     }
 178   }
 179   chop $out;
 180   return $out;
 181 }
 182
 183 sub FetchKey {
 184   my $fingerprint = shift;
 185   my $signatures = shift;
 186   my ($out, $keyringparam) = undef;
 187
 188   foreach (split(/:/, $config{keyrings})) {
 189     $keyringparam .= "--keyring $_ ";
 190   }
 191
 192   $fingerprint =~ s/\s//g;
 193   $fingerprint = "0x".$fingerprint;
 194
 195   local $ENV{PATH} = '';
 196   $/ = undef; # just suck it up ....
 197   if ($signatures) {
 198       open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
 199       $out = <FP>;
 200       close FP;
 201   }
 202   open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
 203   $out .= <FP>;
 204   close FP;
 205   $/ = "\n";
 206
 207   return $out;
 208 }
 209
 210 sub FormatTimestamp {
 211   my $in = shift;
 212   $in =~ /^(....)(..)(..)(..)(..)(..)/;
 213
 214   return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
 215 }
 216
 217 sub FormatLastSeen {
 218 # Format:
 219 # [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
 220 # [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>"
 221   my $lastseenpgp = shift;
 222   my $lastseenfrom = shift;
 223   my ($d1, $d2, $lastseen);
 224
 225   return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
 226   $lastseen = $lastseenfrom if (!$lastseenpgp);
 227
 228   if ($lastseenfrom && $lastseenpgp) {
 229     ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);
 230     ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
 231     $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
 232   }
 233
 234   my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.*?|\-)"\s+"<(.+?)>"/);
 235   $list = "on $list" if ($list);
 236   return "$date $list<br>&nbsp;Message ID: $msgid";
 237 }
 238
 239 sub LookupCountry {
 240   my $in = shift;
 241   my ($abbrev, $country);
 242   open (F, $config{countrylist}) || return uc($in);
 243   while (<F>) {
 244     chomp;
 245     ($abbrev, $country) = split(/\s+/, $_, 2);
 246     if ($abbrev eq $in) {
 247       close F;
 248       return $country;
 249     }
 250   }
 251   close F;
 252   return uc($in);
 253 }
 254
 255 ####################
 256 # Some HTML Routines
 257
 258 my $htmlhdrsent = 0;
 259
 260 sub HTMLSendHeader {
 261   print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
 262   $htmlhdrsent = 1;
 263 }
 264
 265 sub HTMLPrint {
 266   &HTMLSendHeader if (!$htmlhdrsent);
 267   print shift;
 268 }
 269
 270 sub HTMLError {
 271   HTMLPrint(shift);
 272   die "\n";
 273 }
 274
 275 sub CheckLatLong {
 276   my ($lat, $long) = @_;
 277
 278   $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
 279
 280   if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
 281     return ($lat, $long);
 282   } else {
 283     return ("", "");
 284   }
 285 }
 286
 287 sub FixParams {
 288   my $query = shift;
 289   my $key;
 290   my @names = $query->param;
 291
 292   foreach $key (@names) { # web security is a joke ... <sigh>
 293     $_ = $query->param($key);
 294     s/&/&amp;/g;
 295     s/[<\x8B]/&lt;/g;
 296     s/[>\x9B]/&gt;/g;
 297
 298     $query->param($key, $_);
 299   }
 300 }
 301
 302
 303 sub LDAPUpdate {
 304   my $ldap = shift;
 305   my $dn = shift;
 306   my $attr = shift;
 307   my $val = shift;
 308   my $mesg;
 309
 310   if (!$val) {
 311     $mesg = $ldap->modify($dn, delete => { $attr => [] });
 312   } else {
 313     $val = [ $val ] if (!ref($val));
 314     $mesg = $ldap->modify($dn, replace => { $attr => $val });
 315     $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
 316   }
 317 }
 318
 319 ###################
 320 # Config file stuff
 321 sub ReadConfigFile {
 322   # reads a config file and results a hashref with the results
 323   my (%config, $attr, $setting);
 324   open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
 325   while (<F>) {
 326     chomp;
 327     if ((!/^\s*#/) && ($_ ne "")) {
 328       # Chop off any trailing comments
 329       s/#.*//;
 330       /([^=]+)=(.*)/;
 331       ($attr, $setting) = ($1, $2);
 332       $setting =~ s/"//g; #"
 333       $setting =~ s/;$//;
 334       $attr =~ s/^\s+//; $attr =~ s/\s+$//;
 335       $setting =~ s/^\s+//; $setting =~ s/\s+$//;
 336       $config{$attr} = $setting;
 337     }
 338   }
 339   close F;
 340   return %config;
 341 }
 342
 343 sub UpgradeConnection($) {
 344   my ($ldap) = @_;
 345   my $mesg = $ldap->start_tls(
 346                           verify => 'require',
 347                           capath => '/etc/ssl/certs/'
 348                           );
 349   $mesg->sync;
 350   if ($mesg->code != LDAP_SUCCESS) {
 351     print "Content-type: text/html; charset=utf-8\n\n";
 352     print "<html><body><h1>STARTTLS failed: "..$mesg->error."</h1></body></html>\n";
 353     exit(1);
 354   };
 355 };
 356 1;