OnlinePayment/HTTPS.pm

   1 package Business::OnlinePayment::HTTPS;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA $DEBUG $ssl_module $skip_NetSSLeay);
   5 #use URI;
   6 #use URI::QueryParam;
   7 use URI::Escape;
   8 use Tie::IxHash;
   9
  10 @ISA = qw( Business::OnlinePayment );
  11
  12 $VERSION = '0.03';
  13
  14 $DEBUG = 0;
  15
  16 BEGIN {
  17
  18         $ssl_module = '';
  19
  20         eval {
  21                 die if defined($skip_NetSSLeay) && $skip_NetSSLeay;
  22                 require Net::SSLeay;
  23                 #import Net::SSLeay
  24                 #  qw(get_https post_https make_form make_headers);
  25                 $ssl_module = 'Net::SSLeay';
  26         };
  27
  28         if ($@) {
  29                 eval {
  30                         require LWP::UserAgent;
  31                         require HTTP::Request::Common;
  32                         require Crypt::SSLeay;
  33                         #import HTTP::Request::Common qw(GET POST);
  34                         $ssl_module = 'Crypt::SSLeay';
  35                 };
  36         }
  37
  38         unless ( $ssl_module ) {
  39                 die "Net::SSLeay or Crypt::SSLeay (+LWP) is required";
  40         }
  41
  42 }
  43
  44 =head1 NAME
  45
  46 Business::OnlinePayment::HTTPS - Base class for HTTPS payment APIs
  47
  48 =head1 SYNOPSIS
  49
  50   package Business::OnlinePayment::MyProcessor
  51   @ISA = qw( Business::OnlinePayment::HTTPS );
  52
  53   sub submit {
  54           my $self = shift;
  55
  56           #...
  57
  58           # pass a list (order is preserved, if your gateway needs that)
  59           ($page, $response, %reply_headers)
  60             = $self->https_get( field => 'value', ... );
  61
  62           #or a hashref
  63           my %hash = ( field => 'value', ... );
  64           ($page, $response_code, %reply_headers)
  65             = $self->https_get( $hashref );
  66
  67           #...
  68   }
  69
  70 =head1 DESCRIPTION
  71
  72 This is a base class for HTTPS based gateways, providing useful code for
  73 implementors of HTTPS payment APIs.
  74
  75 It depends on Net::SSLeay _or_ ( Crypt::SSLeay and LWP::UserAgent ).
  76
  77 =head1 METHODS
  78
  79 =over 4
  80
  81 =item https_get HASHREF | FIELD => VALUE, ...
  82
  83 Accepts parameters as either a hashref or a list of fields and values.  In the
  84 latter case, ordering is preserved (see L<Tie::IxHash> to do so when passing a
  85 hashref).
  86
  87 Returns a list consisting of the page content as a string, the HTTP response
  88 code, and a list of key/value pairs representing the HTTP response headers.
  89
  90 =cut
  91
  92 sub https_get {
  93   my $self = shift;
  94
  95   #accept a hashref or a list (keep it ordered)
  96   my $post_data;
  97   if ( ref($_[0]) ) {
  98     $post_data = shift;
  99   } else {
 100     tie my %hash, 'Tie::IxHash', @_;
 101     $post_data = \%hash;
 102   }
 103
 104   my $path = $self->path;
 105   if ( keys %$post_data ) {
 106
 107     #my $u = URI->new("", "https");
 108     #$u->query_param(%$post_data);
 109     #$path .= '?'. $u->query;
 110
 111     $path .= '?'. join('&',
 112       map { uri_escape($_).'='. uri_escape($post_data->{$_}) }
 113       keys %$post_data
 114     );
 115     #warn $path;
 116
 117   }
 118
 119   my $referer = ''; ### XXX referer!!!
 120   my %headers;
 121   $headers{'Referer'} = $referer if length($referer);
 122
 123   if ( $ssl_module eq 'Net::SSLeay' ) {
 124
 125     import Net::SSLeay qw(get_https make_headers);
 126     my $headers = make_headers(%headers);
 127     get_https( $self->server, $self->port, $path, $referer, $headers );
 128
 129   } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 130
 131     import HTTP::Request::Common qw(GET);
 132
 133     my $url = 'https://'. $self->server;
 134     $url .= ':'. $self->port
 135       unless $self->port == 443;
 136     $url .= "/$path";
 137
 138     my $ua = new LWP::UserAgent;
 139     my $res = $ua->request( GET( $url ) );
 140
 141     #( $res->as_string, # wtf?
 142     ( $res->content,
 143       $res->code,
 144       map { $_ => $res->header($_) } $res->header_field_names
 145     );
 146
 147   } else {
 148
 149     die "unknown SSL module $ssl_module";
 150
 151   }
 152
 153 }
 154
 155 =item https_post SCALAR | HASHREF | FIELD => VALUE, ...
 156
 157 Accepts form fields and values as either a hashref or a list.  In the latter
 158 case, ordering is preserved (see L<Tie::IxHash> to do so when passing a
 159 hashref).
 160
 161 Also accepts instead a simple scalar containing the raw content.
 162
 163 Returns a list consisting of the page content as a string, the HTTP response
 164 code, and a list of key/value pairs representing the HTTP response headers.
 165
 166 =cut
 167
 168 sub https_post {
 169   my $self = shift;
 170
 171   #accept a hashref or a list (keep it ordered)
 172   my $post_data;
 173   if ( ref($_[0]) eq 'HASH' ) {
 174     $post_data = shift;
 175   } elsif ( scalar(@_) > 1 ) {
 176     tie my %hash, 'Tie::IxHash', @_;
 177     $post_data = \%hash;
 178   } elsif ( scalar(@_) == 1 ) {
 179     $post_data = shift;
 180   } else {
 181     die "https_post called with no params\n";
 182   }
 183
 184   my $referer = ''; ### XXX referer!!!
 185   my %headers;
 186   $headers{'Referer'} = $referer if length($referer);
 187   $headers{'Host'} = $self->server;
 188
 189   if ( $DEBUG && ref($post_data) ) {
 190     warn join('', map { "  $_ => ". $post_data->{$_}. "\n" } keys %$post_data );
 191   }
 192
 193   if ( $ssl_module eq 'Net::SSLeay' ) {
 194
 195     #import Net::SSLeay qw(post_https make_headers make_form);
 196     import Net::SSLeay qw(make_headers make_form);
 197     my $headers = make_headers(%headers);
 198
 199     if ( $DEBUG ) {
 200       warn $self->server. ':'. $self->port. $self->path. "\n";
 201       $Net::SSLeay::trace = 2;
 202     }
 203     #post_https( $self->server, $self->port, $self->path,
 204     #            $headers, make_form(%$post_data)  );
 205
 206     my $raw_data = ref($post_data) ? make_form(%$post_data) : $post_data;
 207     _my_post_https( $self->server, $self->port, $self->path,
 208                     $headers, $raw_data );
 209
 210   } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 211
 212     import HTTP::Request::Common qw(POST);
 213
 214     my $url = 'https://'. $self->server;
 215     $url .= ':'. $self->port
 216       unless $self->port == 443;
 217     $url .= $self->path;
 218
 219     if ( $DEBUG ) {
 220       warn $url;
 221     }
 222
 223     my $ua = new LWP::UserAgent;
 224
 225     my $res;
 226     if ( ref($post_data) ) {
 227       $res = $ua->request( POST( $url, [ %$post_data ] ) );
 228     } else {
 229       my $req =new HTTP::Request( 'POST' => $url );
 230       $req->content_type('application/x-www-form-urlencoded');
 231       $req->content($post_data);
 232       $res = $ua->request($req);
 233     }
 234
 235     #( $res->as_string, # wtf?
 236     ( $res->content,
 237       $res->code,
 238       map { $_ => $res->header($_) } $res->header_field_names
 239     );
 240
 241   } else {
 242
 243     die "unknown SSL module $ssl_module";
 244
 245   }
 246
 247 }
 248
 249 # SecureHostingUPG (and presumably other IIS-based gateways?) doesn't like the
 250 # Host: $site:$port header auto-added by Net::SSLeay, which it adds regardless
 251 # if you supply one or not
 252
 253 sub _my_post_https ($$$;***) { _my_do_httpx2(POST => 1, @_) }
 254
 255 sub _my_do_httpx2 {
 256     my ($page, $response, $headers, $server_cert) = &_my_do_httpx3;
 257     Net::SSLeay::X509_free($server_cert) if defined $server_cert;
 258     my($h,$v);
 259     return ($page, $response,
 260             map( { ($h,$v)=/^(\S+)\:\s*(.*)$/; (uc($h),$v); }
 261                 split(/\s?\n/, $headers)
 262                 )
 263             );
 264 }
 265
 266 sub _my_do_httpx3 {
 267     my ($method, $usessl, $site, $port, $path, $headers,
 268         $content, $mime_type, $crt_path, $key_path) = @_;
 269     my ($response, $page, $h,$v);
 270
 271     my $CRLF = $Net::SSLeay::CRLF;
 272
 273     if ($content) {
 274         $mime_type = "application/x-www-form-urlencoded" unless $mime_type;
 275         my $len = Net::SSLeay::blength($content);
 276         $content = "Content-Type: $mime_type$CRLF"
 277             . "Content-Length: $len$CRLF$CRLF$content";
 278     } else {
 279         $content = "$CRLF$CRLF";
 280     }
 281
 282     my $req = "$method $path HTTP/1.0$CRLF";
 283     unless ( defined $headers && $headers =~ /^Host:/m ) {
 284       $req .= "Host: $site";
 285       unless ( ( $port==80 && !$usessl ) || ( $port==443 && $usessl ) ) {
 286         $req .= ":$port";
 287       }
 288       $req .= $CRLF;
 289     }
 290     $req .= (defined $headers ? $headers : '') . "Accept: */*$CRLF$content";
 291
 292     warn "do_httpx3($method,$usessl,$site:$port)" if $Net::SSLeay::trace;
 293     my ($http, $errs, $server_cert)
 294         = Net::SSLeay::httpx_cat($usessl, $site, $port, $req, $crt_path, $key_path);
 295     return (undef, "HTTP/1.0 900 NET OR SSL ERROR$CRLF$CRLF$errs") if $errs;
 296
 297     $http = '' if !defined $http;
 298     ($headers, $page) = split /\s?\n\s?\n/, $http, 2;
 299     warn "headers >$headers< page >>$page<< http >>>$http<<<" if $Net::SSLeay::trace>1;
 300     ($response, $headers) = split /\s?\n/, $headers, 2;
 301     return ($page, $response, $headers, $server_cert);
 302 }
 303
 304 =back
 305
 306 =head1 SEE ALSO
 307
 308 L<Business::OnlinePayment>
 309
 310 =cut
 311
 312 1;
 313