Datatid 2000 #2/Datatid-2000-02.iso/internet/ecpro/setup.exe/CCLIB.PM

Perl POD Document | 1997-12-03 | 22.5 KB | 821 lines

# --*-PERL-*--
#####################################################################
#
# Copyright 1996, CyberCash Inc. All rights reserved.
# Written by Brian Boesch and Judy Grass
# Modified by Gene Gotimer
#
# These routines are intended to be used exclusively with the
# CyberCash secure payment system.
#
# RCSID: $Id: CCLib.pm,v 1.5 1997/07/14 11:53:30 gotimer Exp $
#
# Do not redistribute without written permission from CyberCash Inc.
######################################################################

# This CCLib.pm is part of the  distribution.

package CCLib;

require Exporter;
@ISA = (Exporter);
@EXPORT = qw();
@EXPORT_OK = qw( sendmserver   urlencode     urldecode
                 GetQuery      SplitMessage  Clean
                 SetServer     Browser       GetHash
                 Now           Seconds       GMT
                 HumanSeconds  encode        decode );

$computehash = '/usr/local/bin/computehash';
$tmpdir = $ENV{'TMP'}; # NT only

# UNIX or NT version
$OS = 'NT';

# Set the CyberCash CashRegister version number
$version = '';

use Socket;
use Time::Local;

#
# Debugging: Modify the variables below to enable debugging to a log file
#
# Be aware that performance is greatly decreased with debugging turned on
#

# Debugging is on if $debugging is not 0
# Set to 1 for API level debugging: only what comes into sendmserver
#    and GetQuery and what goes out of sendmserver and GetQuery is
#    logged
# Set to 2 for debugging every step of the way
$debugging = 0;

# Debug messages will be written to this file
$debuglog = '/tmp/CCLib.log';

# Leave this variable alone, it is used to control the level of
# indent for debugging messages
$indent = '';


##########################################################
# sendmserver(url,
#      attribute, value,
#      attribute2, value2,
#      ...);
#
# Returns set of attribute values appropriate for an assoc array
#
sub sendmserver {

# Get the url and name-value pairs passed as parameters
    local($url, @pairs) = @_;

# set up some variables
    local($encoded_pairs);
    local($payment_server_addr,@payment_server_addrs,$payment_server_socket);
    local($name,$aliases,$protocol,$addrtype,$length);
    local($pairs_length,$message,$message_length,$write_result);
    local($timeout,$TimedOut,$socket_data,@socket_data);
    local(%result) = ();

# For backwards compatibility
    $paymentserverhost = $main::paymentserverhost || $paymentserverhost;
    $paymentserverport = $main::paymentserverport || $paymentserverport;
    $paymentserversecret = $main::paymentserversecret || $paymentserversecret;

    if ($debugging) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "\n${indent}== Entering sendmserver ==\n";
    $indent .= '  ';
    print DEBUG "${indent}POST to host: $paymentserverhost, port: $paymentserverport\n";
    print DEBUG "${indent}secret: $paymentserversecret, command: $url\n\n";

    print DEBUG "${indent}## Name-Value pairs to send ##\n";
    my($i,$j);
    for ($i=0; $i<@pairs; $i+=2) {
        $j = $i + 1;
        print DEBUG "${indent}$pairs[$i] = [[$pairs[$j]]]\n";
    }
        print DEBUG "\n";
    close(DEBUG);
    }

# turn the name-value pairs into a url encoded message
    $encoded_pairs = &urlencode(@pairs);

    if ($debugging > 1) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "${indent}Encoded name-value pairs: $encoded_pairs\n";
    close(DEBUG);
    }

# set up the socket to talk to the payment server
    if ($OS eq 'UNIX') {
    $SOCK_STREAM = SOCK_STREAM;
    $AF_INET = AF_INET;
    } else {
    $SOCK_STREAM = 1;
    $AF_INET = 2;
    }

# find the TCP protocol information
    ($name,$aliases,$protocol) = getprotobyname('tcp');

# find the address for the payment server
   if ($paymentserverhost =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
      $payment_server_addr = pack("C4", $1, $2, $3, $4);
   } else {
      ($name,$aliases,$addrtype,$length,@payment_server_addrs) = gethostbyname($paymentserverhost);
      $payment_server_addr = $payment_server_addrs[0];
   }

# Put the socket info into the correct format for the connect
    $payment_server_socket = pack('S n a4 x8',$AF_INET,$paymentserverport,$payment_server_addr);

# This is a better version, but sockaddr_in is undefined in Perl 5.001m
#    $payment_server_socket = sockaddr_in($paymentserverport,$payment_server_addr);

# make the socket filehandle and connect to the socket
# if any fail, reply and return with an appropriate error message
# "S" is the socket filehandle
    socket(S,$AF_INET,$SOCK_STREAM,$protocol) || (&SocketFailed,return %result);
    if ($debugging > 1) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "\n${indent}Opened socket.\n";
    close(DEBUG);
    }

    connect(S,$payment_server_socket) || (&ConnectFailed,return %result);
    if ($debugging > 1) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "${indent}Connected to socket.\n\n";
    close(DEBUG);
    }

# Now that the socket is open, create a message to send
    $pairs_length = length($encoded_pairs);
    $message = <<"END";
POST /$paymentserversecret/$url HTTP/1.0
User-Agent: CyberCashMerchant-$version
Content-type: application/x-www-form-urlencoded
Content-length: $pairs_length

$encoded_pairs
END
    $message_length = length($message);

    if ($debugging > 1) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "${indent}Encoded name-value pairs length = $pairs_length\n";
    print DEBUG "${indent}Message:\n$message\n";
    print DEBUG "${indent}Message length = $message_length\n";
    close(DEBUG);
    }

    if ($OS eq 'UNIX') { # alarms are not implemented in NT Perl
# set up a handler for response timeouts
    $SIG{'ALRM'} = \&Timeout;
# SIGALRM will now call the &CCLib::Timeout routine

# set a flag so we can see if we timed out
    $TimedOut = 0;

# set the timeout value for sending a message
# WARNING: The payment server may wait up to 90 seconds for
#          a response from the CyberCash server. If you don't
#          wait at least 90 seconds, you may be giving up
#          too early. Be patient.
    $timeout = 120;
    alarm($timeout);
    }

# force flush the output buffer
   select(S); $| = 1; print ''; select(STDOUT);

# send the message over the socket
    if ($OS eq 'UNIX') {
# $write_result will be undef if there was an error
    $write_result = syswrite(S,$message,$message_length);
    unless ( defined($write_result) ) { &SyswriteFailed; return %result; }
    } else {
    print S $message;
    }

# reinstate buffered I/O
    $| = 0;

    if ($debugging > 1) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "${indent}Wrote message to socket.\n";
    print DEBUG "${indent}Reading response.\n";
    close(DEBUG);
    }

    if ($OS eq 'UNIX') {
# reset the alarm while we wait for a response
    alarm($timeout);
    }

# read the socket line-by-line
    while (<S>) {

    if ($OS eq 'UNIX') {
# if we timed out, we should return. %results is already filled out.
        return %result if ($TimedOut);
    }

    if ($debugging > 1) {
        open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
        print DEBUG "${indent}Read single line: $_\n";
        close(DEBUG);
    }

    if ($OS eq 'UNIX') {
# reset the alarm for the next line
        alarm($timeout);
    }

# if we are told to go away, then we should do just that
    if (/x-go-away-message/i) { &GoAway; return %result;}

# read until a blank line
    last if (/^\s*$/);
    }

    if ($OS eq 'UNIX') {
# reset the alarm for the all-at-once read
    alarm($timeout);
    }

# we want to read all the rest of the data, all at once,
# then convert to a single scalar value
    @socket_data = <S>;
    $socket_data = join('',@socket_data);

    if ($debugging > 1) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "${indent}Read all at once:\n@socket_data\n";
    print DEBUG "${indent}Finished reading response.\n";
    close(DEBUG);
    }

    if ($OS eq 'UNIX') {
# turn off the alarm and reset the default signal handler
    alarm(0);
    $SIG{'ALRM'} = 'DEFAULT';
    }

# decode the url encoded response, and send back the result
# as an associative array (%result)
    %result = &urldecode($socket_data);

    if ($debugging) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "${indent}## Decoded response Name-Value pairs ##\n";
    foreach (keys %result) {
        print DEBUG "${indent}$_ = [[$result{$_}]]\n";
    }
    $indent =~ s/  //;
    print DEBUG "\n\n${indent}== Exiting sendmserver ==\n\n\n";
    close(DEBUG);
    }

    return %result;
}


#
# This routine is called when a SIGALRM is received.
# That means that we have timed-out waiting for a
# response from the payment server.
#
sub Timeout {

    $result{'MStatus'} = 'failure-hard';
    $result{'MErrLoc'} = 'CCLib';
    $result{'MErrMsg'} = "No response in $timeout seconds from the Merchant Payment Server.";

    $TimedOut = 1;
}


##########################################################
#
# Set the server information
#
sub SetServer {
    local(%server) = @_;

    $paymentserverhost = $server{'host'};
    $paymentserverport = $server{'port'};
    $paymentserversecret = $server{'secret'};

}


##########################################################
#
# Strip any unwanted characters from a given string,
# in this case, anything but a-z, A-Z, 0-9, plus, minus,
# space, tab, slash, at, period, percent, or backslash
# Most importantly, semicolons and dollar signs are removed
# so they won't get passed to the command line.
#
sub Clean {

    local($string) = @_;

# check that all characters are legal,
# if not, delete illegals
    $string =~ tr/a-zA-Z0-9_\-+ \t\/\@\.%\\//cd;

    return $string;
}


##########################################################
#
# URL encode the message and place into "cybermessage"
# urlencode takes a list elements 0,2,4,... are fieldnames
#                        elements 1,3,5,... are values
#
sub urlencode {
    my(@msglist) = @_;
    my($msg) = '';
    my($name,$value);

    if ($debugging > 1) {
        open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
        print DEBUG "\n${indent}== Entering urlencode ==\n";
        $indent .= '  ';
        close(DEBUG);
    }

# step through the list
    while (@msglist > 0) {

# grab the next name-value pair
    $name = shift(@msglist);
    $value = shift(@msglist);

        if ($debugging > 1) {
        open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
        print DEBUG "${indent}Raw (Encoded) name-value pair: $name -> $value";
        close(DEBUG);
        }

# encode the name and value
    $name = &encode($name);
    $value = &encode($value);

        if ($debugging > 1) {
        open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
        print DEBUG " ($name -> $value)\n";
        close(DEBUG);
        }

# add the now-encoded name-value pair to the message
    $msg .= "$name=$value";

# add an ampersand (as a name-value pair delimiter) unless
# we have reached the end
    $msg .= '&' unless (@msglist <= 0);

        if ($debugging > 1) {
        open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
        print DEBUG "${indent}Message is now: $msg\n\n";
        close(DEBUG);
        }

    }

# everything is url encoded, so send the message back
    if ($debugging > 1) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    $indent =~ s/  //;
    print DEBUG "${indent}== Exiting urlencode ==\n\n";
    close(DEBUG);
    }

    return $msg;
}


##########################################################
#
# URL decode the message
#
sub urldecode {
    my($encoded) = @_;
    my(@pairs) = split(/&/,$encoded);
    my(%pairs,$name,$value);

    if ($debugging > 1) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "\n${indent}== Entering urldecode ==\n";
    $indent .= '  ';
    close(DEBUG);
    }

    foreach (@pairs) {

# Split into name and value
    ($name,$value) = split(/=/,$_,2);

        if ($debugging > 1) {
        open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
        print DEBUG "${indent}Raw name-value pair: $_\n";
        close(DEBUG);
        }

# Convert plus signs to spaces, and %XX from hex numbers to alphanumeric
    $name = &decode($name);
    $value = &decode($value);

# If the name has already been seen, just tack the value on the end
# with a \0 delimeter
    if ( defined($pairs{$name}) ) {
        $pairs{$name} .= "\0$value";
    } else {
        $pairs{$name} = $value;
    }

        if ($debugging > 1) {
            open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
            print DEBUG "${indent}Decoded name-value pair: $name -> $pairs{$name}\n\n";
            close(DEBUG);
        }
    }

    if ($debugging > 1) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    $indent =~ s/  //;
    print DEBUG "${indent}== Exiting urldecode ==\n\n";
    close(DEBUG);
    }

    return %pairs;
}


# URL encode a string
sub encode {
    my($text) = @_;

    # only alphanumerics and underscore (\w), dash, period, and star
    # can go through UNencoded
    $text =~ s/([^ \w\-.*])/sprintf("%%%2.2x",ord($1))/ge;

    # spaces get converted to plus signs (+)
    # plus signs were already converted to %2B (ascii 43)
    $text =~ s/ /+/g;

    return $text;
}


# URL decode a string
sub decode {
    my($text) = @_;

    # Convert plus signs to spaces, and %XX from hex numbers to alphanumeric
    $text =~ s/\+/ /g;
    $text =~ s/%([a-fA-F0-9]{2})/pack("c",hex($1))/ge;

    return $text;
}



##########################################################
#
# Get the query from the HTTP message
#
sub GetQuery {
    my($query,%pairs) = '';

    if ($debugging) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "\n${indent}== Entering GetQuery ==\n";
    $indent .= '  ';
    print DEBUG "${indent}$ENV{'REQUEST_METHOD'} request:\n";
    close(DEBUG);
    }

# Read in text
    if ($ENV{'REQUEST_METHOD'} =~ /GET/i) {
        $query = $ENV{'QUERY_STRING'};

    if ($debugging > 1) {
        open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
        print DEBUG "$query\n";
        close(DEBUG);
    }

    } elsif ($ENV{'REQUEST_METHOD'} =~ /POST/i) {
    read(STDIN,$query,$ENV{'CONTENT_LENGTH'}) if ($ENV{'CONTENT_LENGTH'} > 0);

    if ($debugging > 1) {
        open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
        print DEBUG "${indent}Content-Length = $ENV{'CONTENT_LENGTH'}\n";
        print DEBUG "$query\n";
        close(DEBUG);
    }
    }

# Decode the results
    %pairs = &urldecode($query);

    if ($debugging) {
    open(DEBUG, ">>$debuglog") || die "\nCCLib.pm debugging: Cannot append to $debuglog: $!";
    print DEBUG "${indent}## Decoded Name-Value pairs ##\n";
        foreach (keys %pairs) {
            print DEBUG "${indent}$_ = [[$pairs{$_}]]\n";
        }
        $indent =~ s/  //;
        print DEBUG "\n\n${indent}== Exiting GetQuery ==\n\n\n";
    close(DEBUG);
    }

    return %pairs;
}


##########################################################
#
# Split up a MIME message into an associative array
#
sub SplitMessage {
    local($message,$ccmessage) = @_;
    local(@message,%message,$field,$colon,$data);

    @message = split(/\n/,$message);
    if ($ccmessage) {
        # take the header and footer off
        $message{'header'} = shift(@message);
        $message{'footer'} = pop(@message);
    }

    # parse the message
    $field = '';
    $colon = '';
    foreach (@message) {
        if (/^\s+/) {   # continuation line
            if ($field) {
                ($data) = /^\s+(.+)/;
                $data .= "\n";
                if ($colon eq ':') {
                    $data =~ s/\s*$//; # only trim trailing whitespace if colon
                }
                $message{$field} .= $data;
            }
        } else {   # new field
            ($field,$colon,$data) = /^\s*(.+?)\s*([:;])\s*(.+)/;
            $data .= "\n";
            if ($colon eq ':') {
                $data =~ s/\s*$//; # only trim trailing whitespace if colon
            }
            $message{$field} = $data;
        }
    }

    return(%message);
}


##########################################################
#
# Find the browser type
#
sub Browser {
    local(%browser) = ();
    local($platform,$type,$version);

    $_ = $ENV{'HTTP_USER_AGENT'};

    # get the platform
    if (/win(dows)?\s*(32|95|nt)/i) {
        $platform = 'win32';
    } elsif (/win/i) {
        $platform = 'win';
    } elsif (/mac/i) {
        $platform = 'mac';
    } else {
        $platform = 'other';
    }

    # get the browser type and version
    # First, check explicitly for MSIE
    if (/MSIE/) {
        $type = 'MSIE';
        ($version) = /MSIE\s+(.+?);/;
    } else {
        ($type,$version) = /^(.*?)\/\s*(.+?)\s/;
    }

    # put it into the assoc array
    %browser = ( 'platform' => $platform,
                 'type'     => $type,
                 'version'  => $version );

    return(%browser);
}


##########################################################
#
# Find the browser type
#
sub GetHash {
    local($text,$secret) = @_;
    local($signThis) = "${secret}${text}${secret}";

    if ($OS eq 'NT') {
        # can't use command line to pass text on NT, so
        # write the message to a temporary file
        local($tempfile) = "hash$$";
        $tempfile =~ tr/A-Za-z0-9_//cd;
        $tempfile = "$tmpdir/$tempfile.tmp";
        open(TEMP,">$tempfile");
        binmode TEMP;
        print TEMP $signThis;
        close(TEMP);

        # get the base64-encoded MD5 hash
        open(HASH,"$computehash -f $tempfile|");

    } else {
        # get the base64-encoded MD5 hash
        open(HASH,"$computehash '$signThis'|");
    }

    $hash = <HASH>;
    chomp($hash);
    close(HASH);

    # strip leading and trailing whitespace
    $hash =~ s/^\s*|\s*$//g;

    return($hash);

    if ($OS eq 'NT') {
        # clean up the temporary file
        unlink "$tempfile";
    }
}


##########################################################
#
# Routines for manipulating time formats
#

# return the current date + an offset in YYYYMMDDhhmmss.sss UTC
sub Now {
    my($offset) = @_;
    my($ss,$mm,$hh,$DD,$MM,$YYYY,$wday,$yday,$isdst) =
        gmtime(time + $offset);
    $MM++;
    $YYYY += 1900 if ($year < 100);

    my($now) = sprintf('%4d%02d%02d%02d%02d%02d.000',$YYYY,$MM,$DD,$hh,$mm,$ss);
    return($now);
}


# Convert YYYYMMDDhhmmss.sss to seconds
sub Seconds {
    my($machine) = @_;
    my($year,$yr,$month,$date,$hour,$minute,$second,$frac) =
        $machine =~ /A?(\d\d(\d\d))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d).*(\d\d\d)*/i;

    my($seconds) = timegm($second,$minute,$hour,$date,($month-1),($year-1900)) + $frac/1000;

    return $seconds;
}


# Convert seconds to human-readable time
sub GMT {
    my($seconds) = @_;
    my($ss,$mm,$hh,$DD,$MM,$YYYY,$wday,$yday,$isdst) =
        gmtime($seconds);
    my($nss,$nmm,$nhh,$nDD,$nMM,$nYYYY,$nwday,$nyday,$nisdst) =
        gmtime(time);
    $MM++;

    my($human) = sprintf('%d/%d/%d at %d:%02d:%02d GMT',$MM,$DD,$YYYY,$hh,$mm,$ss);

    if ($yday == $nyday) {
        $human = sprintf('%d:%02d:%02d GMT',$hh,$mm,$ss);
    } elsif ( ($yday-$nyday) == 1) {
        $human = sprintf('tommorrow at %d:%02d:%02d GMT',$hh,$mm,$ss);
    }

    return $human;
}


# convert seconds to a more human-readable string
sub HumanSeconds {
    use integer;

    my($seconds) = @_;
    my(@parts) = ();

    my($weeks) = $seconds / (7 * 24 * 60 * 60);
    $seconds %= (7 * 24 * 60 * 60);
    my($days) = $seconds / (24 * 60 * 60);
    $seconds %= (24 * 60 * 60);
    my($hours) = $seconds / (60 * 60);
    $seconds %= (60 * 60);
    my($minutes) = $seconds / 60;
    $seconds %= 60;

    if ($weeks) {
        if ($weeks == 1) {
            push(@parts,'1 week');
        } else {
            push(@parts,"$weeks weeks");
        }
    }
    if ($days) {
        if ($days == 1) {
            push(@parts,'1 day');
        } else {
            push(@parts,"$days days");
        }
    }
    if ($hours) {
        if ($hours == 1) {
            push(@parts,'1 hour');
        } else {
            push(@parts,"$hours hours");
        }
    }
    if ($minutes) {
        if ($minutes == 1) {
            push(@parts,'1 minute');
        } else {
            push(@parts,"$minutes minutes");
        }
    }
    if ($seconds) {
        if ($seconds == 1) {
            push(@parts,'1 second');
        } else {
            push(@parts,"$seconds seconds");
        }
    }

    my($lastpart) = pop(@parts);
    my($human) = '';
    if (@parts) {
        if (@parts == 1) {
            $human = "$parts[0] and ";
        } else {
            $human = join(', ',@parts) . ', and ';
        }
    }
    $human .= $lastpart;

    return $human;
}


##########################################################
#
# Error reporting routines
#
sub SocketFailed {
    $result{'MStatus'} = 'failure-hard';
    $result{'MErrLoc'} = 'CCLib';
    $result{'MErrMsg'} = 'Could not open socket to connect to Merchant Payment Server.';
}

sub ConnectFailed {
    $result{'MStatus'} = 'failure-hard';
    $result{'MErrLoc'} = 'CCLib';
    $result{'MErrMsg'} = <<'END';
Could not connect socket to the Merchant Payment Server.
It may not be running or your configuration may be incorrect.
END
}

sub SyswriteFailed {
    $result{'MStatus'} = 'failure-hard';
    $result{'MErrLoc'} = 'CCLib';
    $result{'MErrMsg'} = 'Could not write to the socket.';
}

sub GoAway {
    $result{'MStatus'} = 'failure-hard';
    $result{'MErrLoc'} = 'MPMT';
    $result{'MErrMsg'} = 'Misconfigured server/CGI-script secret.';
}


1;