#!/usr/bin/perl -wT

# F*EX CGI for FIX Java client
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Copyright: GNU General Public License

use Digest::MD5	qw(md5_hex);

# add fex lib
($FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
die "$0: no $FEXLIB\n" unless -d $FEXLIB;

$| = 1;

our $error = 'F*EX ERROR';
our $head = "$ENV{SERVER_NAME} F*EX FIX";

# import from fex.pp
our ($spooldir,$akeydir,$skeydir,$gkeydir);
our $skey = '';
our $gkey = '';
our $akey = '';

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

chdir $spooldir or http_die("$spooldir - $!\n");

my ($name,$value);
my $user = '';
my $to = '';
my $id = '';

# parse HTTP QUERY_STRING
foreach (split '&',$ENV{QUERY_STRING}) {
  /(.+?)=(.*)/;
  $name  = $1 || $_;
  $value = $2 || '';
  # decode %URL-encoded parameters
  $value =~ s/%([a-f0-9]{2})/chr(hex($1))/gie;
  setparam($name,$value); 
};

if ($akey and not $from) {
  if (open $idf,'<',"$akeydir/$sid:$akey/@" and $id = <$idf>) {
    chomp $id;
    close $idf;
    $from = readlink "$akeydir/$sid:$akey" 
      or http_die("internal server error: no $akey symlink");
    $from =~ s:.*/::;
    if ($akey ne md5_hex("$from:$id")) {
      http_die("wrong AKEY");
    }
  }
}

if ($skey) {
  $from = $to = $id = $rid = '';
  if (open $skey,'<',"$skeydir/$skey") {
    while (<$skey>) {
      if (/^(\w+)=(.+)/) {
        $from = $2 if lc($1) eq 'from';
        $to   = $2 if lc($1) eq 'to';
        $id   = $2 if    $1  eq 'id';
      }
    }
    close $skey;
  } else {
    http_die("wrong SKEY");
  }
  if ($from and $to and $id) {
    if (open $to,'<',"$to/\@SUBUSER") {
      while (<$to>) {
        chomp;
        if (/^\Q$from:$id\E$/i) {
          $rid = $id;
          last;
        }
      }
      close $to;
    }
  } else {
    http_die("INTERNAL ERROR: missing data in $skey");
  }
  unless ($rid) {
    debuglog("wrong SKEY:$skey from=$from id=$id");
    http_die("authentification failed for SKEY=$skey");
  }

} elsif ($gkey) {
  $from = $to = $id = $rid = '';
  if (open $gkey,'<',"$gkeydir/$gkey") {
    while (<$gkey>) {
      if (/^(\w+)=(.+)/) {
        $from = $2 if lc($1) eq 'from';
        $to   = $2 if lc($1) eq 'to';
        $id   = $2 if    $1  eq 'id';
      }
    }
    close $gkey;
  } else {
    http_die("wrong GKEY");
  }
  if ($from and $to and $id) {
    if (open $to,'<',"$to/\@SUBUSER") {
      while (<$to>) {
        chomp;
        if (/^\Q$from:$id\E$/ or /^\*:$id\E$/) {
          $rid = $id;
          last;
        }
      }
      close $to;
    }
  } else {
    http_die("INTERNAL ERROR: missing data in $gkey");
  }
  unless ($rid) {
    debuglog("wrong GKEY:$gkey from=$from id=$id");
    http_die("authentification failed for GKEY=$gkey");
  }

} elsif ($id and $from) {
  
  # regular user?
  if(open $from,'<',"$from/\@") {
    $rid = <$from>||'';
    chomp $rid;
    close $from;
    $rid = '' if $id ne $rid;
  }
  
  # group member without gkey?
  if ($to and $to =~ /^@([\w-]+)$/) {
    if (open $group,"$from/\@GROUP/$1") {
      # full user?
      $group_ok = $id if $rid and $id and ($id eq $rid);
      while (<$group>) {
        s/#.*//;
        s/\s//g;
        if (/([^\/]+):(.+)/) {
          my $gm = $1;
          my $gi = $2;
          if ($gm =~ /^\Q$from\E/i) {
            if (($id eq $gi) or $rid and ($id eq $rid)) {
              $group_ok = $rid = $id;
            } else {
              # fuplog("ERROR: wrong auth-ID $id from $from for group $to");
              debuglog("id sent by user $from=$id, group $to id=$gi");
              http_die("Wrong auth-ID");
            }
          } else {
            push @group,$gm;
          }
        }
      }
      close $group;
      unless ($group_ok) {
        # fuplog("ERROR: $from not in group $to");
        debuglog("$from not in group $to");
        http_die("You are not in this group");
      }
      unless (@group) {
        http_die("Recipient group has no members");
      }
    } else {
      # fuplog("ERROR: group \@$to does not exist");
      debuglog("$from/\@GROUP/$to : $!");
      http_die("No such group $to");
    }
  }

} else {
  http_die("missing user data");
}

# public recipient? (needs no auth-ID for sender)
if ($from and $to and $id and $id eq 'PUBLIC' and
    @public_recipients and grep /^\Q$to\E$/i,@public_recipients) {
  unless (checkaddress($from)) {
    http_die("$from is not a valid e-mail address");
  }
  $rid = $id;
}

http_die("$from has no auth-ID") unless $rid;
http_die("Wrong auth-ID") if $rid ne $id;

http_header('200 OK');
print html_header($head);

if ($skey) {
  $id = "skey:$skey";
}

$java = 'http://java.sun.com/javase/downloads/index.jsp#jre';
pq(qq(
  '<applet code="fix.Client.class" archive="FIX.jar" width=150 height=50>'
  '  <param name="server"   value="$ENV{PROTO}://$ENV{HTTP_HOST}">'
  '  <param name="user"     value="$from">'
  '  <param name="to"       value="$to">'
  '  <param name="id"       value="$id">'
  '  <param name="skey"     value="$skey">'
  '  <param name="gkey"     value="$gkey">'
  '  <param name="akey"     value="$akey">'
  '</applet>'
  '<script language="JavaScript"><!--'
  'if (navigator.javaEnabled()) {'
  '  /* JAVA ok */'
  '} else {'
  '  document.write("found no java runtime environment, cannot start F*IX upload applet");'
  '}'
  '//  --></script>'
  '<p>'
  'You will need <a href="$java">java</a> version >= 1.6'
  '<p>'
  'Warning: F*IX will not work correctly on a Macintosh.'
  '<p>'
  '<a href="/fup>back to fup (HTML upload page)</a>'
  '</body></html>'
));

exit;


# set parameter variables
sub setparam {
  my ($v,$vv) = @_;
  my ($key,$idf);
  
  $v = uc(despace($v));
  if      ($v eq 'FROM') { 
    $from = despace($vv);
  } elsif ($v eq 'TO') { 
    $to = despace($vv);
  } elsif ($v eq 'ID') { 
    $id = despace($vv);
  } elsif ($v eq 'SKEY') { 
    $skey = despace($vv);
  } elsif ($v eq 'GKEY') { 
    $gkey = despace($vv);
  } elsif ($v eq 'AKEY') { 
    $akey = despace($vv);
  }
}
