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