Source Code 1992 March/Source_Code_CD-ROM_Walnut_Creek_March_1992.iso/usenet/altsrcs/1/1586/unspool

Text File | 1990-12-28 | 12.8 KB | 471 lines

#! /usr/local/bin/perl
#
# unspool does all of the actual processing for the ACS.
#
#die "unspool.perl compiled successfully\n";
#
# If the lock file exists, we are already running. Die immediately.
if ( -e "/usr/personals/LCK..SPOOL" ) {
    exit 0;
}
#
# set up the environment for suid operations - no longer needed but...
#
$ENV{"PATH"} = "/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/personals";
$ENV{"IFS"} = '' if $ENV{"IFS"} ne '';
$path = $ENV{"PATH"};

# set the permissions on all files we create to user only.
umask(0077);

# flush on selected channel
$| = 1;
#
# create the lock file
#
open(LCK,">/usr/personals/LCK..SPOOL");
close(LCK);

# open the address:alias database
if (! dbmopen(r2a,"/usr/personals/real2alias",0600)) {
    print STDERR ":::can't dbmopen real2alias: $!\n";
    exit(1);
}

# open the alias-index file and get the current alias.
if (open(INDEX,'</usr/personals/alias-index')) {
    $alias_index = <INDEX>;
    close(INDEX);
}
else {
    $alias_index = 'a';
}
#
# Process all the replies in the spool directory
#
$seq = $$;
while (</usr/personals/spool/REP*> ) {
    $repfile = $_;

    # check to make sure no fast connections are running. unspool
    # kicks off quite a few other processes, which can seriously
    # degrade throughput on a fast modem connected to a slow system.
    &fstchk;

    # open the spooled reply file
    open(MSG,"<$repfile");

    # read the first line of the message, which contains the recipient's
    # alias.
    $target_alias = <MSG>;

    # hack off the terminal newline
    chop $target_alias;

    # Load the message on MSG into an array
    @message = <MSG> ;
    close(MSG);

    # open the file in the repair directory to store the header and
    # status info in case something goes wrong.
    $replog = 0;
    $repname = "/usr/personals/repair/REP$seq-$target_alias";
    if ( open(REPLOG,">$repname")) {
        $replog = 1;
        $seq++;
    }

    # get the sender's address from the From: line
    $address = &getaddr;

    # write the header and the extracted address to the repair file
    print REPLOG @header if ( $replog );
    print REPLOG "::: address = $address\n" if ( $replog );

    # if we didn't get a usable address, go on to the next message
    goto repfail if ( "$address" eq '' );

    # extract the username from the address
    $user = &getuser($address);

    # log it in the repair file
    print REPLOG "::: user = $user\n" if ( $replog );

    # if there is none, or if it's not acceptable, go to next message
    goto repfail if ( "$user" eq '' );

    # extract the subject from the Subject: line
    $subject = &getsubj;

    # if the subject is empty, replace it with something clever
    $subject = "(None)" if ( "$subject" eq '' );
    # and log it
    print REPLOG "::: subject = $subject\n" if ( $replog );

    # look up the sender's alias in the database. If s/he doesn't
    # have one, give hir one, and log it
    $sender_alias = &getsender($address);
    print REPLOG "::: sender_alias = $sender_alias\n" if ( $replog );

    # Lookup target_alias in real2alias db
    # WARNING: you cannot save time by jumping out of this loop
    # after the target_alias has been found. Perl's implementation
    # of the dbm stuff requires that "each" visit every entry in
    # the data base before it resets. This was the origin of the
    # infamous reply to the wrong alias bug.
    $recip_address = '';
    $found = 0;
    while (($key,$value) = each %r2a) {
        if ( $found == 0 ) {
            if ( "$value" eq "$target_alias" ) {
                $recip_address = $key;
                $found = 1;
            }
        }
    }

    # non-existent target alias - send a terse message to the sender
    # explaining this.
    if ( "$recip_address" eq '' ) {
        # send a bounce message to sender
        # Using elm here is a horrendous kluge. We should probably
        # use smail instead.
        open(ELM,"|/usr/local/bin/elm -s \"ACS Reply to $target_alias Failed\" $address");
        print ELM "Alias $target_alias not found in database.\nSorry.\nACS\n";
        close(ELM);
        # log the failure
        if ( $replog ) {
            print REPLOG "::: No recip_address for $target_alias\n";
        }
        goto repfail;
    }

    # open a pipe into acsmail to send out the anonymous reply
    if (! open(REPLY,"|/usr/personals/acsmail -F $[e-mail] $recip_address")) {
        goto repfail;
    }

    # write the reply into acsmail's stdin. acsmail will add the other
    # header fields.
    print REPLY "Subject: $subject\n";
    print REPLY "To: $recip_address\n\n";
    print REPLY @body;
    close(REPLY);

    # since the reply apparently succeeded, unlink the repair file.
    unlink($repname);
    next;
    # something broke. Note it in the repair file and do the next one.
repfail:
    print REPLOG "::: Reply failed\n" if ( $replog );
    next;
} continue {
    # if a repair file is open, close it
    close(REPLOG) if ( $replog );
    # and delete the spooled reply file.
    unlink($repfile);
}
#
# Now do the messages to be posted
#
while (</usr/personals/spool/POST*> ) {
    $postfile = $_;

    # check for other things that shouldn't be disturbed
    &fstchk;

    # open the spooled POST file
    open(MSG,"<$postfile");

    # Load the message on MSG into an array
    @message = <MSG> ;
    close(MSG);

    # get the sender's address from the From: line
    $address = &getaddr;
    # if it's empty, forget it and do the next message
    goto postfail if ( "$address" eq '' );

    # get the username from the address
    $user = &getuser($address);

    # if the username is empty or forbidden, do the next message
    goto postfail if ( "$user" eq '' );

    # get the subject from the Subject: line
    $subject = &getsubj;

    # trash postings with "test" in the Subject: line
    next if ( $subject =~ /test/io );

    # if there is no subject, insert one
    $subject = "(None)" if ( $subject eq '' );

    # get the sender's alias. assign one if necessary.
    $alias = &getsender($address);

    # open a pipe into inews for the article
    if ( ! open(INEWS,"| /bin/inews -h")) {
        print STDERR "Can\'t pipe into inews\n";
        goto postfail;
    }

    # write the article into inews' stdin
    print INEWS "Path: $alias\n";
    print INEWS "From: ",$alias,"@alembic.ACS.COM\n";
    print INEWS "Newsgroups: alt.personals\n";
    print INEWS "Subject: $subject\n";
    print INEWS "Distribution: local\n";
    print INEWS "Reply-To: ",$alias,"@alembic.ACS.COM\n";
    print INEWS "Followup-To: sender\n";
    print INEWS "Organization: Anonymous Contact Service\n";
    print INEWS "\n";
    print INEWS @body;

    # add the ACS usage "signature"
    print INEWS "\n-- \n";
    print INEWS <<EOS;
To use this service, send email to:                   | There is a 25 line
Anonymous posting:    [e-mail]      | limit on all posts
Anonymous reply:    <user's alias>@alembic.ACS.COM| and e-mail messages.
Test path/get an alias: [e-mail]      | Alternate path:
ACS administrator:    [e-mail]     | uunet!alembic!...
EOS
    close(INEWS);
postfail:
    next;
} continue {
    # delete the spooled POST file
    unlink($postfile);
}

#
# Process the acs-ping messages
#
while (</usr/personals/spool/PING*> ) {
    $pingfile = $_;

    # don't disturb high-priority processing
    &fstchk;

    # open the spooled PING file
    open(MSG,"<$pingfile");

    # Load the message on MSG into an array
    @message = <MSG> ;
    close(MSG);

    # get the sender's address from the From: line
    $address = &getaddr;

    # forget it and do the next one if no address
    goto pingfail if ( "$address" eq '' );

    # extract the username from the address
    $user = &getuser($address);

    # skip to next message if the username is empty or forbidden
    goto pingfail if ( "$user" eq '' );

    # get the sender's alias, assigning one if necessary
    $sender_alias = &getsender($address);
    $| = 1;

    # open a pipe into smail to send the echo back
    open(REPLY,"|smail -F [e-mail] $address")
            || die "Can't pipe into smail\n";

    # write the ping message into smail's stdin
    print REPLY "Subject: Message RCVD\n";
    print REPLY "To: $address\n\n";
    print REPLY "Your ping request has been received by [e-mail]\n";
    print REPLY "Your alias will be $[e-mail]\n";
    print REPLY "The header of your message as it arrived here follows:\n\n";

    # send them a copy of their message header. Who knows why?
    print REPLY @header;
    close(REPLY);
pingfail:
    next;
} continue {
    # delete the spooled PING file
    unlink($pingfile);
}

# cleanup: close the real2alias database, delete the lock file, delete
# and rewrite the alias-index file, and exit.
dbmclose(r2a);
unlink("/usr/personals/LCK..SPOOL");
unlink('/usr/personals/alias-index');
open(INDEX,'>/usr/personals/alias-index') ||
    die "Can't open alias-index: $!\n";
print INDEX $alias_index;
close(INDEX);
exit(0);

# subroutine fstchk checks to see if there are any conditions on the
# system which unspool would interfere with. Mostly, this consists of
# high-speed data transfers and high-priority processes running. If
# fstchk finds such a condition, it sleeps for 30 seconds, then checks
# again to see if the condition still exists. It continues this loop
# forever.
sub fstchk {
    #
    # If we're using a high-speed line, sleep until the call ends
    # (otherwise the transfer rate drops through the floor)
    #
    while ( -e "/usr/spool/uucp/LCK/LCK..uunet" ) {
        sleep 30;
    }
} # end subroutine fstchk

#
# Subroutine getaddr splits the message in global array @message
# into global arrays @header and @body, truncates @body to 25
# lines, tries to find a signature in @body and deletes it if it
# finds one, the searches @header for a From: line and extracts
# the actual address from it if it can.
# Returns $address.
#
sub getaddr {
    #
    # split the message into body and header
hb:    for ( $line = 0 ; $line <= $#message; $line++ ) {
        if ( $message[$line] eq "\n" ) {
            # store the header
            @header = @message[ 0 .. $line-1 ];
            # store the first 25 lines of the body
            @body = @message [ $line+1 .. $line+25 ];
            last hb;
        }
    }
    #
    # Trash the signature if present
sig:    for ($line = 0; $line <= $#body; $line++ ) {
        if ( $body[$line] eq "-- \n" || $body[$line] =~ /---/ ) {
            $#body = $line - 1;
            last sig;
        }
    }
    #
    # Get From: line from header
    $from = '';
from:    for ($line = 0; $line <= $#header; $line++ ) {
        if ( $header[$line] =~ /^From: (.*)/ ) {
            $from = $1;
            last from;
        }
    }
    #
    # No From: line
    #
    #
    if ( $line > $#header) {
        return '';
    }
    # Try to extract actual address from $from line
    # look for <bangpath> form first, since that's what uunet
    # put's into the From: line
    if ( $from =~ /<(.*)>/ ) {
        $Address = $1;
    }
    else {
        # try From: address ( comment )
        if ( $from =~ /(.*) \(.*\)/ ) {
            $Address = $1;
        }
        else {
            # just use whatever's there
            $Address = $from;
        }
    }
    # get rid of any whitespace following the address
    ($Address,$junk) = split(/[ \t]/,$Address);
    # return the address
    $Address;
} # end subroutine getaddr

#
# subroutine getuser($address) -
# extract the username from an address and check to make sure it isn't
# one of the "forbidden" usernames. Returns either null or the username.
#

sub getuser {
    local($addr) = pop(@_);
    #
    # if sender is uucp, news, mailer-daemon, etc., junk the message
    # get the last ! component
    @phase1 = split(/!/,$addr);
    $usr = $phase1[$#phase1];
    # get whatever sits in front of an "@".
    @phase2 = split(/@/,$usr);
    $usr = $phase2[0];
    # get whatever precedes a "%"
    @phase3 = split(/%/,$usr);
    $usr = $phase3[0];

    # check for anything that might conceivably be the username
    # of something that bounces mail, rather than a person. We
    # also exclude root, simply because there are too many root
    # users doing system administration at some sites.
    study $usr;
    if ( $usr =~ /MAILER/i) { return(''); }
    if ( $usr =~ /DAEMON/i)    { return(''); }
    if ( $usr =~ /uucp/i)    { return(''); }
    if ( $usr =~ /POSTMASTER/i)    { return(''); }
    if ( $usr =~ /DELIVER/i) { return(''); }
    if ( $usr =~ /news/i)    { return(''); }
    if ( $usr =~ /root/)    { return(''); }
    $usr;
} # end subroutine getuser

# subroutine getsubj - search through the global array @header until
# we find a Subject: line. Extract and return the subject.

sub getsubj {
    #
    # Get Subject: line from header
    $subj = '';
    for ($line = 0; $line <= $#header; $line++ ) {
        if ( $header[$line] =~ /^Subject: (.*)$/ ) {
            $subj = $1;
            last ;
        }
    }
    $subj;
} # end subroutine getsubj

#
# subroutine getsender($address) - given the address of the sender of
# a message, find hir alias in the real2alias database and return the
# alias. If the sender is not in the database, add them. Returns the
# sender's alias.

sub getsender {
    local($addr) = pop(@_);
    #
    # Lookup sender in real2alias db
    $Salias = $r2a{$addr};
    if ( ! defined($Salias)) {
        # create alias for sender
        $alias_index++;
        $Salias = "acs-".$alias_index;
        # add the newbie to the database
        $r2a{"$addr"} = $Salias;
        # Add alias to /usr/lib/aliases
        open(SYSALIAS,">>/usr/lib/aliases") ||
            die "Can't write to aliases file: $!\n";
        print SYSALIAS "$Salias: \"|/usr/personals/anon-reply $Salias\"\n";
        close(SYSALIAS);
        #
        # need to execute newaliases here if sendmail doesn't
        # support OD flag to automatically update dbm database
        # of course, this is irrelevant if the MTA doesn't
        # use dbm database.
        # system("/usr/ucb/newaliases");
    }
    # return the alias
    $Salias;
} # end subroutine getsender