#!/usr/bin/perl
package Mail::SpamCannibal::Session;
use strict;
#use diagnostics;
use vars qw($VERSION @ISA @EXPORT_OK);
# do not AutoLoad, used only by scripts
require Exporter;
@ISA = qw(Exporter);
$VERSION = do { my @r = (q$Revision: 0.04 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
@EXPORT_OK = qw(
mac
encode
decode
new_ses
clean
validate
sesswrap
);
=head1 NAME
Mail::SpamCannibal::Session - session management utilities
=head1 SYNOPSIS
use Mail::SpamCannibal::Session qw(
encode
decode
mac
new_ses
clean
validate
sesswrap
);
$encoded = encode($string);
$string = decode($encoded);
$mac = mac(@elements);
$sess_id=new_ses($base64ID,$session_dir,\$error,$ses_val);
$var = clean($tainted);
$user=validate($session_dir,$sess_id,$secret,\$error,$expire);
($user,$content,$file)=validate($session_dir,$sess_id,$secret,\$error,$expire);
$rv = sesswrap($command,$stdin);
=cut
=head1 DESCRIPTION
B<Mail::SpamCannibal::Session> provides utilities to manage web sessions.
=over 4
=item * $encoded = encode($string);
This function encodes an ascii string into the I<URL and Filename safe> Base64
character set. Character
62 (0x3E) "+" is replaced with a "-" (minus sign)
and character 63 (0x3F) "/" is replaced with a "_"
(underscore). Pad characters "=" are removed.
input: ascii string
returns: modified Base64 encoded string
=cut
sub encode {
my $string = shift or return '';
require MIME::Base64;
(my $encoded = &MIME::Base64::encode_base64($string,'')) =~ s/=//g;
$encoded =~ tr|+/|-_|;
return $encoded;
}
=item * $string = decode($encoded);
This function decodes a <URL and Filename safe> Base64 encoded string.
input: encoded string
returns: text string
=cut
sub decode {
my $encoded = shift or return '';
require MIME::Base64;
$encoded =~ tr|-_|+/|;
$encoded .= ('','','==','=')[length($encoded) % 4];
&MIME::Base64::decode_base64($encoded);
}
=item * $mac = mac(@elements);
This function makes a I<URL and Filename safe> BASE64 MD5 hash of from the
supplies text string(s). Character
62 (0x3E) "+" is replaced with a "-" (minus sign)
and character 63 (0x3F) "/" is replaced with a "_"
(underscore).
input: one or more input elements
returns: modified base64 string
=cut
# From RFC 3548
# ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/
#
# In the URL and Filename safe variant, character
# 62 (0x3E) "+" is replaced with a "-" (minus sign)
# and character 63 (0x3F) "/" is replaced with a "_"
# (underscore).
# Pad characters "=" are eliminated entirely
# ... but is not produced by Digest::MD5 to begin with
#
sub mac {
require Digest::MD5;
(my $scode = &Digest::MD5::md5_base64(join('',@_))) =~ tr|+/|-_|;
return $scode;
}
=item * $sess_id = new_ses($base64ID,$session_dir,\$error,$ses_val);
Create a new session and return the identifying string.
input: session directory path,
base64 unique ID, (URL safe)
secret key for MAC,
pointer to $error scalar,
[optional] value for session
file contents, default -1
Normally the session file is created containing a -1 with the presumption
that the login procedure and password verification was successful. If the
application needs to track conditional login attempts, then the session
value can be initialized to a positive value and the 'validate' function
(below) will return a false (undef) for 'user' when called with a SCALAR return
value. The application must set the session value negative for the 'user'
string to be returned.
returns: session ID or undef
=cut
# create a complete ticket of the form
# user(base64).MAC.file
# where mac = mac(user(base64),file,secret);
# where file = time.pid.ticket
# and ticket = mac(user(base64),time,pid,secret)
#
sub new_ses {
my ($session_dir,$base64ID,$secret,$ep,$ses_val) = @_;
my $time = time;
my $ticket = mac($base64ID,$time,$$,$secret);
my $file = $time .'.'. $$ .'.'. $ticket;
my $mac = mac($base64ID,$file,$secret);
$$ep = 'could not create session key';
open(SES,'>'. $session_dir .'/'. $file)
or return undef;
print SES ($ses_val) ? $ses_val : -1;
close SES;
return $base64ID .'.'. $mac .'.'. $file;
}
=item * $var = clean($tainted);
Clean a tainted variable;
input: tainted var
returns: clean var
=cut
# untaint a variable
sub clean {
return undef unless $_[0];
$_[0] =~ /^(.+)/;
return $1;
}
=item * $user=validate($session_dir,$sess_id,$secret,\$error,$expire);
=item * ($user,$content,$file)=validate($session_dir,$sess_id,$secret,\$error,$expire);
Validate a current session. The session directory is swept for
sessions that have exceeded the expire time (seconds), then checked for the
presence of a matching session. On error, a descriptive message is placed in
the external scalar $error and undef is returned.
input: session directory path,
session ID,
secret key for MAC,
pointer to error,
expire (seconds) [optional]
default = 15 minutes
returns: scalar: user name or undef
array: (user,contents,sess file)
or ()
NOTE: in SCALAR mode, the return value will always be false if the session
contents are > 0.
=cut
# return $user on success
# return undef on failure and set $error = reason
#
sub validate {
my($session_dir,$sesid,$secret,$ep,$expire) = @_;
$expire = 900 unless $expire;
$expire = time - clean($expire);
unless (opendir(D,$session_dir)) {
$$ep = 'could not open session directory';
return (wantarray) ? () : undef;
}
my @files = grep(!/^\./, readdir(D));
closedir D;
my @zap;
foreach(@files) {
my $file = $session_dir .'/'. clean($_);
my $atime = (stat($file))[8];
push @zap, $file unless (stat($file))[8] > $expire;
}
unlink @zap if @zap;
my ($user,$mac,$file) = split(/\./,$sesid,3);
unless ($mac eq mac($user,$file,$secret)) {
$$ep = 'session ID is altered';
return (wantarray) ? () : undef;
}
my ($time,$pid,$ticket) = split(/\./,$file);
unless ($ticket eq mac($user,$time,$pid,$secret)) {
$$ep = 'corrupt session ticket';
return (wantarray) ? () : undef;
}
unless (open(SES,$session_dir .'/'. $file)) {
$$ep = 'no such session';
return (wantarray) ? () : undef;
}
$_ = <SES>;
close SES;
if ($_) {
chomp;
} else {
$_ = -1;
}
return (wantarray)
? (decode($user),$_,$file)
: ($_ && $_ < 0)
? decode($user)
: do {$$ep = 'login required'; undef};
}
=item * $rv = sesswrap($command,$stdin);
Execute a session wrap command and return results.
input: command string,
stdin string [optional]
returns: wrapper output
The wrapper is opened with the command string in it's command line. $stdin,
if any, is written to the wrapper's STDIN.
For calls which have a $stdin argument, this routine uses 'fork' and spawns
a child httpd process. The routine is enhanced for modperl to properly kill
off the child
=back
=cut
sub sesswrap {
my($command,$stdin) = @_;
# do this in a lite weight fashion if there is no stdin
return eval{qx|$command|} unless $stdin;
my $r;
eval{require Apache && ($r = Apache->request)};
eval {pipe(FROM_ADMIN, TO_ADMIN) || die "pipe: $!"};
return $@ if $@;
my $pid = fork;
my $rv;
if ($pid) { # parent
close TO_ADMIN;
$rv = <FROM_ADMIN>;
close FROM_ADMIN;
# belt and suspenders
local $SIG{CHLD} = sub {waitpid($pid,0)};
waitpid($pid,0);
} else { # child
return "could not fork sesswrap: $!"
unless defined $pid;
close FROM_ADMIN;
while (1) {
unless (open STDERR, '>&STDOUT') {
print STDERR "could not dup STDERR to STDOUT: $!";
last;
}
unless (open STDOUT, '>&TO_ADMIN') {
print STDERR "could not dup STDOUT TO_ADMIN: $!";
last;
}
open(ADMIN, '|'. $command) ||
print STDERR "can not exec program";
print ADMIN $stdin
if $stdin;
close ADMIN;
last;
}
close TO_ADMIN;
(exit 0) unless $r;
CORE::exit(0);
}
$rv || '';
}
=head1 DEPENDENCIES
none
=head1 EXPORT_OK
encode
decode
mac
new_ses
validate
sesswrap
=head1 COPYRIGHT
Copyright 2003 - 2005 , Michael Robinton <michael@bizsystems.com>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
=head1 AUTHOR
Michael Robinton <michael@bizsystems.com>
=cut
1;