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
9 use Date::Manip qw(ParseDate);
10 use Net::LDAP qw(LDAP_SUCCESS LDAP_PROTOCOL_ERROR);
13 use Digest::HMAC_SHA1 qw(hmac_sha1_hex);
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";
19 my %config = &ReadConfigFile;
24 open (F, "<", "/dev/urandom") || die &HTMLError("No /dev/urandom found!");
25 read(F, $input, $keysize); # key length is 8 bytes
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);
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 if ($md5 == 1 && !$no_crypttype_header) { $out = "\$1\$$out\$"; }
56 my $plaintext = shift;
58 my $cipher = Crypt::CBC->new( -key => $hexkey, -cipher => 'Blowfish');
59 my $ciphertext_hex = $cipher->encrypt_hex($plaintext);
61 return $ciphertext_hex;
66 my $ciphertext_hex = shift;
68 my $cipher = Crypt::CBC->new( -key => $hexkey, -cipher => 'Blowfish');
69 my $plaintext = $cipher->decrypt_hex($ciphertext_hex);
74 sub SavePasswordToFile {
78 my $authtoken = CreateAuthToken($userid);
79 UpdateAuthToken($authtoken, $password);
83 sub ReadPasswordFromFile {
84 my $authtoken = shift;
86 my (undef, $hexkey) = ParseAuthToken($authtoken);
87 my $fn = GetFNfromAuthToken($authtoken);
92 # if we couldn't read the password file, assume user is unauthenticated. is this ok?
93 open (F, "<", $fn) || return undef;
98 # check to make sure we read something
99 return undef if (!$passwd || !$time);
101 # check to make sure the time is positive, and that the auth token
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}));
106 return Decrypt($hexkey, $passwd);
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;
115 my ($crypteduserid, undef) = ParseAuthToken($authtoken);
117 $crypteduserid =~ y,_,/,; # reversee translation from slashes to underscores
118 my $res = crypt($userid, $crypteduserid);
120 HTMLError("Failed to validate user authtoken\n") unless ($res eq $crypteduserid);
123 # given an authtoken and username, update lifetime of the authtoken, if it validates.
125 my $authtoken = shift;
128 VerifyCryptedUserMatches($authtoken, $userid);
130 my $r = ReadPasswordFromFile($authtoken);
132 UpdateAuthToken($authtoken, $r);
134 ClearAuthToken($authtoken);
139 # clear an authtoken's file from disk, if it validates.
141 my $authtoken = shift;
143 my $fn = GetFNfromAuthToken($authtoken);
145 unlink $fn || &HTMLError("Error removing authtoken: $!");
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>;
154 chomp($base_hmac_key);
156 my $derived_key_hmac = hmac_sha1_hex("authtoken hmac key", $base_hmac_key);
157 return $derived_key_hmac;
160 # return a Mac (Message Authentication Code) for data.
164 my $hmac_key = getAuthTokenHMACkey();
165 my $hmac = hmac_sha1_hex($data, $hmac_key);
170 # Given a userid, create an authtoken.
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
175 sub CreateAuthToken {
178 my $cryptuser = crypt($userid, CreateCryptSalt(1));
179 $cryptuser =~ y,/,_,; # translate slashes to underscores
181 my $key = &Util::CreateKey($config{blowfishkeylen});
182 my $hexkey = unpack("H".($config{blowfishkeylen}*2), $key);
184 my $data = "$cryptuser,$hexkey";
185 my $hmac = getDataMac($data);
186 my $authtoken = "$hmac,$data";
191 # Parse an authtoken into encoded userid and key information and validate its mac.
193 my $authtoken = shift;
194 my ($hmac_got, $data) = split(/,/, $authtoken, 2);
195 my $hmac_want = getDataMac($data);
197 HTMLError("Failed to validate authtoken\n") unless ($hmac_got eq $hmac_want);
199 my ($cryptuserid, $hexkey) = split(/,/, $data, 2);
200 return ($cryptuserid, $hexkey);
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);
208 my $fn = "$config{authtokenpath}/$cryptuserid";
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);
218 my $secret = Encrypt($hexkey, $password);
219 my $fn = GetFNfromAuthToken($authtoken);
221 my $saveumask = umask 077;
222 open (F, ">", $fn) || &HTMLError("$fn: $!");
232 sub FormatFingerPrint {
236 if (length($in) == 32) {
238 $out .= substr($in, $_*2, 2)." ";
239 $out .= " " if ($_ == 7);
242 foreach (0..int(length($in)/4)) {
243 $out .= substr($in, $_*4, 4)." ";
251 my $fingerprint = shift;
252 my $signatures = shift;
253 my ($out, $keyringparam) = undef;
255 foreach (split(/:/, $config{keyrings})) {
256 $keyringparam .= "--keyring $_ ";
259 $fingerprint =~ s/\s//g;
260 $fingerprint = "0x".$fingerprint;
262 local $ENV{PATH} = '';
263 $/ = undef; # just suck it up ....
265 open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
269 open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
277 sub FormatTimestamp {
279 $in =~ /^(....)(..)(..)(..)(..)(..)/;
281 return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
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);
292 return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
293 $lastseen = $lastseenpgp;
294 $lastseen = $lastseenfrom if (!$lastseenpgp);
296 if ($lastseenfrom && $lastseenpgp) {
297 ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);
298 ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
299 $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
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> Message ID: $msgid";
313 my ($abbrev, $country);
314 open (F, $config{countrylist}) || return uc($in);
317 ($abbrev, $country) = split(/\s+/, $_, 2);
318 if ($abbrev eq $in) {
333 print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
338 &HTMLSendHeader if (!$htmlhdrsent);
348 my ($lat, $long) = @_;
350 $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
352 if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
353 return ($lat, $long);
362 my @names = $query->param;
364 foreach $key (@names) { # web security is a joke ... <sigh>
365 $_ = $query->param($key);
370 $query->param($key, $_);
383 $mesg = $ldap->modify($dn, delete => { $attr => [] });
385 $val = [ $val ] if (!ref($val));
386 $mesg = $ldap->modify($dn, replace => { $attr => $val });
387 $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
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: $!");
399 if ((!/^\s*#/) && ($_ ne "")) {
400 # Chop off any trailing comments
403 ($attr, $setting) = ($1, $2);
404 $setting =~ s/"//g; #"
406 $attr =~ s/^\s+//; $attr =~ s/\s+$//;
407 $setting =~ s/^\s+//; $setting =~ s/\s+$//;
408 $config{$attr} = $setting;
415 sub UpgradeConnection($) {
417 my $mesg = $ldap->start_tls(
419 cafile => $config{sslcafile},
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";
429 sub readwrite3($$$$) {
430 my ($in, $inputfd, $stdoutfd, $stderrfd) = @_;
432 #Echolot::Log::trace("Entering readwrite_gpg.");
434 local $INPUT_RECORD_SEPARATOR = undef;
435 my $sout = IO::Select->new();
436 my $sin = IO::Select->new();
439 #Echolot::Log::trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
441 $inputfd->blocking(0);
442 $stdoutfd->blocking(0);
443 $stderrfd->blocking(0);
444 $sout->add($stdoutfd);
445 $sout->add($stderrfd);
448 my ($stdout, $stderr) = ("", "", "");
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.");
458 if ($offset != length($in)) {
459 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
461 unless (defined ($written)) {
462 #Echolot::Log::warn("Error while writing to GnuPG: $!");
468 if ($offset == length($in)) {
469 #Echolot::Log::trace("writing to $wfd done.");
477 next unless (@$readyr); # Wait some more.
479 for my $rfd (@$readyr) {
481 #Echolot::Log::trace("reading from $rfd done.");
486 #Echolot::Log::trace("reading from $rfd.");
487 if ($rfd == $stdoutfd) {
491 if ($rfd == $stderrfd) {
497 #Echolot::Log::trace("readwrite_gpg done.");
498 return ($stdout, $stderr);
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;
511 unless (defined $pid) {
512 return (2, "Could not fork: $!");
514 unless ($pid) { # child
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");
532 $oldpw = '' unless defined $oldpw;
533 my $out = join("\n", $pw, $oldpw, @$ldapelements)."\n";
534 my ($stdout, $stderr) = readwrite3($out, $stdinW, $stdoutR, $stderrR);
537 my $exitcode = $? >> 8;
538 if ($exitcode == 0 && $stdout eq '' && $stderr eq '') {
540 } elsif ($exitcode == 1 && $stderr eq '') {
543 return (2, "check exited with exit code $exitcode, said '$stdout' on stdout, and '$stderr' on stderr.");