5 use Date::Manip qw(ParseDate);
6 use Net::LDAP qw(:all);
8 my $blocksize = 8; # A blowfish block is 8 bytes
9 my $configfile = "/etc/userdir-ldap/userdir-ldap.conf";
10 #my $configfile = "/home/randolph/html/debian/perl/userdir-ldap.conf";
12 my %config = &ReadConfigFile;
15 eval 'use Crypt::Blowfish';
23 open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
24 read(F, $input, $keysize); # key length is 8 bytes
31 # this can create either a DES type salt or a MD5 salt
32 my $md5 = shift; # do we want a MD5 salt?
33 my $validstr = './0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
34 my @valid = split(//,$validstr);
37 my $cryptsaltlen = ($md5 ? 8 : 2);
39 open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
40 foreach (1..$cryptsaltlen) {
42 $out .= $valid[ord($in) % ($#valid + 1)];
45 return ($md5 ? "\$1\$$out\$" : $out);
49 # blowfish only encrypts things in blocks of 8 bytes, so we
50 # need a custom routine that handles longer strings....
55 # prepend a length byte */
56 $input = chr(length($input)).$input;
57 $input .= "\001" x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));
59 for ($pos = 0; $pos < length($input); $pos += $blocksize) {
60 $output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize))) if ($hascryptix);
66 # like encrypt, needs to deal with big blocks. Note that we assume
67 # trailing spaces are unimportant.
70 my ($pos, $portion, $output, $len);
72 ((length($input) % $blocksize) == 0) || &HTMLError("Password corrupted"); # should always be true...
74 for ($pos = 0; $pos < length($input); $pos += $blocksize*2) {
75 $portion = pack("H16", substr($input, $pos, $blocksize*2));
76 $output .= $cipher->decrypt($portion) if ($hascryptix);
79 # check length byte, discard junk
80 $len = substr($output, 0, 1);
81 $output = substr($output, 1, ord($len));
85 sub SavePasswordToFile {
90 my $cryptuser = crypt($userid, &CreateCryptSalt);
91 my $secret = Encrypt($cipher, $password);
92 $cryptuser =~ y/\//_/; # translate slashes to underscores...
94 my $fn = "$config{authtokenpath}/$cryptuser";
95 open (F, ">$fn") || &HTMLError("$fn: $!");
103 sub ReadPasswordFromFile {
109 $userid =~ y/\//_/; # translate slashes to underscores...
111 # if we couldn't read the password file, assume user is unauthenticated. is this ok?
112 open (F, "<$config{authtokenpath}/$userid") || return undef;
113 chomp($passwd = <F>);
117 # check to make sure we read something
118 return undef if (!$passwd || !$time);
120 # check to make sure the time is positive, and that the auth token
122 my $tdiff = (time - $time);
123 &HTMLError("Your authentication token has expired. Please <a href=\"https://$ENV{SERVER_NAME}/$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
125 return Decrypt($cipher, $passwd);
129 my ($id, $hrkey) = split(/,/, shift, 2);
130 return undef if (!$id || !$hrkey);
131 my $key = pack("H".(length($hrkey)), $hrkey);
132 my $cipher = new Crypt::Blowfish $key;
133 my $r = ReadPasswordFromFile($id, $cipher);
135 UpdateAuthToken("$id,$hrkey", $r);
137 ClearAuthToken("$id,$hrkey")
143 my ($id, $hrkey) = split(/,/, shift, 2);
144 $id =~ y/\//_/; # switch / to _
145 unlink "$config{authtokenpath}/$id" || &HTMLError("Error removing authtoken: $!");
148 sub UpdateAuthToken {
149 my ($id, $hrkey) = split(/,/, shift, 2);
150 my $password = shift;
151 my $key = pack("H".(length($hrkey)), $hrkey);
152 $id =~ y/\//_/; # switch / to _
153 my $cipher = new Crypt::Blowfish $key;
154 my $secret = Encrypt($cipher, $password);
156 my $fn = "$config{authtokenpath}/$id";
157 open (F, ">$fn") || &HTMLError("$fn: $!");
161 chmod 0600, "$fn" || &HTMLError("$fn: $!");
165 sub FormatFingerPrint {
169 if (length($in) == 32) {
171 $out .= substr($in, $_*2, 2)." ";
172 $out .= " " if ($_ == 7);
175 foreach (0..int(length($in)/4)) {
176 $out .= substr($in, $_*4, 4)." ";
184 my $fingerprint = shift;
185 my $signatures = shift;
186 my ($out, $keyringparam) = undef;
188 foreach (split(/:/, $config{keyrings})) {
189 $keyringparam .= "--keyring $_ ";
192 $fingerprint =~ s/\s//g;
193 $fingerprint = "0x".$fingerprint;
195 local $ENV{PATH} = '';
196 $/ = undef; # just suck it up ....
198 open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
202 open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
210 sub FormatTimestamp {
212 $in =~ /^(....)(..)(..)(..)(..)(..)/;
214 return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
219 # [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
220 # [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>"
221 my $lastseenpgp = shift;
222 my $lastseenfrom = shift;
223 my ($d1, $d2, $lastseen);
225 return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
226 $lastseen = $lastseenfrom if (!$lastseenpgp);
228 if ($lastseenfrom && $lastseenpgp) {
229 ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);
230 ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
231 $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
234 my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.*?|\-)"\s+"<(.+?)>"/);
235 $list = "on $list" if ($list);
236 return "$date $list<br> Message ID: $msgid";
241 my ($abbrev, $country);
242 open (F, $config{countrylist}) || return uc($in);
245 ($abbrev, $country) = split(/\s+/, $_, 2);
246 if ($abbrev eq $in) {
261 print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
266 &HTMLSendHeader if (!$htmlhdrsent);
276 my ($lat, $long) = @_;
278 $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
280 if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
281 return ($lat, $long);
290 my @names = $query->param;
292 foreach $key (@names) { # web security is a joke ... <sigh>
293 $_ = $query->param($key);
298 $query->param($key, $_);
311 $mesg = $ldap->modify($dn, delete => { $attr => [] });
313 $val = [ $val ] if (!ref($val));
314 $mesg = $ldap->modify($dn, replace => { $attr => $val });
315 $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
322 # reads a config file and results a hashref with the results
323 my (%config, $attr, $setting);
324 open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
327 if ((!/^\s*#/) && ($_ ne "")) {
328 # Chop off any trailing comments
331 ($attr, $setting) = ($1, $2);
332 $setting =~ s/"//g; #"
334 $attr =~ s/^\s+//; $attr =~ s/\s+$//;
335 $setting =~ s/^\s+//; $setting =~ s/\s+$//;
336 $config{$attr} = $setting;
343 sub UpgradeConnection($) {
345 my $mesg = $ldap->start_tls(
347 capath => '/etc/ssl/certs/'
350 if ($mesg->code != LDAP_SUCCESS) {
351 print "Content-type: text/html; charset=utf-8\n\n";
352 print "<html><body><h1>STARTTLS failed: "..$mesg->error."</h1></body></html>\n";