#!/usr/bin/perl -w
###################################################
# This Daemon has 3 Methods:
# getCSR (sid)
#  - creates a new Certificate Signing Request together with a
#  - secret key which can be looked up via the Session ID (sid)
#  - the key will be held in memory
#  - returns the CSR
# putCRT (sid, CRT)
#  - receives a signed certificate
#  - creates a PKCS#12 key pair from the cert and the in-memory key 
#  - encrypts the p12 with a random passphrase
#  - the random passphrase is held in memory, can be looked up via the sid
#  - the p12 is stored in LDAP under the user's entry (found using the sid)
#  - returns true or false
# getPassphrase (sid)
#  - returns the Passphrase to the p12 key pair using the sid.
#
# ... and possibly a credential negotiation function for CRUD to follow
# 
# The daemon forks with each request and uses System V IPC to access
# the passphrase hash from each child process
# 
# The socket is only accessible by RBAC (i.e. on the same machine) 
# using proxy functions. RBAC speaks only HttpS and the separate RBAC function 
# getPassphrase uses Client Auth from CRUD
#
# author Martin Haase / DAASI International GmbH / Project SLC-Gap
# inspired by gridshib-ca-demo-portal.cgi and the Perl Cookbook
#
# creation date: 2010-03-22
# 
# 2010-03-23: rapid prototyping stubs for every function
# 2010-03-23: getCRT, 
# 2010-03-24: putCRT,
# 2010-05-06: getPassphrase; 
# 2010-05-19: debugged/fixed, ported to perl 5.10
# 2010-07-13: introduce configuration file using DAASIlib::CONF
# 2010-07-15: changed from INET to local UNIX socket
# 2011-06-06: random initialization, better debuggg logging
#

use IO::Socket;
use POSIX qw(:sys_wait_h);
use IPC::Shareable;

use Math::Random;
use Time::HiRes;

use warnings "all";
use Data::Dump qw(dump);

use Net::LDAP qw(LDAP_SUCCESS LDAP_TIMELIMIT_EXCEEDED LDAP_SIZELIMIT_EXCEEDED 
                 LDAP_NO_SUCH_OBJECT LDAP_ALREADY_EXISTS );
# this one needs IO::Socket::SSL

use Crypt::OpenSSL::PKCS10 qw( :const );
use Crypt::OpenSSL::RSA;
use Crypt::OpenSSL::X509;
use Crypt::OpenSSL::PKCS12;
use File::Temp;

use DAASIlib::CONF qw (is_debug);
use DAASIlib::Data;
# these two need: IO::Prompt, Log::Log4perl, DBI, DAASIlib::Gettext, Config::General

my $data = new DAASIlib::Data;
my ($progname, $progpath, $etcdir, $sysconfig) = $data->getProgramFiles($0);

#print "progname: $progname, path: $progpath, etc: $etcdir, sysconfig: $sysconfig\n";

my $conf = new DAASIlib::CONF;
$conf->loadConfig($sysconfig, $progpath, $etcdir);

my %ldap_config;
foreach $k (keys %{$conf->{data}}) {
    if ($k =~ /^ldap_conf_(\S+)/) {
	$ldap_config{$1} = $conf->{data}{$k};
    }
}


$DEBUG = 0;
if (defined $conf->{data}->{debugmode} && $conf->{data}->{debugmode}) { $DEBUG = 1 }
my $socketfile = $conf->{data}{socketfile};
my $RBACuser = $conf->{data}{rbacuser};
my $passphraselength = $conf->{data}{passphraselength};


# dead child process reaper
sub REAPER {
    1 until (-1 == waitpid(-1, WNOHANG));
    $SIG{CHLD} = \&REAPER;
}
$SIG{CHLD} = \&REAPER;

# child sigint definition
$SIG{INT} = sub { die "$$ dying...\n" };

# shared hash in-memory for passphrases
$handle = tie %passphrases, 'IPC::Shareable', undef, {destroy => 1};

unlink $socketfile;
$server = IO::Socket::UNIX->new(Local => $socketfile,
				Type => SOCK_STREAM,
				Reuse => 1,
				Blocking => 1,
				Listen => SOMAXCONN )
    or die "Cannot be a UNIX Socket Server with file $socketfile: $@\n";

use vars qw($login $pass);
($login,$pass,$uid,$gid) = getpwnam($RBACuser) or die "$RBACuser not in passwd file";
chown $uid, $gid, $socketfile;

debuggg ("\n------------ Demon restart at ". scalar ( localtime()) . " ------------\n");

while (1) {
    $client = $server->accept();
    
    next unless defined( $client);

    next if $pid = fork; # Parent macht weiter im while

    die "fork: $!" unless defined $pid; # das kommt nicht vor

    # ab hier kindprozess
    close $server; # server nicht mehr gebraucht im Kindprozess
    doJob ($client);
    exit; # das Kind stirbt und macht keine neue accept-Prüfung
} continue {

    close $client if defined( $client );; #  im Elternprozess nicht mehr gebraucht

}


sub doJob {
    random_set_seed_from_phrase(Time::HiRes::time);

    debuggg (scalar ( localtime()) . " doing Job ...\n");
    my $client = shift;

    my $routine = <$client>;
    chomp $routine;
    debuggg ("Routine is $routine ...\n");

    my $sid = <$client>;
    chomp $sid;
    debuggg ("SID is $sid ...\n");
    
    debuggg ("SID Inventory:\nSID: ");
    debuggg (join "\nSID: ",keys %passphrases);
    debuggg ("\n");

    if ($routine eq "getCSR") {
	my ($csr, $key) = &getCSR();
	
	$handle->shlock();
	$passphrases{$sid} = $key; # store temporarily the RSA key here, will be replaced by a $passphraselength long pkcs12 passphrase when putCRT is called
	$handle->shunlock();

	print $client "getCSRresult\n";
	print $client $csr;

    } elsif ($routine eq "putCRT") {
	my $crt = "";
	while ($next = <$client>) {
	    last if $next =~ />>>EOF<<</;
	    $crt .= $next;
	} 

	$result = &putCRT ( $sid, $crt);

	print $client "putCRTresult\n";
	print $client $result;

    } elsif ($routine eq "getPassphrase") {
	my $passphrase = &getPassphrase($sid);

	print $client "getPassphraseresult\n";
	print $client $passphrase;

    } else { 
	die "Unknown command: $routine";
    } 
#    debuggg "returned $routine result to socket client\n...\n";
    print $client "\n".'>>>EOF<<<'."\n";
    # jetzt sagt der server nix mehr (s. exit im while)
}

########################################################
# specific functions
################
sub getCSR {
    # create dummy CSR with key
    
    my $req = Crypt::OpenSSL::PKCS10->new();

    # Use dummy DN, GridShib-CA will override with correct value
    $req->set_subject("/C=US/O=Dummy/CN=Dummy");
    $req->sign();

    return ($req->get_pem_req(), $req->get_pem_pk());
}


sub putCRT {
    my ($sid, $crt) = @_;
    my $key = $passphrases{$sid};

    # check whether key and crt match
    if ( !defined $key || !matchKeys($key,$crt)) { return "false";}

    # create random passphrase for p12
    my $randompassphrase = createRandomPhrase();

    # create p12 from key and crt
    my $p12 = buildP12 ($crt, $key, $randompassphrase);

    # send p12 to LDAP, first looking up which user entry the $sid belongs to
    my $transferToLDAPsuccess = sendPKCS12toLDAP ( $sid, $p12, $crt, \%ldap_config );
    if (!$transferToLDAPsuccess) { return "false"; }

    # finally, given all other operations succeeded,
    # register passphrase now for daemon's lifetime, replacing the key
    $handle->shlock();
    $passphrases{$sid} = $randompassphrase;
    $handle->shunlock();

    return "true";
}

sub getPassphrase {
    my $sid = shift;

    if (length $passphrases{$sid} > $passphraselength) {
	die "Certificate for SID $sid not yet signed!";
    }
    return $passphrases{$sid};

}

#########################################################################
# helper subs
#############
sub createRandomPhrase {
    $ps ="";
    while(length ($ps) < $passphraselength ) {
        $r = chr ( random_uniform_integer (1, 48, 122 ));
        $ps .= $r if ($r =~ m/[a-zA-Z0-9]/);
    }
    return $ps;
}

sub matchKeys {
    my ($key_string, $crt_string) = @_;

    if (length ($key_string) <= $passphraselength) { 
        # is already passphrase set and no RSA key anymore
	return 0;
    }

    my $key = Crypt::OpenSSL::RSA->new_private_key($key_string);
    my $public_key_string = $key->get_public_key_string;

    my $crt = Crypt::OpenSSL::X509->new_from_string ( $crt_string );
    my $public_crt_string = $crt->pubkey();
    
    return ( $public_key_string eq  $public_crt_string);

}

sub buildP12 {
    my ($crt, $key, $pass) = @_;

    my ($fh, $filename) = File::Temp::tempfile(UNLINK => 0,
					    DIR => "/tmp");
#    close $fh;
    
    $p12obj = Crypt::OpenSSL::PKCS12->new();
    $p12obj->create( $crt, $key, $pass, $filename );

    open (P12, "<$filename");
    read P12, $p12contents, 99999;
    close P12;

    unlink ( $filename );

    return $p12contents;
}



sub sendPKCS12toLDAP {
    my ($sid,$pkcs12,$crt_string,$rh_ldap_config) = @_;

    my $gridX509subjectDn = Crypt::OpenSSL::X509->new_from_string ( $crt_string )->subject();
    # make the Grid format: ", " -> "/"
    $gridX509subjectDn =~ s(^)[/];
    $gridX509subjectDn =~ s(, )[/]g;

    my $ldap = ldapConnect($rh_ldap_config);
    if (not defined $ldap) {
	return 0;
    }


    ### first search for the session entry
    my $filter = "(rbacname=$sid)";

    my $rbacbase = $rh_ldap_config->{basedn};
    $rh_ldap_config->{basedn} = "ou=sessions," . $rbacbase;

    my $mesg = ldapSearch($ldap, $filter, $rh_ldap_config);

    my $entry;
    my $eppn;

    if ( $mesg) {
        $entry = $mesg->pop_entry();
	if (!defined ($entry)) {
	    ### Kein Eintrag gefunden
	    return 0;
	}
	$eppn = $entry->get_value( 'rbacSessionUser' );
    } else {
        ### Kein Eintrag gefunden
	return 0;
    }

    ### then search for the ePPN and put the p12 there
    $filter = "(uid=$eppn)";

    $rh_ldap_config->{basedn} = "ou=people," . $rbacbase;

    $mesg = ldapSearch($ldap, $filter, $rh_ldap_config);

    if ( $mesg) {
        $entry = $mesg->pop_entry();
	if (!defined ($entry)) {
	    ### Kein Eintrag gefunden
	    return 0;
	}
	$entry->changetype( "modify" );

        $entry->replace( "userpkcs12" => $pkcs12 );

	if (! grep( /^gridCertificateUser$/,  $entry->get_value('objectclass') ) ) {
	    $entry->add( "objectclass" => "gridCertificateUser" );
	}

	$entry->replace( "gridX509subject" => $gridX509subjectDn );

        my $updatemesg = $entry->update($ldap);
        if ( $updatemesg->code != Net::LDAP::LDAP_SUCCESS ) {   
            ## Fehler;
	    return 0;
        }
    } else {
        ### Kein Eintrag gefunden
	return 0;
    }
    return 1;
}

sub ldapConnect {
    my ($rh_ldapdef) = @_;
    
    my $uri = 'ldap://'.$rh_ldapdef->{'host'}.':'.$rh_ldapdef->{'port'};

    my $ldap = Net::LDAP->new( $uri); 
    
    
    if ( !$ldap ) {
        return(undef);
    }
    
    if ( $rh_ldapdef->{is_tls} ) {
        my $tlsmesg = $ldap->start_tls ( verify => $rh_ldapdef->{tls_verify},
                                         cafile => $rh_ldapdef->{tls_cafile},
                                         ciphers => $rh_ldapdef->{tls_cypher});
        
        if ( $tlsmesg->code != Net::LDAP::LDAP_SUCCESS ) {
	    # we can do without tls, the server is here.
	    # return undef;
        }
    }
    
    my $mesg = $ldap->bind( $rh_ldapdef->{binddn}, 
                            password => $rh_ldapdef->{bindpw} );
    
    unless ( $mesg->code == Net::LDAP::LDAP_SUCCESS ) {
	return undef;
    }
    
    return $ldap;
} 



sub ldapSearch {
    my ( $ldap, $filter, $rh_ldapdef ) = @_;

    if ( ! $$rh_ldapdef{filter}) {
        $$rh_ldapdef{filter}="(objectclass=*)";
    }

    my $mesg = $ldap->search(
	base      => $$rh_ldapdef{basedn},
	scope     => $$rh_ldapdef{scope},
                             filter    => $filter,
	);
 
    if ( $mesg->code == Net::LDAP::LDAP_SUCCESS ) {

    } else {
	return undef;
    }

    return ($mesg);
}

sub debuggg {
    return unless $DEBUG;
    print shift;
}
