display all host keys, remove DSA key support
[mirror/userdir-ldap-cgi.git] / Util.pm
1 # -*- perl -*-x
2 package Util;
3
4 use strict;
5 use Date::Manip qw(ParseDate);
6
7 my $blocksize = 8; # A blowfish block is 8 bytes
8 my $configfile = "/etc/userdir-ldap/userdir-ldap.conf";
9 #my $configfile = "/home/randolph/html/debian/perl/userdir-ldap.conf";
10
11 my %config = &ReadConfigFile;
12
13 my $hascryptix = 1;
14 eval 'use Crypt::Blowfish';
15 if ($@) {
16   $hascryptix = undef;
17 }
18
19 sub CreateKey {
20   my $keysize = shift;
21   my $input;
22   open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
23   read(F, $input, $keysize); # key length is 8 bytes
24   close F;
25   
26   return $input;
27 }
28
29 sub CreateCryptSalt {
30   # this can create either a DES type salt or a MD5 salt
31   my $md5 = shift; # do we want a MD5 salt?
32   my $validstr = './0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
33   my @valid = split(//,$validstr);
34   my ($in, $out);
35   
36   my $cryptsaltlen = ($md5 ? 8 : 2);
37   
38   open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
39   foreach (1..$cryptsaltlen) {
40     read(F, $in, 1);
41     $out .= $valid[ord($in) % ($#valid + 1)];
42   }
43   close F;
44   return ($md5 ? "\$1\$$out\$" : $out);
45 }
46
47 sub Encrypt { 
48   # blowfish only encrypts things in blocks of 8 bytes, so we
49   # need a custom routine that handles longer strings....
50   my $cipher = shift;
51   my $input = shift;
52   my ($pos, $output);
53
54   # prepend a length byte */
55   $input = chr(length($input)).$input;
56   $input .= "\001" x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));
57
58   for ($pos = 0; $pos < length($input); $pos += $blocksize) {    
59     $output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize))) if ($hascryptix);
60   }
61   return $output;
62 }
63
64 sub Decrypt {
65   # like encrypt, needs to deal with big blocks. Note that we assume
66   # trailing spaces are unimportant.
67   my $cipher = shift;
68   my $input = shift;
69   my ($pos, $portion, $output, $len);
70   
71   ((length($input) % $blocksize) == 0) || &HTMLError("Password corrupted"); # should always be true...
72
73   for ($pos = 0; $pos < length($input); $pos += $blocksize*2) {
74     $portion = pack("H16", substr($input, $pos, $blocksize*2));
75     $output .= $cipher->decrypt($portion) if ($hascryptix);
76   }
77   
78   # check length byte, discard junk
79   $len = substr($output, 0, 1);
80   $output = substr($output, 1, ord($len));
81   return $output;
82 }
83
84 sub SavePasswordToFile {
85   my $userid = shift;
86   my $password = shift;
87   my $cipher = shift;
88
89   my $cryptuser = crypt($userid, &CreateCryptSalt);
90   my $secret = Encrypt($cipher, $password);
91   $cryptuser =~ y/\//_/; # translate slashes to underscores...
92   
93   my $fn = "$config{authtokenpath}/$cryptuser";
94   open (F, ">$fn") || &HTMLError("$fn: $!");
95   print F "$secret\n";
96   print F time."\n";
97   close F;
98   chmod 0600, $fn;
99   return $cryptuser;
100 }
101
102 sub ReadPasswordFromFile {
103   my $userid = shift;
104   my $cipher = shift;
105   my $passwd;
106   my $time;
107   
108   $userid =~ y/\//_/; # translate slashes to underscores...
109
110   # if we couldn't read the password file, assume user is unauthenticated. is this ok?
111   open (F, "<$config{authtokenpath}/$userid") || return undef; 
112   chomp($passwd = <F>);
113   chomp($time = <F>);
114   close F; 
115
116   # check to make sure we read something
117   return undef if (!$passwd || !$time);
118   
119   # check to make sure the time is positive, and that the auth token
120   # has not expired
121   my $tdiff = (time - $time);
122   &HTMLError("Your authentication token has expired. Please <a href=\"$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
123   
124   return Decrypt($cipher, $passwd);
125 }
126
127 sub CheckAuthToken {
128   my ($id, $hrkey) = split(/,/, shift, 2);
129   return undef if (!$id || !$hrkey);
130   my $key = pack("H".(length($hrkey)), $hrkey);
131   my $cipher = new Crypt::Blowfish $key;
132   my $r = ReadPasswordFromFile($id, $cipher);
133   if ($r) {
134     UpdateAuthToken("$id,$hrkey", $r);
135   } else {    
136     ClearAuthToken("$id,$hrkey")
137   }
138   return $r;
139 }
140
141 sub ClearAuthToken {
142   my ($id, $hrkey) = split(/,/, shift, 2);
143   $id =~ y/\//_/; # switch / to _
144   unlink "$config{authtokenpath}/$id" || &HTMLError("Error removing authtoken: $!");
145 }
146
147 sub UpdateAuthToken {
148   my ($id, $hrkey) = split(/,/, shift, 2);
149   my $password = shift;
150   my $key = pack("H".(length($hrkey)), $hrkey);
151   $id =~ y/\//_/; # switch / to _
152   my $cipher = new Crypt::Blowfish $key;
153   my $secret = Encrypt($cipher, $password);
154   
155   my $fn = "$config{authtokenpath}/$id";
156   open (F, ">$fn") || &HTMLError("$fn: $!");
157   print F "$secret\n";
158   print F time."\n";
159   close F;
160   chmod 0600, "$fn" || &HTMLError("$fn: $!");
161   return 1;
162 }
163
164 sub FormatFingerPrint {
165   my $in = shift;
166   my $out;
167   
168   if (length($in) == 32) {
169     foreach (0..15) {
170       $out .= substr($in, $_*2, 2)." ";
171       $out .= "&nbsp;" if ($_ == 7);
172     }      
173   } else {
174     foreach (0..int(length($in)/2)) {
175       $out .= substr($in, $_*4, 4)." ";
176     }      
177   }
178   return $out;
179 }
180
181 sub FetchKey {
182   my $fingerprint = shift;
183   my ($out, $keyringparam) = undef;
184   
185   foreach (split(/:/, $config{keyrings})) {
186     $keyringparam .= "--keyring $_ ";
187   }
188   
189   $fingerprint =~ s/\s//g;
190   $fingerprint = "0x".$fingerprint;
191
192   $/ = undef; # just suck it up ....
193   open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --check-sigs --fingerprint $fingerprint|");
194   $out = <FP>;
195   close FP;
196   open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
197   $out .= <FP>;
198   close FP;
199   $/ = "\n";
200   
201   return $out;
202 }
203
204 sub FormatTimestamp {
205   my $in = shift;
206   $in =~ /^(....)(..)(..)(..)(..)(..)/;
207   
208   return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
209 }
210
211 sub FormatLastSeen {
212 # Format:
213 # [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
214 # [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>"
215   my $lastseenpgp = shift;
216   my $lastseenfrom = shift;
217   my ($d1, $d2, $lastseen);
218
219   return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
220   $lastseen = $lastseenfrom if (!$lastseenpgp);
221
222   if ($lastseenfrom && $lastseenpgp) {
223     ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);  
224     ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
225     $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
226   }
227
228   my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.+?|\-)"\s+"<(.+?)>"/);
229   $list = "on $list" if ($list);
230   return "$date $list<br>&nbsp;Message ID: $msgid";
231 }
232
233 sub LookupCountry {
234   my $in = shift;
235   my ($abbrev, $country);
236   open (F, $config{countrylist}) || return uc($in);
237   while (<F>) {
238     chomp;
239     ($abbrev, $country) = split(/\s+/, $_, 2);
240     if ($abbrev eq $in) {
241       close F;
242       return $country;
243     }
244   }
245   close F;
246   return uc($in);
247 }
248
249 ####################
250 # Some HTML Routines
251
252 my $htmlhdrsent = 0;
253
254 sub HTMLSendHeader {
255   print "Content-type: text/html\n\n" if (!$htmlhdrsent);
256   $htmlhdrsent = 1;
257 }
258
259 sub HTMLPrint {
260   &HTMLSendHeader if (!$htmlhdrsent);
261   print shift;
262 }
263
264 sub HTMLError {
265   HTMLPrint(shift);
266   die "\n";
267 }
268
269 sub CheckLatLong {
270   my ($lat, $long) = @_;
271
272   $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
273   
274   if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
275     return ($lat, $long);
276   } else {
277     return ("", "");
278   }
279 }
280
281 sub FixParams {
282   my $query = shift;
283   my $key;
284   my @names = $query->param;
285
286   foreach $key (@names) { # web security is a joke ... <sigh>
287     $_ = $query->param($key);
288     s/&/&amp;/g; 
289     s/[<\x8B]/&lt;/g;
290     s/[>\x9B]/&gt;/g;
291
292     $query->param($key, $_);
293   }
294 }   
295
296   
297 sub LDAPUpdate {
298   my $ldap = shift;
299   my $dn = shift;
300   my $attr = shift;
301   my $val = shift;
302   my $mesg;
303   
304   if (!$val) {
305     $mesg = $ldap->modify($dn, delete => { $attr => [] });
306   } else {
307     $val = [ $val ] if (!ref($val));
308     $mesg = $ldap->modify($dn, replace => { $attr => $val });
309     $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
310   }
311 }
312
313 ###################
314 # Config file stuff
315 sub ReadConfigFile {
316   # reads a config file and results a hashref with the results
317   my (%config, $attr, $setting);
318   open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
319   while (<F>) {
320     chomp;
321     if ((!/^\s*#/) && ($_ ne "")) {
322       # Chop off any trailing comments
323       s/#.*//;
324       ($attr, $setting) = split(/=/, $_, 2);
325       $setting =~ s/"//g; #"
326       $setting =~ s/;$//;
327       $attr =~ s/^\s+//; $attr =~ s/\s+$//;
328       $setting =~ s/^\s+//; $setting =~ s/\s+$//;      
329       $config{$attr} = $setting;
330     }
331   }
332   close F;
333   return %config;
334 }
335
336 1;