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
9 use Date::Manip qw(ParseDate);
10 use Net::LDAP qw(LDAP_SUCCESS LDAP_PROTOCOL_ERROR);
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";
17 my %config = &ReadConfigFile;
20 eval 'use Crypt::Blowfish';
28 open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
29 read(F, $input, $keysize); # key length is 8 bytes
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);
42 my $cryptsaltlen = ($md5 ? 8 : 2);
44 open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
45 foreach (1..$cryptsaltlen) {
47 $out .= $valid[ord($in) % ($#valid + 1)];
50 return ($md5 ? "\$1\$$out\$" : $out);
54 my $validstr = './0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
55 my @valid = split(//,$validstr);
60 open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
61 foreach (1..$cryptsaltlen) {
63 $out .= $valid[ord($in) % ($#valid + 1)];
70 # blowfish only encrypts things in blocks of 8 bytes, so we
71 # need a custom routine that handles longer strings....
76 # prepend a length byte */
77 $input = chr(length($input)).$input;
78 $input .= "\001" x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));
80 for ($pos = 0; $pos < length($input); $pos += $blocksize) {
81 $output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize))) if ($hascryptix);
87 # like encrypt, needs to deal with big blocks. Note that we assume
88 # trailing spaces are unimportant.
91 my ($pos, $portion, $output, $len);
93 ((length($input) % $blocksize) == 0) || &HTMLError("Password corrupted"); # should always be true...
95 for ($pos = 0; $pos < length($input); $pos += $blocksize*2) {
96 $portion = pack("H16", substr($input, $pos, $blocksize*2));
97 $output .= $cipher->decrypt($portion) if ($hascryptix);
100 # check length byte, discard junk
101 $len = substr($output, 0, 1);
102 $output = substr($output, 1, ord($len));
106 sub SavePasswordToFile {
108 my $password = shift;
111 my $cryptuser = crypt($userid, &CreateCryptSalt);
112 my $secret = Encrypt($cipher, $password);
113 $cryptuser =~ y/\//_/; # translate slashes to underscores...
115 my $fn = "$config{authtokenpath}/$cryptuser";
116 open (F, ">$fn") || &HTMLError("$fn: $!");
124 sub ReadPasswordFromFile {
130 $userid =~ y/\//_/; # translate slashes to underscores...
132 # if we couldn't read the password file, assume user is unauthenticated. is this ok?
133 open (F, "<$config{authtokenpath}/$userid") || return undef;
134 chomp($passwd = <F>);
138 # check to make sure we read something
139 return undef if (!$passwd || !$time);
141 # check to make sure the time is positive, and that the auth token
143 my $tdiff = (time - $time);
144 &HTMLError("Your authentication token has expired. Please <a href=\"https://$ENV{SERVER_NAME}/$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
146 return Decrypt($cipher, $passwd);
150 my ($id, $hrkey) = split(/,/, shift, 2);
151 return undef if (!$id || !$hrkey);
152 my $key = pack("H".(length($hrkey)), $hrkey);
153 my $cipher = new Crypt::Blowfish $key;
154 my $r = ReadPasswordFromFile($id, $cipher);
156 UpdateAuthToken("$id,$hrkey", $r);
158 ClearAuthToken("$id,$hrkey")
164 my ($id, $hrkey) = split(/,/, shift, 2);
165 $id =~ y/\//_/; # switch / to _
166 unlink "$config{authtokenpath}/$id" || &HTMLError("Error removing authtoken: $!");
169 sub UpdateAuthToken {
170 my ($id, $hrkey) = split(/,/, shift, 2);
171 my $password = shift;
172 my $key = pack("H".(length($hrkey)), $hrkey);
173 $id =~ y/\//_/; # switch / to _
174 my $cipher = new Crypt::Blowfish $key;
175 my $secret = Encrypt($cipher, $password);
177 my $fn = "$config{authtokenpath}/$id";
178 open (F, ">$fn") || &HTMLError("$fn: $!");
182 chmod 0600, "$fn" || &HTMLError("$fn: $!");
186 sub FormatFingerPrint {
190 if (length($in) == 32) {
192 $out .= substr($in, $_*2, 2)." ";
193 $out .= " " if ($_ == 7);
196 foreach (0..int(length($in)/4)) {
197 $out .= substr($in, $_*4, 4)." ";
205 my $fingerprint = shift;
206 my $signatures = shift;
207 my ($out, $keyringparam) = undef;
209 foreach (split(/:/, $config{keyrings})) {
210 $keyringparam .= "--keyring $_ ";
213 $fingerprint =~ s/\s//g;
214 $fingerprint = "0x".$fingerprint;
216 local $ENV{PATH} = '';
217 $/ = undef; # just suck it up ....
219 open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
223 open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
231 sub FormatTimestamp {
233 $in =~ /^(....)(..)(..)(..)(..)(..)/;
235 return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
240 # [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
241 # [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>"
242 my $lastseenpgp = shift;
243 my $lastseenfrom = shift;
244 my ($d1, $d2, $lastseen);
246 return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
247 $lastseen = $lastseenpgp;
248 $lastseen = $lastseenfrom if (!$lastseenpgp);
250 if ($lastseenfrom && $lastseenpgp) {
251 ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);
252 ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
253 $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
256 my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.*?|\-)"\s+"(<.+?>)"/);
257 $list = "on $list" if ($list);
258 $date = CGI::escapeHTML($date);
259 $user = CGI::escapeHTML($user);
260 $list = CGI::escapeHTML($list);
261 $msgid = CGI::escapeHTML($msgid);
262 return "$date $list<br> Message ID: $msgid";
267 my ($abbrev, $country);
268 open (F, $config{countrylist}) || return uc($in);
271 ($abbrev, $country) = split(/\s+/, $_, 2);
272 if ($abbrev eq $in) {
287 print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
292 &HTMLSendHeader if (!$htmlhdrsent);
302 my ($lat, $long) = @_;
304 $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
306 if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
307 return ($lat, $long);
316 my @names = $query->param;
318 foreach $key (@names) { # web security is a joke ... <sigh>
319 $_ = $query->param($key);
324 $query->param($key, $_);
337 $mesg = $ldap->modify($dn, delete => { $attr => [] });
339 $val = [ $val ] if (!ref($val));
340 $mesg = $ldap->modify($dn, replace => { $attr => $val });
341 $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
348 # reads a config file and results a hashref with the results
349 my (%config, $attr, $setting);
350 open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
353 if ((!/^\s*#/) && ($_ ne "")) {
354 # Chop off any trailing comments
357 ($attr, $setting) = ($1, $2);
358 $setting =~ s/"//g; #"
360 $attr =~ s/^\s+//; $attr =~ s/\s+$//;
361 $setting =~ s/^\s+//; $setting =~ s/\s+$//;
362 $config{$attr} = $setting;
369 sub UpgradeConnection($) {
371 my $mesg = $ldap->start_tls(
373 cafile => '/etc/ssl/certs/spi-cacert-2008.pem'
376 if ($mesg->code != LDAP_SUCCESS) {
377 print "Content-type: text/html; charset=utf-8\n\n";
378 print "<html><body><h1>STARTTLS failed: ".$mesg->error."</h1></body></html>\n";
383 sub readwrite3($$$$) {
384 my ($in, $inputfd, $stdoutfd, $stderrfd) = @_;
386 #Echolot::Log::trace("Entering readwrite_gpg.");
388 local $INPUT_RECORD_SEPARATOR = undef;
389 my $sout = IO::Select->new();
390 my $sin = IO::Select->new();
393 #Echolot::Log::trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
395 $inputfd->blocking(0);
396 $stdoutfd->blocking(0);
397 $stderrfd->blocking(0);
398 $sout->add($stdoutfd);
399 $sout->add($stderrfd);
402 my ($stdout, $stderr) = ("", "", "");
404 my ($readyr, $readyw);
405 while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
406 #Echolot::Log::trace("select waiting for ".($sout->count())." fds.");
407 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, 42);
408 #Echolot::Log::trace("ready: write: ".(defined $readyw ? scalar @$readyw : 'none')."; read: ".(defined $readyr ? scalar @$readyr : 'none'));
409 for my $wfd (@$readyw) {
410 #Echolot::Log::trace("writing to $wfd.");
412 if ($offset != length($in)) {
413 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
415 unless (defined ($written)) {
416 #Echolot::Log::warn("Error while writing to GnuPG: $!");
422 if ($offset == length($in)) {
423 #Echolot::Log::trace("writing to $wfd done.");
431 next unless (defined(@$readyr)); # Wait some more.
433 for my $rfd (@$readyr) {
435 #Echolot::Log::trace("reading from $rfd done.");
440 #Echolot::Log::trace("reading from $rfd.");
441 if ($rfd == $stdoutfd) {
445 if ($rfd == $stderrfd) {
451 #Echolot::Log::trace("readwrite_gpg done.");
452 return ($stdout, $stderr);
455 sub checkPasswordQuality($$$) {
456 my ($pw, $oldpw, $ldapelements) = @_;
457 my ($stdinR, $stdinW) = (IO::Handle->new(), IO::Handle->new());
458 my ($stdoutR, $stdoutW) = (IO::Handle->new(), IO::Handle->new());
459 my ($stderrR, $stderrW) = (IO::Handle->new(), IO::Handle->new());
460 pipe $stdinR, $stdinW;
461 pipe $stdoutR, $stdoutW;
462 pipe $stderrR, $stderrW;
465 unless (defined $pid) {
466 return (2, "Could not fork: $!");
468 unless ($pid) { # child
475 open (STDIN, "<&".$stdinR->fileno) or warn ("Cannot dup stdinR (fd ".$stdinR->fileno.") as STDIN: $!");
476 open (STDOUT, ">&".$stdoutW->fileno) or warn ("Cannot dup stdoutW (fd ".$stdoutW->fileno.") as STDOUT: $!");
477 open (STDERR, ">&".$stderrW->fileno) or warn ("Cannot dup stderrW (fd ".$stderrW->fileno.") as STDERR: $!");
478 { exec('/usr/lib/userdir-ldap-cgi/password-qualify-check'); }
479 $stderrW->print("Could not exec password-qualify-check: $!\n");
486 $oldpw = '' unless defined $oldpw;
487 my $out = join("\n", $pw, $oldpw, @$ldapelements)."\n";
488 my ($stdout, $stderr) = readwrite3($out, $stdinW, $stdoutR, $stderrR);
491 my $exitcode = $? >> 8;
492 if ($exitcode == 0 && $stdout eq '' && $stderr eq '') {
494 } elsif ($exitcode == 1 && $stderr eq '') {
497 return (2, "check exited with exit code $exitcode, said '$stdout' on stdout, and '$stderr' on stderr.");