Util.pm

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