Fix typo in update.wml spotted by Sylvain Beucler.
[mirror/userdir-ldap-cgi.git] / 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 Peter Palfrader
5
6 package Util;
7
8 use strict;
9 use Date::Manip qw(ParseDate);
10 use Net::LDAP qw(:all);
11 use English;
12
13 my $blocksize = 8; # A blowfish block is 8 bytes
14 my $configfile = "/etc/userdir-ldap/userdir-ldap.conf";
15 #my $configfile = "/home/randolph/html/debian/perl/userdir-ldap.conf";
16
17 my %config = &ReadConfigFile;
18
19 my $hascryptix = 1;
20 eval 'use Crypt::Blowfish';
21 if ($@) {
22   $hascryptix = undef;
23 }
24
25 sub CreateKey {
26   my $keysize = shift;
27   my $input;
28   open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
29   read(F, $input, $keysize); # key length is 8 bytes
30   close F;
31   
32   return $input;
33 }
34
35 sub CreateCryptSalt {
36   # this can create either a DES type salt or a MD5 salt
37   my $md5 = shift; # do we want a MD5 salt?
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   return ($md5 ? "\$1\$$out\$" : $out);
51 }
52
53 sub Encrypt { 
54   # blowfish only encrypts things in blocks of 8 bytes, so we
55   # need a custom routine that handles longer strings....
56   my $cipher = shift;
57   my $input = shift;
58   my ($pos, $output);
59
60   # prepend a length byte */
61   $input = chr(length($input)).$input;
62   $input .= "\001" x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));
63
64   for ($pos = 0; $pos < length($input); $pos += $blocksize) {    
65     $output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize))) if ($hascryptix);
66   }
67   return $output;
68 }
69
70 sub Decrypt {
71   # like encrypt, needs to deal with big blocks. Note that we assume
72   # trailing spaces are unimportant.
73   my $cipher = shift;
74   my $input = shift;
75   my ($pos, $portion, $output, $len);
76   
77   ((length($input) % $blocksize) == 0) || &HTMLError("Password corrupted"); # should always be true...
78
79   for ($pos = 0; $pos < length($input); $pos += $blocksize*2) {
80     $portion = pack("H16", substr($input, $pos, $blocksize*2));
81     $output .= $cipher->decrypt($portion) if ($hascryptix);
82   }
83   
84   # check length byte, discard junk
85   $len = substr($output, 0, 1);
86   $output = substr($output, 1, ord($len));
87   return $output;
88 }
89
90 sub SavePasswordToFile {
91   my $userid = shift;
92   my $password = shift;
93   my $cipher = shift;
94
95   my $cryptuser = crypt($userid, &CreateCryptSalt);
96   my $secret = Encrypt($cipher, $password);
97   $cryptuser =~ y/\//_/; # translate slashes to underscores...
98   
99   my $fn = "$config{authtokenpath}/$cryptuser";
100   open (F, ">$fn") || &HTMLError("$fn: $!");
101   print F "$secret\n";
102   print F time."\n";
103   close F;
104   chmod 0600, $fn;
105   return $cryptuser;
106 }
107
108 sub ReadPasswordFromFile {
109   my $userid = shift;
110   my $cipher = shift;
111   my $passwd;
112   my $time;
113   
114   $userid =~ y/\//_/; # translate slashes to underscores...
115
116   # if we couldn't read the password file, assume user is unauthenticated. is this ok?
117   open (F, "<$config{authtokenpath}/$userid") || return undef; 
118   chomp($passwd = <F>);
119   chomp($time = <F>);
120   close F; 
121
122   # check to make sure we read something
123   return undef if (!$passwd || !$time);
124   
125   # check to make sure the time is positive, and that the auth token
126   # has not expired
127   my $tdiff = (time - $time);
128   &HTMLError("Your authentication token has expired. Please <a href=\"https://$ENV{SERVER_NAME}/$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
129   
130   return Decrypt($cipher, $passwd);
131 }
132
133 sub CheckAuthToken {
134   my ($id, $hrkey) = split(/,/, shift, 2);
135   return undef if (!$id || !$hrkey);
136   my $key = pack("H".(length($hrkey)), $hrkey);
137   my $cipher = new Crypt::Blowfish $key;
138   my $r = ReadPasswordFromFile($id, $cipher);
139   if ($r) {
140     UpdateAuthToken("$id,$hrkey", $r);
141   } else {    
142     ClearAuthToken("$id,$hrkey")
143   }
144   return $r;
145 }
146
147 sub ClearAuthToken {
148   my ($id, $hrkey) = split(/,/, shift, 2);
149   $id =~ y/\//_/; # switch / to _
150   unlink "$config{authtokenpath}/$id" || &HTMLError("Error removing authtoken: $!");
151 }
152
153 sub UpdateAuthToken {
154   my ($id, $hrkey) = split(/,/, shift, 2);
155   my $password = shift;
156   my $key = pack("H".(length($hrkey)), $hrkey);
157   $id =~ y/\//_/; # switch / to _
158   my $cipher = new Crypt::Blowfish $key;
159   my $secret = Encrypt($cipher, $password);
160   
161   my $fn = "$config{authtokenpath}/$id";
162   open (F, ">$fn") || &HTMLError("$fn: $!");
163   print F "$secret\n";
164   print F time."\n";
165   close F;
166   chmod 0600, "$fn" || &HTMLError("$fn: $!");
167   return 1;
168 }
169
170 sub FormatFingerPrint {
171   my $in = shift;
172   my $out;
173   
174   if (length($in) == 32) {
175     foreach (0..15) {
176       $out .= substr($in, $_*2, 2)." ";
177       $out .= "&nbsp;" if ($_ == 7);
178     }      
179   } else {
180     foreach (0..int(length($in)/4)) {
181       $out .= substr($in, $_*4, 4)." ";
182     }      
183   }
184   chop $out;
185   return $out;
186 }
187
188 sub FetchKey {
189   my $fingerprint = shift;
190   my $signatures = shift;
191   my ($out, $keyringparam) = undef;
192   
193   foreach (split(/:/, $config{keyrings})) {
194     $keyringparam .= "--keyring $_ ";
195   }
196   
197   $fingerprint =~ s/\s//g;
198   $fingerprint = "0x".$fingerprint;
199
200   local $ENV{PATH} = '';
201   $/ = undef; # just suck it up ....
202   if ($signatures) {
203       open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
204       $out = <FP>;
205       close FP;
206   }
207   open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
208   $out .= <FP>;
209   close FP;
210   $/ = "\n";
211   
212   return $out;
213 }
214
215 sub FormatTimestamp {
216   my $in = shift;
217   $in =~ /^(....)(..)(..)(..)(..)(..)/;
218   
219   return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
220 }
221
222 sub FormatLastSeen {
223 # Format:
224 # [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
225 # [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>"
226   my $lastseenpgp = shift;
227   my $lastseenfrom = shift;
228   my ($d1, $d2, $lastseen);
229
230   return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
231   $lastseen = $lastseenpgp;
232   $lastseen = $lastseenfrom if (!$lastseenpgp);
233
234   if ($lastseenfrom && $lastseenpgp) {
235     ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);
236     ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
237     $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
238   }
239
240   my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.*?|\-)"\s+"(<.+?>)"/);
241   $list = "on $list" if ($list);
242   $date = CGI::escapeHTML($date);
243   $user = CGI::escapeHTML($user);
244   $list = CGI::escapeHTML($list);
245   $msgid = CGI::escapeHTML($msgid);
246   return "$date $list<br>&nbsp;Message ID: $msgid";
247 }
248
249 sub LookupCountry {
250   my $in = shift;
251   my ($abbrev, $country);
252   open (F, $config{countrylist}) || return uc($in);
253   while (<F>) {
254     chomp;
255     ($abbrev, $country) = split(/\s+/, $_, 2);
256     if ($abbrev eq $in) {
257       close F;
258       return $country;
259     }
260   }
261   close F;
262   return uc($in);
263 }
264
265 ####################
266 # Some HTML Routines
267
268 my $htmlhdrsent = 0;
269
270 sub HTMLSendHeader {
271   print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
272   $htmlhdrsent = 1;
273 }
274
275 sub HTMLPrint {
276   &HTMLSendHeader if (!$htmlhdrsent);
277   print shift;
278 }
279
280 sub HTMLError {
281   HTMLPrint(shift);
282   die "\n";
283 }
284
285 sub CheckLatLong {
286   my ($lat, $long) = @_;
287
288   $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
289   
290   if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
291     return ($lat, $long);
292   } else {
293     return ("", "");
294   }
295 }
296
297 sub FixParams {
298   my $query = shift;
299   my $key;
300   my @names = $query->param;
301
302   foreach $key (@names) { # web security is a joke ... <sigh>
303     $_ = $query->param($key);
304     s/&/&amp;/g; 
305     s/[<\x8B]/&lt;/g;
306     s/[>\x9B]/&gt;/g;
307
308     $query->param($key, $_);
309   }
310 }   
311
312   
313 sub LDAPUpdate {
314   my $ldap = shift;
315   my $dn = shift;
316   my $attr = shift;
317   my $val = shift;
318   my $mesg;
319   
320   if (!$val) {
321     $mesg = $ldap->modify($dn, delete => { $attr => [] });
322   } else {
323     $val = [ $val ] if (!ref($val));
324     $mesg = $ldap->modify($dn, replace => { $attr => $val });
325     $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
326   }
327 }
328
329 ###################
330 # Config file stuff
331 sub ReadConfigFile {
332   # reads a config file and results a hashref with the results
333   my (%config, $attr, $setting);
334   open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
335   while (<F>) {
336     chomp;
337     if ((!/^\s*#/) && ($_ ne "")) {
338       # Chop off any trailing comments
339       s/#.*//;
340       /([^=]+)=(.*)/;
341       ($attr, $setting) = ($1, $2);
342       $setting =~ s/"//g; #"
343       $setting =~ s/;$//;
344       $attr =~ s/^\s+//; $attr =~ s/\s+$//;
345       $setting =~ s/^\s+//; $setting =~ s/\s+$//;      
346       $config{$attr} = $setting;
347     }
348   }
349   close F;
350   return %config;
351 }
352
353 sub UpgradeConnection($) {
354   my ($ldap) = @_;
355   my $mesg = $ldap->start_tls(
356                           verify => 'require',
357                           cafile => '/etc/ssl/certs/spi-cacert-2008.pem'
358                           );
359   $mesg->sync;
360   if ($mesg->code != LDAP_SUCCESS) {
361     print "Content-type: text/html; charset=utf-8\n\n";
362     print "<html><body><h1>STARTTLS failed: "..$mesg->error."</h1></body></html>\n";
363     exit(1);
364   };
365 };
366
367 sub readwrite3($$$$) {
368   my ($in, $inputfd, $stdoutfd, $stderrfd) = @_;
369
370   #Echolot::Log::trace("Entering readwrite_gpg.");
371
372   local $INPUT_RECORD_SEPARATOR = undef;
373   my $sout = IO::Select->new();
374   my $sin = IO::Select->new();
375   my $offset = 0;
376
377   #Echolot::Log::trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
378
379   $inputfd->blocking(0);
380   $stdoutfd->blocking(0);
381   $stderrfd->blocking(0);
382   $sout->add($stdoutfd);
383   $sout->add($stderrfd);
384   $sin->add($inputfd);
385
386   my ($stdout, $stderr) = ("", "", "");
387
388   my ($readyr, $readyw);
389   while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
390     #Echolot::Log::trace("select waiting for ".($sout->count())." fds.");
391     ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, 42);
392     #Echolot::Log::trace("ready: write: ".(defined $readyw ? scalar @$readyw : 'none')."; read: ".(defined $readyr ? scalar @$readyr : 'none'));
393     for my $wfd (@$readyw) {
394       #Echolot::Log::trace("writing to $wfd.");
395       my $written = 0;
396       if ($offset != length($in)) {
397         $written = $wfd->syswrite($in, length($in) - $offset, $offset);
398       }
399       unless (defined ($written)) {
400         #Echolot::Log::warn("Error while writing to GnuPG: $!");
401         close $wfd;
402         $sin->remove($wfd);
403         $sin = undef;
404       } else {
405         $offset += $written;
406         if ($offset == length($in)) {
407           #Echolot::Log::trace("writing to $wfd done.");
408           close $wfd;
409           $sin->remove($wfd);
410           $sin = undef;
411         }
412       }
413     }
414
415     next unless (defined(@$readyr)); # Wait some more.
416
417     for my $rfd (@$readyr) {
418       if ($rfd->eof) {
419         #Echolot::Log::trace("reading from $rfd done.");
420         $sout->remove($rfd);
421         close($rfd);
422         next;
423       }
424       #Echolot::Log::trace("reading from $rfd.");
425       if ($rfd == $stdoutfd) {
426         $stdout .= <$rfd>;
427         next;
428       }
429       if ($rfd == $stderrfd) {
430         $stderr .= <$rfd>;
431         next;
432       }
433     }
434   }
435   #Echolot::Log::trace("readwrite_gpg done.");
436   return ($stdout, $stderr);
437 };
438
439 sub checkPasswordQuality($$$) {
440   my ($pw, $oldpw, $ldapelements) = @_;
441   my ($stdinR, $stdinW) = (IO::Handle->new(), IO::Handle->new());
442   my ($stdoutR, $stdoutW) = (IO::Handle->new(), IO::Handle->new());
443   my ($stderrR, $stderrW) = (IO::Handle->new(), IO::Handle->new());
444   pipe $stdinR, $stdinW;
445   pipe $stdoutR, $stdoutW;
446   pipe $stderrR, $stderrW;
447
448   my $pid = fork();
449   unless (defined $pid) {
450     return (2, "Could not fork: $!");
451   };
452   unless ($pid) { # child
453     $stdinW->close;
454     $stdoutR->close;
455     $stderrR->close;
456     close STDIN;
457     close STDOUT;
458     close STDERR;
459     open (STDIN, "<&".$stdinR->fileno) or warn ("Cannot dup stdinR (fd ".$stdinR->fileno.") as STDIN: $!");
460     open (STDOUT, ">&".$stdoutW->fileno) or warn ("Cannot dup stdoutW (fd ".$stdoutW->fileno.") as STDOUT: $!");
461     open (STDERR, ">&".$stderrW->fileno) or warn ("Cannot dup stderrW (fd ".$stderrW->fileno.") as STDERR: $!");
462     { exec('/usr/lib/userdir-ldap-cgi/password-qualify-check'); }
463     $stderrW->print("Could not exec password-qualify-check: $!\n");
464     exit(1);
465   };
466   $stdinR->close;
467   $stdoutW->close;
468   $stderrW->close;
469
470   $oldpw = '' unless defined $oldpw;
471   my $out = join("\n", $pw, $oldpw, @$ldapelements)."\n";
472   my ($stdout, $stderr) = readwrite3($out, $stdinW, $stdoutR, $stderrR);
473   waitpid $pid, 0;
474   
475   my $exitcode = $? >> 8;
476   if ($exitcode == 0 && $stdout eq '' && $stderr eq '') {
477     return (0, "ok");
478   } elsif ($exitcode == 1 && $stderr eq '') {
479     return (1, $stdout);
480   } else {
481     return (2, "check exited with exit code $exitcode, said '$stdout' on stdout, and '$stderr' on stderr.");
482   };
483 };
484 1;