Add VoIP field to CGI [zobel].
[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=\"https://$ENV{SERVER_NAME}/$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)/4)) {
175       $out .= substr($in, $_*4, 4)." ";
176     }      
177   }
178   chop $out;
179   return $out;
180 }
181
182 sub FetchKey {
183   my $fingerprint = shift;
184   my $signatures = shift;
185   my ($out, $keyringparam) = undef;
186   
187   foreach (split(/:/, $config{keyrings})) {
188     $keyringparam .= "--keyring $_ ";
189   }
190   
191   $fingerprint =~ s/\s//g;
192   $fingerprint = "0x".$fingerprint;
193
194   local $ENV{PATH} = '';
195   $/ = undef; # just suck it up ....
196   if ($signatures) {
197       open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
198       $out = <FP>;
199       close FP;
200   }
201   open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
202   $out .= <FP>;
203   close FP;
204   $/ = "\n";
205   
206   return $out;
207 }
208
209 sub FormatTimestamp {
210   my $in = shift;
211   $in =~ /^(....)(..)(..)(..)(..)(..)/;
212   
213   return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
214 }
215
216 sub FormatLastSeen {
217 # Format:
218 # [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
219 # [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>"
220   my $lastseenpgp = shift;
221   my $lastseenfrom = shift;
222   my ($d1, $d2, $lastseen);
223
224   return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
225   $lastseen = $lastseenfrom if (!$lastseenpgp);
226
227   if ($lastseenfrom && $lastseenpgp) {
228     ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);  
229     ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
230     $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
231   }
232
233   my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.*?|\-)"\s+"<(.+?)>"/);
234   $list = "on $list" if ($list);
235   return "$date $list<br>&nbsp;Message ID: $msgid";
236 }
237
238 sub LookupCountry {
239   my $in = shift;
240   my ($abbrev, $country);
241   open (F, $config{countrylist}) || return uc($in);
242   while (<F>) {
243     chomp;
244     ($abbrev, $country) = split(/\s+/, $_, 2);
245     if ($abbrev eq $in) {
246       close F;
247       return $country;
248     }
249   }
250   close F;
251   return uc($in);
252 }
253
254 ####################
255 # Some HTML Routines
256
257 my $htmlhdrsent = 0;
258
259 sub HTMLSendHeader {
260   print "Content-type: text/html; charset=utf-8\n\n" if (!$htmlhdrsent);
261   $htmlhdrsent = 1;
262 }
263
264 sub HTMLPrint {
265   &HTMLSendHeader if (!$htmlhdrsent);
266   print shift;
267 }
268
269 sub HTMLError {
270   HTMLPrint(shift);
271   die "\n";
272 }
273
274 sub CheckLatLong {
275   my ($lat, $long) = @_;
276
277   $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
278   
279   if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
280     return ($lat, $long);
281   } else {
282     return ("", "");
283   }
284 }
285
286 sub FixParams {
287   my $query = shift;
288   my $key;
289   my @names = $query->param;
290
291   foreach $key (@names) { # web security is a joke ... <sigh>
292     $_ = $query->param($key);
293     s/&/&amp;/g; 
294     s/[<\x8B]/&lt;/g;
295     s/[>\x9B]/&gt;/g;
296
297     $query->param($key, $_);
298   }
299 }   
300
301   
302 sub LDAPUpdate {
303   my $ldap = shift;
304   my $dn = shift;
305   my $attr = shift;
306   my $val = shift;
307   my $mesg;
308   
309   if (!$val) {
310     $mesg = $ldap->modify($dn, delete => { $attr => [] });
311   } else {
312     $val = [ $val ] if (!ref($val));
313     $mesg = $ldap->modify($dn, replace => { $attr => $val });
314     $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
315   }
316 }
317
318 ###################
319 # Config file stuff
320 sub ReadConfigFile {
321   # reads a config file and results a hashref with the results
322   my (%config, $attr, $setting);
323   open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
324   while (<F>) {
325     chomp;
326     if ((!/^\s*#/) && ($_ ne "")) {
327       # Chop off any trailing comments
328       s/#.*//;
329       /([^=]+)=(.*)/;
330       ($attr, $setting) = ($1, $2);
331       $setting =~ s/"//g; #"
332       $setting =~ s/;$//;
333       $attr =~ s/^\s+//; $attr =~ s/\s+$//;
334       $setting =~ s/^\s+//; $setting =~ s/\s+$//;      
335       $config{$attr} = $setting;
336     }
337   }
338   close F;
339   return %config;
340 }
341
342 1;