#!/usr/bin/perl -wT

# FEX CGI for mailman (users) authentification
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Copyright: GNU General Public License

use CGI         qw(:standard);
use CGI::Carp	qw(fatalsToBrowser);
use Fcntl 	qw(:flock :seek);
use Digest::MD5	qw(md5_hex);
use IO::Socket::INET;

# To make this CGI work, you have to define these two config variables 
# in fex.ph: 
#   $mm_url   : mailman URL
#   @mm_lists : lists of allowed mailing lists
# Example:
#   $mm_url = 'http://listserv.uni-stuttgart.de/mailman';
#   @mm_lists = qw(rad-licht tandem fex);

# add fex lib
$FEXLIB =
  $0 =~ m:(/.+)/.+/: ? "$1/lib":
  $0 =~ m:(.*/):     ? "$1/../lib":
                       "../lib";
die "$0: no $FEXLIB\n" unless -d $FEXLIB;

# imports from fex.pp
our ($logdir,$fra,$mm_url,$mm_lists);

# load common code, local config : $HOME/lib/fex.ph
require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";

my $ra = untaint($ENV{REMOTE_ADDR});
my $akeydir = "$spooldir/.akeys"; mkdirp($akeydir); # authentification keys
my $akey = '';
  
our $error = 'F*EX MMA ERROR';

chdir $spooldir or die "$spooldir - $!\n";

my $log = "$logdir/mma.log";

http_die("No mailman lists allowed for F*EX") unless @mm_lists and $mm_url;

unless ($mm_url =~ m{^http://.+/}) {
  http_die("Invalid mailman URL $mm_url");
}

$head = "F*EX mailman authentification";
$user = $list = $password = $id = '';

# look for CGI parameters
foreach my $v (param) {
  $vv = param($v);
  $vv =~ s/[ \t\000]//g;
  if ($v =~ /^(from|user)$/i) {
    $vv =~ s:/::g;
    $user = untaint(lc($vv));
  } elsif ($v =~ /^password$/i) {
    $password = $vv;
  } elsif ($v =~ /^list$/i and $vv =~ /([\w_-]+)/) {
    $list = $1;
  }
}

if ($user and $list and $password) {
  unless (grep /^\Q$list\E$/i,@mm_lists) {
    mmalog("list $list not allowed");
    http_die("list $list not allowed");
  }
  unless (mm_check($user,$list,$password)) {
    mmalog("authentification failed ($password)");
    http_die("authentification for list $list failed");
  }
  if ($user =~ m:/:) {
    mmalog("Illegal character / in $user");
    http_die("Illegal character / in $user");
  }
  if (open F,"$user/@") {
    $id = <F>;
    http_die("no access") unless $id;
    chomp $id;
    close F;
  } else {
    $id = randstring(8);
    mkdir $user,0700;
    open F,">$user/@" or http_die("Cannot create user ID file - $!");
    print F $id,"\n";
    close F;
    if (open F,">$user/.auto") {
      print F "mailman:$list\n"; 
      close F;
    }
  }
  $akey = untaint(md5_hex("$user:$id"));
  symlink "../$user","$akeydir/$ra:$akey";
  nvt_print(
    "HTTP/1.1 303 See Other",
    "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fup?akey=$akey",
    ""
  );
  mmalog("authentification ok");
  exit;
}

http_header("200 OK");
pq(qq(
  '<h1>$head</h1>'
  '<a href="http://$ENV{HTTP_HOST}/">F*EX (File EXchange)</a>'
  'is a service to send big files to any user on the internet.'
  '<p>'
  '<form action="$ENV{SCRIPT_NAME}" method="post"'
  ' accept-charset="UTF-8" enctype="multipart/form-data">'
  '<table>'
  '  <tr><td>Login (your e-mail address):'
  '      <td><input type="text"     name="user" size="60" value="$user"></tr>'
  '  <tr><td><a href="$mm_url/listinfo">Mailing list</a>:'
  '      <td><input type="text" name="list" size="16" value="$list"></tr>'
  '  <tr><td>Password:'
  '      <td><input type="password" name="password" size="16"></tr>'
  '</table>'
  '<p>'
  '<input type="submit" value="continue">'
  '</form>'
  '</body></html>'
));
exit;
  

sub mm_check {
  my ($user,$list,$password) = @_;
  my ($SH,$server,@post,$length,$reply);
  my $mm = '';
  my $auth = 0;
  my $port = 80;
  local $_;
  
  $server = $mm_url;
  $server =~ s{http://}{};
  $mm   = $1 if $server =~ s:(/.*)::;
  $port = $1 if $server =~ s/:(\d+)//;

  $SH = IO::Socket::INET->new(
    PeerAddr => $server,
    PeerPort => $port,
    Proto    => 'tcp',
  );

  http_die("cannot connect to $server:$port") unless $SH;
  
  $boundary = randstring(32);

  push @post,"--$boundary";
  push @post,"Content-Disposition: form-data; name=\"email\"";
  push @post,"";
  push @post,"$user";
  push @post,"--$boundary";
  push @post,"Content-Disposition: form-data; name=\"password\"";
  push @post,"";
  push @post,"$password";
  push @post,"--$boundary--";
  
  $length = length(join('',@post))+scalar(@post)*2;
  
  unshift @post,"POST /$mm/options/$list HTTP/1.1",
                "Host: $server",
                "Content-Length: $length",
                "Content-Type: multipart/form-data; boundary=$boundary",
                 "";
  
  print {$SH} $_,"\r\n" foreach (@post);
  
  $reply = <$SH>;
  http_die("no reply from $mm_url") unless $reply;
  http_die("error from $mm_url : $reply") if $reply !~ /^HTTP.... 200/;
  while (<$SH>) {
    $auth = 1 if /Submit.*options-submit/;
  }
  close $SH;
  return $auth;
}


# alternative authentication methode: do it locally
sub mm_check_local {
  my ($user,$list,$password) = @_;
  my %mm;
  local $_;
  local *P;
  local $ENV{PATH} = '';
  
  open P,"/usr/lib/mailman/bin/dumpdb /var/list/$list/config.pck|"
    or http_die("No access to mailman list $list - $!");
  while (<P>) { last if /'password': \'/ } 
  while (<P>) { 
    s/.* \{ //; 
    $mm{$1} = $2 if /'(.+?)': '(.+)'/; 
    last if /\'\},/; 
  }
  while (<P>) {}
  close P;
  
  return ($mm{$user} and $mm{$user} eq $password);
}


sub mmalog {
  my $msg = "@_";
  
  $msg =~ s/\n/ /g;
  $msg =~ s/\s+$//;
  
  if (open $log,">>$log") {
    flock $log,LOCK_EX;
    seek $log,0,SEEK_END;
    printf {$log} "%s %s (%s) %s %s\n",isodate(time),$user,$fra,$list,$msg;
    close $log;
  }
}
