OnlinePayment/HTTPS.pm

   1 package Business::OnlinePayment::HTTPS;
   2
   3 use strict;
   4 use vars qw($VERSION $DEBUG $ssl_module $skip_NetSSLeay);
   5 use URI::Escape;
   6 use Tie::IxHash;
   7 use base qw(Business::OnlinePayment);
   8
   9 $VERSION = '0.09';
  10 $DEBUG   = 0;
  11
  12 BEGIN {
  13
  14     $ssl_module = '';
  15
  16     eval {
  17         die if defined($skip_NetSSLeay) && $skip_NetSSLeay;
  18         require Net::SSLeay;
  19         Net::SSLeay->VERSION(1.30);
  20
  21         #import Net::SSLeay
  22         #  qw(get_https post_https make_form make_headers);
  23         $ssl_module = 'Net::SSLeay';
  24     };
  25
  26     if ($@) {
  27         eval {
  28             require LWP::UserAgent;
  29             require HTTP::Request::Common;
  30             require Crypt::SSLeay;
  31
  32             #import HTTP::Request::Common qw(GET POST);
  33             $ssl_module = 'Crypt::SSLeay';
  34         };
  35     }
  36
  37     unless ($ssl_module) {
  38         die "One of Net::SSLeay (v1.30 or later)"
  39           . " 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   use base 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( \%hash );
  66
  67       #...
  68   }
  69
  70 =head1 DESCRIPTION
  71
  72 This is a base class for HTTPS based gateways, providing useful code
  73 for 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 [ \%options ] HASHREF | FIELD => VALUE, ...
  82
  83 Accepts parameters as either a hashref or a list of fields and values.
  84 In the latter case, ordering is preserved (see L<Tie::IxHash> to do so
  85 when passing a hashref).
  86
  87 Returns a list consisting of the page content as a string, the HTTP
  88 response code and message (i.e. "200 OK" or "404 Not Found"), and a list of
  89 key/value pairs representing the HTTP response headers.
  90
  91 The options hashref supports setting headers and Content-Type:
  92
  93   {
  94       headers => { 'X-Header1' => 'value', ... },
  95       Content-Type => 'text/namevalue',
  96   }
  97
  98 =cut
  99
 100 sub https_get {
 101     my $self = shift;
 102
 103     # handle optional options hashref
 104     my $opts;
 105     if ( scalar(@_) > 1 and ref( $_[0] ) eq "HASH" ) {
 106         $opts = shift;
 107     }
 108
 109     # accept a hashref or a list (keep it ordered)
 110     my $post_data;
 111     if ( ref( $_[0] ) eq 'HASH' ) {
 112         $post_data = shift;
 113     }
 114     elsif ( scalar(@_) > 1 ) {
 115         tie my %hash, 'Tie::IxHash', @_;
 116         $post_data = \%hash;
 117     }
 118     elsif ( scalar(@_) == 1 ) {
 119         $post_data = shift;
 120     }
 121     else {
 122         die "https_get called with no params\n";
 123     }
 124
 125     $opts->{"Content-Type"} ||= "application/x-www-form-urlencoded";
 126
 127     ### XXX referer!!!
 128     my %headers;
 129     if ( ref( $opts->{headers} ) eq "HASH" ) {
 130         %headers = %{ $opts->{headers} };
 131     }
 132     $headers{'Host'} ||= $self->server;
 133
 134     my $path = $self->path;
 135     if ( keys %$post_data ) {
 136         $path .= '?'
 137           . join( '&',
 138             map { uri_escape($_) . '=' . uri_escape( $post_data->{$_} ) }
 139               keys %$post_data );
 140     }
 141
 142     $self->build_subs(qw( response_page response_code response_headers ));
 143
 144     if ( $ssl_module eq 'Net::SSLeay' ) {
 145
 146         import Net::SSLeay qw(get_https make_headers);
 147         my $headers = make_headers(%headers);
 148
 149         my( $res_page, $res_code, @res_headers ) =
 150           get_https( $self->server,
 151                      $self->port,
 152                      $path,
 153                      $headers,
 154                      "",
 155                      $opts->{"Content-Type"},
 156                    );
 157
 158         $res_code =~ /^(HTTP\S+ )?(.*)/ and $res_code = $2;
 159
 160         $self->response_page( $res_page );
 161         $self->response_code( $res_code );
 162         $self->response_headers( { @res_headers } );
 163
 164         ( $res_page, $res_code, @res_headers );
 165
 166     } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 167
 168         import HTTP::Request::Common qw(GET);
 169
 170         my $url = 'https://' . $self->server;
 171         $url .= ':' . $self->port
 172           unless $self->port == 443;
 173         $url .= "/$path";
 174
 175         my $ua = new LWP::UserAgent;
 176         foreach my $hdr ( keys %headers ) {
 177             $ua->default_header( $hdr => $headers{$hdr} );
 178         }
 179         my $res = $ua->request( GET($url) );
 180
 181         my @res_headers = map { $_ => $res->header($_) }
 182                               $res->header_field_names;
 183
 184         $self->response_page( $res->content );
 185         $self->response_code( $res->code. ' '. $res->message );
 186         $self->response_headers( { @res_headers } );
 187
 188         ( $res->content, $res->code. ' '. $res->message, @res_headers );
 189
 190     } else {
 191         die "unknown SSL module $ssl_module";
 192     }
 193
 194 }
 195
 196 =item https_post [ \%options ] SCALAR | HASHREF | FIELD => VALUE, ...
 197
 198 Accepts form fields and values as either a hashref or a list.  In the
 199 latter case, ordering is preserved (see L<Tie::IxHash> to do so when
 200 passing a hashref).
 201
 202 Also accepts instead a simple scalar containing the raw content.
 203
 204 Returns a list consisting of the page content as a string, the HTTP
 205 response code and message (i.e. "200 OK" or "404 Not Found"), and a list of
 206 key/value pairs representing the HTTP response headers.
 207
 208 The options hashref supports setting headers and Content-Type:
 209
 210   {
 211       headers => { 'X-Header1' => 'value', ... },
 212       Content-Type => 'text/namevalue',
 213   }
 214
 215 =cut
 216
 217 sub https_post {
 218     my $self = shift;
 219
 220     # handle optional options hashref
 221     my $opts;
 222     if ( scalar(@_) > 1 and ref( $_[0] ) eq "HASH" ) {
 223         $opts = shift;
 224     }
 225
 226     # accept a hashref or a list (keep it ordered)
 227     my $post_data;
 228     if ( ref( $_[0] ) eq 'HASH' ) {
 229         $post_data = shift;
 230     }
 231     elsif ( scalar(@_) > 1 ) {
 232         tie my %hash, 'Tie::IxHash', @_;
 233         $post_data = \%hash;
 234     }
 235     elsif ( scalar(@_) == 1 ) {
 236         $post_data = shift;
 237     }
 238     else {
 239         die "https_post called with no params\n";
 240     }
 241
 242     $opts->{"Content-Type"} ||= "application/x-www-form-urlencoded";
 243
 244     ### XXX referer!!!
 245     my %headers;
 246     if ( ref( $opts->{headers} ) eq "HASH" ) {
 247         %headers = %{ $opts->{headers} };
 248     }
 249     $headers{'Host'} ||= $self->server;
 250
 251     if ( $DEBUG && ref($post_data) ) {
 252         warn "post data:\n",
 253           join( '',
 254             map { "  $_ => " . $post_data->{$_} . "\n" } keys %$post_data );
 255     }
 256
 257     $self->build_subs(qw( response_page response_code response_headers ));
 258
 259     if ( $ssl_module eq 'Net::SSLeay' ) {
 260
 261         import Net::SSLeay qw(post_https make_headers make_form);
 262         my $headers = make_headers(%headers);
 263
 264         if ($DEBUG) {
 265             no warnings 'uninitialized';
 266             warn $self->server . ':' . $self->port . $self->path . "\n";
 267             $Net::SSLeay::trace = $DEBUG;
 268         }
 269
 270         my $raw_data = ref($post_data) ? make_form(%$post_data) : $post_data;
 271
 272         my( $res_page, $res_code, @res_headers ) =
 273           post_https( $self->server,
 274                       $self->port,
 275                       $self->path,
 276                       $headers,
 277                       $raw_data,
 278                       $opts->{"Content-Type"},
 279                     );
 280
 281         $res_code =~ /^(HTTP\S+ )?(.*)/ and $res_code = $2;
 282
 283         $self->response_page( $res_page );
 284         $self->response_code( $res_code );
 285         $self->response_headers( { @res_headers } );
 286
 287         ( $res_page, $res_code, @res_headers );
 288
 289     } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 290
 291         import HTTP::Request::Common qw(POST);
 292
 293         my $url = 'https://' . $self->server;
 294         $url .= ':' . $self->port
 295           unless $self->port == 443;
 296         $url .= $self->path;
 297
 298         if ($DEBUG) {
 299             warn $url;
 300         }
 301
 302         my $ua = new LWP::UserAgent;
 303         foreach my $hdr ( keys %headers ) {
 304             $ua->default_header( $hdr => $headers{$hdr} );
 305         }
 306
 307         my $res;
 308         if ( ref($post_data) ) {
 309             $res = $ua->request( POST( $url, [%$post_data] ) );
 310         }
 311         else {
 312             my $req = new HTTP::Request( 'POST' => $url );
 313             $req->content_type( $opts->{"Content-Type"} );
 314             $req->content($post_data);
 315             $res = $ua->request($req);
 316         }
 317
 318         my @res_headers = map { $_ => $res->header($_) }
 319                               $res->header_field_names;
 320
 321         $self->response_page( $res->content );
 322         $self->response_code( $res->code. ' '. $res->message );
 323         $self->response_headers( { @res_headers } );
 324
 325         ( $res->content, $res->code. ' '. $res->message, @res_headers );
 326
 327     } else {
 328         die "unknown SSL module $ssl_module";
 329     }
 330
 331 }
 332
 333 =back
 334
 335 =head1 SEE ALSO
 336
 337 L<Business::OnlinePayment>
 338
 339 =cut
 340
 341 1;