#!/usr/bin/perl use strict; use warnings; use BerkeleyDB; use CDB_File; use Net::DNS; use Cwd; # webauth.pl - receive email, put it on shelf, when caller prompts, # send it back to sendmail and relay, i suppose. # # Receive whole message. Email "from:" that the message is in on the # shelf. Upon receipt of said message we log in $goodmailfrom. The # queue watcher will then check authidx for other messages from said # address and build a 'thank you' and then pass on messages to sendmail # program. # # If the IP address is good, we can just pass exit, there's no point # consuming 3meg of memory, when qmail does it's job in much less. # # for testing locally: # /usr/local/bin/tcpserver 192.168.0.1 2525 ./webauth.pl # # when '.' ends the message put message in array, and end sub # 20060129 ewn start of program code. accepts a message. does not queue # does not greylist. # 20060202 ewn does greylist, saves messages/info in ./stored path # 20060203 ewn validate ip and validate mail from # TODO: check mail from on receipt of envelope # TODO: insert confirmation message into queue when # shelfing new mail # 20060204 ewn sends the cr message containing short information to # qmail-inject $| = 1; #print( getcwd() . "\n" ); my $input; my $version = "0.01a"; my $name = "webauth.pl"; my $domain = "ednevitible.co.uk"; my $workingdir = "/home/ed/qmailshelf"; my $greytable = "$workingdir/greytable.bdb"; my $qmailpath = "/var/qmail"; my $remoteip = $ENV{'TCPREMOTEIP'}; my $postmaster = "ed\@ednevitible.co.uk"; # this is for greylisting provision my %knownips = ( '83.146.42.164' => 27 , '127.0.0.1' => 8 , '192.168.0.0' => 24 ); # queuepath. this is where we shelf messages. this *should* be improved # for balancing messages at a later time in the development such that # fewer messages are stored in top directories. these could then be # referenced in the authidx bdb. my $queuepath = "./stored/"; # TODO: # comment this line if you dont have a validrcptto.cdb file - WARNING # we then have to read various files to check delivery on EVERY rcptto # command which causes huge latencies - maybe I could make this in bdb # format in the next version? my $validrcptto = "$qmailpath/control/validrcptto.cdb"; # if set, every character will be separated with a sleep my $shoulddelay = 0; # 15 mins for delay my $greytime = 900; # this value is not used in the current version, but it's here so that # we can acknowledge it my $greyusemailfrom = 0; # this file stores the datadir => auth mail address+number my $idxfile = "$workingdir/authidx.bdb"; # this is a database table of mail from: addresses which are confirmed # we should always pass mail when greeted by these users my $goodmailfrom = "$workingdir/goodmailfrom.bdb"; # where do we store ip addresses of connections which validate mail? # this may not be of huge benefit if someone has a pool of mail servers my $validip = "$workingdir/validip.bdb"; my %status; my @rcpttos; # message is the whole email, not including envelope my @message; my @messagebody; my @messageheaders; # greylisting vals my @greyvalues; sub response( $ ) { my $message = shift; my %commands = ( 'HELO' => "250 hello", 'EHLO' => "250 hello", 'MAIL' => "250 Mail from <>", 'RCPT' => "450 Rcpt to <> - $message", 'DATA' => "451 $message", 'RSET' => "250 ready", 'VRFY' => "502 not implemented", 'EXPN' => "502 not implemented", 'HELP' => "502 not implemented", 'NOOP' => "250 noop", 'QUIT' => "221 $domain Bye" ); } sub trim( $ ) { my $val = shift; if( defined( $val ) ) { $val =~ s/^\s*//; $val =~ s/\s*$//; } return( $val ); } sub addgreyentry { tie( my %hash, 'BerkeleyDB::Hash', -Filename => $greytable, -Flags => DB_CREATE ) or die( "Cannot access $greytable" ); my $arrval = join( "\0", @greyvalues ); $hash{$remoteip} = $arrval; print( "added grey list entry\n" ); untie( %hash ); } sub hasgreyentry { undef( @greyvalues ); tie( my %hash, "BerkeleyDB::Hash", -Filename => $greytable, -Flags => DB_CREATE ) or die( "Cannot create $greytable" ); if( defined( $hash{$remoteip} ) ) { @greyvalues = split( /\0/, $hash{$remoteip} ); } untie( %hash ); return( @greyvalues ); } sub updategreyentry { tie( my %hash, "BerkeleyDB::Hash", -Filename => $greytable, -Flags => DB_CREATE ) or die( "Cannot create $greytable" ); if( defined( $hash{$remoteip} ) ) { my @parts = split( /\0/, $hash{$remoteip} ); $greyvalues[0] = $parts[0]; $greyvalues[1] = time(); my $arrval = join( "\0", @greyvalues ); $hash{$remoteip} = $arrval; } else { # we're putting this here incase there is now no entry to # update... suppose the database is being accessed concurrently $greyvalues[0] = time(); $greyvalues[1] = time(); addgreyentry(); } untie( %hash ); } sub validatemailfrom { tie( my %mailfrom, 'BerkeleyDB::Hash', -Filename => $goodmailfrom, -Flags => DB_CREATE ) or die( "I could not access $goodmailfrom" ); $mailfrom{$status{'mailfrom'}} = 1; untie( %mailfrom ); } sub isvalidmailfrom { my $retVal = 0; tie( my %mailfrom, 'BerkeleyDB::Hash', -Filename => $goodmailfrom, -Flags => DB_CREATE ) or die( "I could not access $goodmailfrom" ); $retVal = 1 if( defined( $mailfrom{$status{'mailfrom'}} ) ); untie( %mailfrom ); } sub validateip { # set the remote ip to 1, then we know its valid tie( my %ipidx, 'BerkeleyDB::Hash', -Filename => $validip, -Flags => DB_CREATE ) or die( "I cannot access $validip" ); $ipidx{$remoteip} = 1; untie( %ipidx ); } sub confirmedip { my $retVal = 0; tie( my %ipidx, 'BerkeleyDB::Hash', -Filename => $validip, -Flags => DB_CREATE ) or die( "I cannot access $validip" ); $retVal = 1 if( defined( $ipidx{$remoteip} ) ); untie( %ipidx ); return( $retVal ); } sub whiteip { my $retVal = 0; while( ( my $ipaddress, my $nmask ) = each ( %knownips ) ) { my @wip = split( /\./, $ipaddress ); my @ip = split( /\./, $remoteip ); my $w_ip = 0; my $r_ip = 0; for( my $i = 0 ; $i<4 ; $i++ ) { $w_ip = $w_ip | ( $wip[3-$i] << $i*8 ); $r_ip = $r_ip | ( $ip[3-$i] << $i*8 ); } $w_ip = $w_ip | ( ( 2 ** ( 32 - $knownips{$ipaddress} ) ) - 1 ); $r_ip = $r_ip | ( ( 2 ** ( 32 - $knownips{$ipaddress} ) ) - 1 ) ; if( $w_ip == $r_ip ) { $retVal = 1; last; } } return( $retVal ); } sub goodip { sub rbllookup { my $retVal = 0; my @servers = split( ' ', "dnsbl.sorbs.net bl.spamcop.net relays.ordb.org sbl-xbl.spamhaus.org relays.mail-abuse.org nonconfirm.mail-abuse.org dialups.mail-abuse.org dnsbl.njabl.org elays.osirusoft.com list.dsbl.org dun.dnsbl.net vox.schpider.com whios.rfc-ignorant.org" ); my @ip = split( /\./, $remoteip ); my $res = Net::DNS::Resolver->new; foreach my $server ( @servers ) { my $answer = $res->query( $ip[3].".".$ip[2].".".$ip[1].".".$ip[0].".".$server, 'A' ); if( $answer ) { $retVal = 1; last; } } return( $retVal ); } if( !confirmedip() ) { $shoulddelay = 1; } if( whiteip() == 1 ) { print( "220-hello friend, you are whitelisted\n" ); $shoulddelay = 0; } my $dnsresult = rbllookup(); if( $dnsresult == 1 ) { print( "220-RBL\n" ); } @greyvalues = ( time(), 1, time() ); my @array = hasgreyentry(); # so long as the inbound if( scalar( @array ) == 0 && $shoulddelay == 1 ) { # 0 = first time seen # 1 = last time seen $greyvalues[0] = time(); $greyvalues[1] = $greyvalues[0]; addgreyentry(); } if( scalar( @array ) > 0 ) { updategreyentry(); if( time() > $greyvalues[0] + $greytime ) { $shoulddelay = 0; } } # read in the greyentry and check against now return( 0 ); } sub checkshelfrcptto( $ ) { my $rcptto = shift; my $retVal = 0; tie( my %idx, "BerkeleyDB::Hash", -Filename => $idxfile, -Flags => DB_CREATE ) or die( "Cannot open $idxfile" ); if( defined( $idx{$rcptto} ) ) { $status{'iscrresponse'} = 1; $retVal = $idx{$rcptto}; } untie( %idx ); return( $retVal ); } sub checkrcptto( $ ) { my $rcptto = shift; my $retVal = 0; tie( my %validhash, 'CDB_File', $validrcptto ) or die( "Cannot read $validrcptto" ); $rcptto = lc( $rcptto ); if( defined( $validhash{$rcptto} ) ) { $retVal = 1; } else { $retVal = 1 if( checkshelfrcptto( $rcptto ) ne "0" ); if( $rcptto =~ /^(.+)(@(.*)){1}$/ ) { if( defined( $validhash{$2} ) ) { $retVal = 1; } } } untie( %validhash ); return( $retVal ); } sub sendwaitingmail { tie( my %auth, 'BerkeleyDB::Hash', -Filename => $idxfile, -Flags => DB_CREATE ) or die( "I cannot access $idxfile" ); while( ( my $key, my $value ) = each ( %auth ) ) { my @vals = split( /\0/, $value ); if( $vals[0] = $status{'mailfrom'} ) { delete( $auth{$key} ); my $rcpttolist = ""; open( INFO, "$vals[1]/info" ); my @rcptto = ; close( INFO ); for( my $i = 0, my $size = scalar( @rcptto ) ; $i < $size ; $i++ ) { if( $i > 1 ) { $rcpttolist = $rcpttolist . " " . $rcptto[$i]; chomp( $rcpttolist ); } } open( MAIL, "<$vals[1]/mess" ) or die( "I cannot access $vals[1]" ); #print( "Running: $qmailpath/bin/qmail-inject -f$status{'mailfrom'} $rcpttolist\n" ); open( IN, "|$qmailpath/bin/qmail-inject -f$status{'mailfrom'} $rcpttolist" ); print( IN "Received: $name $version, injectificated at\n" ); my @lines = ; foreach my $line ( @lines ) { chomp( $line ); print( IN $line . "\n" ); } close( MAIL ); close( IN ); } } untie( %auth ); } sub greylistprintln( $ ) { my $text = shift; $text .= "\n"; my @parts = split( //, $text ); if( $shoulddelay ) { for( my $i = 0 ; $i $val" ); } foreach my $rcptto ( @rcpttos ) { glp( " $rcptto" ); } } sub cmdhelo( $ ) { my $helo = shift; glp( "250 got helo" ); $status{"helo"} = 1; if( defined $helo ) { my @parts = split( ' ', trim( $helo ) ); $status{"helohost"} = trim( $parts[0] ); glp( "$status{'helohost'}" ); } } sub cmdmailfrom( $ ) { my $fromfield = shift; if( defined( $status{"mailfrom"} ) ) { glp( "503 Sender already specified" ); next; } my $param = trim( $fromfield ); if( $param =~ /^([a-zA-Z0-9+_%-@.]+)$/i ) { glp( "250 ok" ); $status{"mailfrom"} = trim( $fromfield ); } else { glp( "501 Syntax error in parameters or arguments" ); } } sub cmdrcptto( $ ) { my $param = trim( shift ); if( !defined( $status{"mailfrom"} ) ) { glp( "503 Bad sequence of commands (specify MAIL first)" ); next; } if( $param =~ /^([a-zA-Z0-9+_%-@.]+)+$/i ) { if( checkrcptto( $1 ) ) { glp( "250 ok" ); $rcpttos[scalar( @rcpttos )] = $1; } else { glp( "551 sorry, that address is not in my validrcptto.cdb" ); } } else { glp( "553 Invalid address syntax" ); next; } } sub cmddata() { my $bodycount = 0; if( not defined( $status{"mailfrom"} ) ) { glp( "503 MAIL first" ); return; } if( scalar( @rcpttos ) == 0 ) { glp( "503 RCPT first" ); return; } glp( "354 go on" ); while( my $line = ) { $line =~ s/\n$//; $line =~ s/\r$//; $message[$bodycount] = $line; if( $message[$bodycount] eq "." && $bodycount > 0 && $message[$bodycount-1] eq "" ) { # see if this was a confirmation response # TODO: what should we do if the rcptto also carries multiple # aaddresses? my thoughts are to just remove the CR rcptto # and pass the message into the inject queue for( my $i = 0, my $size=scalar( @rcpttos ) ; $i<$size ; $i++ ) { if( checkshelfrcptto( $rcpttos[$i] ) ne "0" ) { delete( $rcpttos[$i] ); $size = scalar( @rcpttos ); validateip(); validatemailfrom(); } } if( defined( $status{'iscrresponse'} ) ) { # find all messages waiting from this mailfrom # and send them. we shall not be sending whitelist from # ip. that is used only for future mail. sendwaitingmail(); } if( scalar( @rcpttos ) == 0 ) { clearstatus(); glp( "250 ok - your IP and mail from are saved. Thanks." ); last; } # at this point we write the message to the disk for processing # later by a cron job pop( @message ); pop( @message ); readheaders(); writemessage(); clearstatus(); glp( "250 ok got message" ); last; } $bodycount++; } } sub generateauth( $ ) { # quick random string, ten digit string my $email = shift; my $retVal ; srand( time() ^ ( $$ + ( $$ << 15 ) ) ); for( my $i = 0 ; $i < 10 ; $i++ ) { $retVal .= int( rand( 10 ) ); } if( $email =~ /^(.*)@(.*)$/ ) { $retVal = "$1-$retVal\@$2"; } return( $retVal ); } sub addidx( $$ ) { my $auth = shift; my $dir = shift; tie( my %idx, 'BerkeleyDB::Hash', -Filename => $idxfile, -Flags => DB_CREATE ) or die( "Could not create $idxfile" ); # separate the fields with a ascii-0, or ^A for some $idx{$auth} = $status{'mailfrom'} . "\0" . $dir; untie( %idx ); } sub writecrmessage( $ ) { my $auth = shift; my $to; if( defined( $status{'mailfrom'} ) ) { $to = $status{'mailfrom'}; } else { if( defined( $status{'reply-to'} ) ) { $to = $status{'reply-to'}; } else { # there's not much we can do now! $to = $postmaster; } } if( !defined( $to ) ) { } if( defined( $status{'subject'} ) ) { if( my $pos = index( $status{'subject'}, '\n' ) != -1 ) { $status{'subject'} = substr( $status{'subject'}, $pos ); } if( my $pos = index( $status{'subject'}, '\r' ) != -1 ) { $status{'subject'} = substr( $status{'subject'} , $pos ); } } else { $status{'subject'} = "No subject"; } my $message = "To: $to\n" . "Reply-to: $auth\n" . "From: $postmaster\n" . "Subject: Please confirm this message\n\nThe message is being held on the shelf.\n\n" . "The subject line is: $status{'subject'}\n\n" . "You should only need to reply to this message once, then I will save your\n" . "email address and connecting server address for future deliveries.\n\n" . "Either reply to this message or send a new email to $auth\n\n" . "to confirm the delivery of this email\n\n\n\n" . "If you think this is spam, please contact $postmaster.\n\n\n" . "The original mail was received from $remoteip.\n\n"; open( F, "|$qmailpath/bin/qmail-inject -f$postmaster $status{'mailfrom'}" ); print( F $message ); close( F ); } sub writemessage() { # TODO: arrange this directory in mail from sub directories: # /stored/a/ # /stored/b/ etc my $datadir = $queuepath . time() . ".$$"; my $temppath = $datadir; my $counter = 0; my $generatedauth = generateauth( $rcpttos[0] ); while( -d $datadir ) { $datadir = $temppath . $counter; $counter++; } mkdir( $datadir ); open( F, ">$datadir/mess" ); foreach my $line ( @message ) { print( F $line . "\n" ); } close( F ); open( F, ">$datadir/info" ); print( F $status{'mailfrom'} . "\n" ); print( F $remoteip . "\n" ); foreach my $line ( @rcpttos ) { print( F $line . "\n" ); } close( F ); open( F, ">$datadir/auth" ); print( F $generatedauth ); close( F ); addidx( $generatedauth, $datadir ); writecrmessage( $generatedauth ); } sub readheaders() { foreach my $line ( @message ) { if( $line eq "" ) { # end of headers last; } if( $line =~ /^subject:(.*)/i ) { my $subject = trim( $1 ); $status{"subject"} = $subject; } if( $line =~ /^return-path:(.*)/i ) { if( !defined( $status{"return-path"} ) ) { $status{"return-path"} = trim( $1 ); } } if( $line =~ /^from:(.*)/i ) { my $from = trim( $1 ); if( !defined( $status{"from"} ) ) { $status{"from"} = $from; } } } } sub readsession() { while( my $line = ) { if( $line =~ /^(ehlo|helo){1}( .*)*/i ) { cmdhelo( $2 ); next; } if( $line =~ /^quit/i ) { glp( "221 $domain $name closing connection" ); exit; } if( $line =~ /^mail from:(.*)$/i ) { cmdmailfrom( $1 ); next; } if( $line =~ /^rcpt to:(.*)$/i ) { cmdrcptto( $1 ); next; } if( $line =~ /^data/i ) { cmddata(); clearstatus(); next; } if( $line =~ /^rset/i ) { clearstatus(); glp( "250 gone" ); next; } print( "502 \"" . trim( $line ) . "\" unimplemented\n" ); } } sub clearstatus() { undef( %status ); undef( @rcpttos ); undef( @message ); undef( @messageheaders ); undef( @messagebody ); undef( @greyvalues ); } startupchecks(); sleep 1; glpbanner(); readsession(); exit;