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