webwml/db.debian.org/Util.pm

# -*- perl -*-x
package Util;

use strict;
use Date::Manip qw(ParseDate);

my $blocksize = 8; # A blowfish block is 8 bytes
my $configfile = "/etc/userdir-ldap/userdir-ldap.conf";
#my $configfile = "/home/randolph/html/debian/perl/userdir-ldap.conf";

my %config = &ReadConfigFile;

my $hascryptix = 1;
eval 'use Crypt::Blowfish';
if ($@) {
  $hascryptix = undef;
}

sub CreateKey {
  my $keysize = shift;
  my $input;
  open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
  read(F, $input, $keysize); # key length is 8 bytes
  close F;
  
  return $input;
}

sub CreateCryptSalt {
  # this can create either a DES type salt or a MD5 salt
  my $md5 = shift; # do we want a MD5 salt?
  my $validstr = './0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
  my @valid = split(//,$validstr);
  my ($in, $out);
  
  my $cryptsaltlen = ($md5 ? 8 : 2);
  
  open (F, "</dev/urandom") || die &HTMLError("No /dev/urandom found!");
  foreach (1..$cryptsaltlen) {
    read(F, $in, 1);
    $out .= $valid[ord($in) % ($#valid + 1)];
  }
  close F;
  return ($md5 ? "\$1\$$out\$" : $out);
}

sub Encrypt { 
  # blowfish only encrypts things in blocks of 8 bytes, so we
  # need a custom routine that handles longer strings....
  my $cipher = shift;
  my $input = shift;
  my ($pos, $output);

  # prepend a length byte */
  $input = chr(length($input)).$input;
  $input .= "\001" x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));

  for ($pos = 0; $pos < length($input); $pos += $blocksize) {    
    $output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize))) if ($hascryptix);
  }
  return $output;
}

sub Decrypt {
  # like encrypt, needs to deal with big blocks. Note that we assume
  # trailing spaces are unimportant.
  my $cipher = shift;
  my $input = shift;
  my ($pos, $portion, $output, $len);
  
  ((length($input) % $blocksize) == 0) || &HTMLError("Password corrupted"); # should always be true...

  for ($pos = 0; $pos < length($input); $pos += $blocksize*2) {
    $portion = pack("H16", substr($input, $pos, $blocksize*2));
    $output .= $cipher->decrypt($portion) if ($hascryptix);
  }
  
  # check length byte, discard junk
  $len = substr($output, 0, 1);
  $output = substr($output, 1, ord($len));
  return $output;
}

sub SavePasswordToFile {
  my $userid = shift;
  my $password = shift;
  my $cipher = shift;

  my $cryptuser = crypt($userid, &CreateCryptSalt);
  my $secret = Encrypt($cipher, $password);
  $cryptuser =~ y/\//_/; # translate slashes to underscores...
  
  my $fn = "$config{authtokenpath}/$cryptuser";
  open (F, ">$fn") || &HTMLError("$fn: $!");
  print F "$secret\n";
  print F time."\n";
  close F;
  chmod 0600, $fn;
  return $cryptuser;
}

sub ReadPasswordFromFile {
  my $userid = shift;
  my $cipher = shift;
  my $passwd;
  my $time;
  
  $userid =~ y/\//_/; # translate slashes to underscores...

  # if we couldn't read the password file, assume user is unauthenticated. is this ok?
  open (F, "<$config{authtokenpath}/$userid") || return undef; 
  chomp($passwd = <F>);
  chomp($time = <F>);
  close F; 

  # check to make sure we read something
  return undef if (!$passwd || !$time);
  
  # check to make sure the time is positive, and that the auth token
  # has not expired
  my $tdiff = (time - $time);
  &HTMLError("Your authentication token has expired. Please <a href=\"$config{webloginhtml}\">relogin</a>") if (($tdiff < 0) || ($tdiff > $config{authexpires}));
  
  return Decrypt($cipher, $passwd);
}

sub CheckAuthToken {
  my ($id, $hrkey) = split(/,/, shift, 2);
  return undef if (!$id || !$hrkey);
  my $key = pack("H".(length($hrkey)), $hrkey);
  my $cipher = new Crypt::Blowfish $key;
  my $r = ReadPasswordFromFile($id, $cipher);
  if ($r) {
    UpdateAuthToken("$id,$hrkey", $r);
  } else {    
    ClearAuthToken("$id,$hrkey")
  }
  return $r;
}

sub ClearAuthToken {
  my ($id, $hrkey) = split(/,/, shift, 2);
  $id =~ y/\//_/; # switch / to _
  unlink "$config{authtokenpath}/$id" || &HTMLError("Error removing authtoken: $!");
}

sub UpdateAuthToken {
  my ($id, $hrkey) = split(/,/, shift, 2);
  my $password = shift;
  my $key = pack("H".(length($hrkey)), $hrkey);
  $id =~ y/\//_/; # switch / to _
  my $cipher = new Crypt::Blowfish $key;
  my $secret = Encrypt($cipher, $password);
  
  my $fn = "$config{authtokenpath}/$id";
  open (F, ">$fn") || &HTMLError("$fn: $!");
  print F "$secret\n";
  print F time."\n";
  close F;
  chmod 0600, "$fn" || &HTMLError("$fn: $!");
  return 1;
}

sub FormatFingerPrint {
  my $in = shift;
  my $out;
  
  if (length($in) == 32) {
    foreach (0..15) {
      $out .= substr($in, $_*2, 2)." ";
      $out .= "&nbsp;" if ($_ == 7);
    }      
  } else {
    foreach (0..int(length($in)/2)) {
      $out .= substr($in, $_*4, 4)." ";
    }      
  }
  return $out;
}

sub FetchKey {
  my $fingerprint = shift;
  my ($out, $keyringparam) = undef;
  
  foreach (split(/:/, $config{keyrings})) {
    $keyringparam .= "--keyring $_ ";
  }
  
  $fingerprint =~ s/\s//g;
  $fingerprint = "0x".$fingerprint;

  $/ = undef; # just suck it up ....
  open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint|");
  $out = <FP>;
  close FP;
  open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint|");
  $out .= <FP>;
  close FP;
  $/ = "\n";
  
  return $out;
}

sub FormatTimestamp {
  my $in = shift;
  $in =~ /^(....)(..)(..)(..)(..)(..)/;
  
  return sprintf("%04d/%02d/%02d %02d:%02d:%02d UTC", $1,$2,$3,$4,$5,$6);
}

sub FormatLastSeen {
# Format:
# [Tue, 11 Jan 2000 02:37:18] "Joey Hess <joeyh@debian.org>" "<debian-boot@lists.debian.org> archive/latest/7130" "<20000110181924.H19910@kitenet.net>"
# [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>"
  my $lastseenpgp = shift;
  my $lastseenfrom = shift;
  my ($d1, $d2, $lastseen);

  return "<b>No activity detected</b>" if (!$lastseenpgp && !$lastseenfrom);
  $lastseen = $lastseenfrom if (!$lastseenpgp);

  if ($lastseenfrom && $lastseenpgp) {
    ($d1) = ($lastseenpgp =~ /^\[(.+?)\]/); $d1 = ParseDate($d1);  
    ($d2) = ($lastseenfrom =~ /^\[(.+?)\]/); $d2 = ParseDate($d2);
    $lastseen = (($d1 gt $d2) ? $lastseenpgp : $lastseenfrom);
  }

  my ($date,$user,$list,$msgid) = ($lastseen =~ /^\[(.+?)\]\s+"(.+?)"\s+"(?:<(.+?)>.+?|\-)"\s+"<(.+?)>"/);
  $list = "on $list" if ($list);
  return "$date $list<br>&nbsp;Message ID: $msgid";
}

sub LookupCountry {
  my $in = shift;
  my ($abbrev, $country);
  open (F, $config{countrylist}) || return uc($in);
  while (<F>) {
    chomp;
    ($abbrev, $country) = split(/\s+/, $_, 2);
    if ($abbrev eq $in) {
      close F;
      return $country;
    }
  }
  close F;
  return uc($in);
}

####################
# Some HTML Routines

my $htmlhdrsent = 0;

sub HTMLSendHeader {
  print "Content-type: text/html\n\n" if (!$htmlhdrsent);
  $htmlhdrsent = 1;
}

sub HTMLPrint {
  &HTMLSendHeader if (!$htmlhdrsent);
  print shift;
}

sub HTMLError {
  HTMLPrint(shift);
  die "\n";
}

sub CheckLatLong {
  my ($lat, $long) = @_;

  $lat =~ s/[^-+\.\d]//g; $long =~ s/[^-+\.\d]//g;
  
  if (($lat =~ /^(\-|\+?)\d+(\.\d+)?/) && ($long =~ /^(\-|\+?)\d+(\.\d+)?/)) {
    return ($lat, $long);
  } else {
    return ("", "");
  }
}

###################
# Config file stuff
sub ReadConfigFile {
  # reads a config file and results a hashref with the results
  my (%config, $attr, $setting);
  open (F, "<$configfile") || &HTMLError("Cannot open $configfile: $!");
  while (<F>) {
    chomp;
    if ((!/^\s*#/) && ($_ ne "")) {
      # Chop off any trailing comments
      s/#.*//;
      ($attr, $setting) = split(/=/, $_, 2);
      $setting =~ s/"//g; #"
      $setting =~ s/;$//;
      $attr =~ s/^\s+//; $attr =~ s/\s+$//;
      $setting =~ s/^\s+//; $setting =~ s/\s+$//;      
      $config{$attr} = $setting;
    }
  }
  close F;
  return %config;
}

sub LDAPUpdate {
  my $ldap = shift;
  my $dn = shift;
  my $attr = shift;
  my $val = shift;
  my $mesg;
  
  if (!$val) {
    $mesg = $ldap->modify($dn, delete => { $attr => [] });
  } else {
    $val = [ $val ] if (!ref($val));
    $mesg = $ldap->modify($dn, replace => { $attr => $val });
    $mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
  }
}

1;
1	jgg	1.1	# -- perl --x
2			package Util;
3
4			use strict;
5	tausq	1.9	use Date::Manip qw(ParseDate);
6	jgg	1.1
7			my $blocksize = 8; # A blowfish block is 8 bytes
8			my $configfile = "/etc/userdir-ldap/userdir-ldap.conf";
9	tausq	1.6	#my $configfile = "/home/randolph/html/debian/perl/userdir-ldap.conf";
10	jgg	1.1
11			my %config = &ReadConfigFile;
12
13	tausq	1.3	my $hascryptix = 1;
14			eval 'use Crypt::Blowfish';
15			if ($@) {
16			$hascryptix = undef;
17			}
18
19	jgg	1.1	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	tausq	1.10	# prepend a length byte */
55			$input = chr(length($input)).$input;
56			$input .= "\001" x ($blocksize - (length($input) % $blocksize)) if (length($input % $blocksize));
57	jgg	1.1
58	tausq	1.3	for ($pos = 0; $pos < length($input); $pos += $blocksize) {
59			$output .= unpack("H16", $cipher->encrypt(substr($input, $pos, $blocksize))) if ($hascryptix);
60	jgg	1.1	}
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	tausq	1.10	my ($pos, $portion, $output, $len);
70	jgg	1.1
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	tausq	1.3	$output .= $cipher->decrypt($portion) if ($hascryptix);
76	jgg	1.1	}
77	tausq	1.10
78			# check length byte, discard junk
79			$len = substr($output, 0, 1);
80			$output = substr($output, 1, ord($len));
81	jgg	1.1	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	tausq	1.5	my ($id, $hrkey) = split(/,/, shift, 2);
129	jgg	1.1	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	tausq	1.5	UpdateAuthToken("$id,$hrkey", $r);
135	jgg	1.1	} else {
136	tausq	1.5	ClearAuthToken("$id,$hrkey")
137	jgg	1.1	}
138			return $r;
139			}
140
141			sub ClearAuthToken {
142	tausq	1.6	my ($id, $hrkey) = split(/,/, shift, 2);
143	jgg	1.1	$id =~ y/\//_/; # switch / to _
144			unlink "$config{authtokenpath}/$id" \|\| &HTMLError("Error removing authtoken: $!");
145			}
146
147			sub UpdateAuthToken {
148	tausq	1.6	my ($id, $hrkey) = split(/,/, shift, 2);
149	jgg	1.1	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 .= " " 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	tausq	1.2	my ($out, $keyringparam) = undef;
184	jgg	1.1
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	tausq	1.2	open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --list-sigs --fingerprint $fingerprint\|");
194	jgg	1.1	$out = <FP>;
195			close FP;
196	tausq	1.2	open(FP, "$config{gpg} --no-options --no-default-keyring $keyringparam --export -a $fingerprint\|");
197	jgg	1.1	$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	tausq	1.8	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	tausq	1.9	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> Message ID: $msgid";
231	tausq	1.8	}
232
233	jgg	1.1	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			###################
282			# Config file stuff
283			sub ReadConfigFile {
284			# reads a config file and results a hashref with the results
285			my (%config, $attr, $setting);
286			open (F, "<$configfile") \|\| &HTMLError("Cannot open $configfile: $!");
287			while (<F>) {
288			chomp;
289			if ((!/^\s*#/) && ($_ ne "")) {
290			# Chop off any trailing comments
291			s/#.*//;
292			($attr, $setting) = split(/=/, $_, 2);
293	tausq	1.3	$setting =~ s/"//g; #"
294	jgg	1.1	$setting =~ s/;$//;
295	tausq	1.7	$attr =~ s/^\s+//; $attr =~ s/\s+$//;
296			$setting =~ s/^\s+//; $setting =~ s/\s+$//;
297	jgg	1.1	$config{$attr} = $setting;
298			}
299			}
300			close F;
301			return %config;
302			}
303
304	tausq	1.11	sub LDAPUpdate {
305			my $ldap = shift;
306			my $dn = shift;
307			my $attr = shift;
308			my $val = shift;
309			my $mesg;
310
311			if (!$val) {
312			$mesg = $ldap->modify($dn, delete => { $attr => [] });
313			} else {
314			$val = [ $val ] if (!ref($val));
315			$mesg = $ldap->modify($dn, replace => { $attr => $val });
316			$mesg->code && &Util::HTMLError("error updating $attr: ".$mesg->error);
317			}
318			}
319
320	jgg	1.1	1;