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.07';
  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 a list of key/value pairs representing the HTTP
  89 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         $self->response_page( $res_page );
 159         $self->response_code( $res_code );
 160         $self->response_headers( { @res_headers } );
 161
 162         ( $res_page, $res_code, @res_headers );
 163
 164     } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 165
 166         import HTTP::Request::Common qw(GET);
 167
 168         my $url = 'https://' . $self->server;
 169         $url .= ':' . $self->port
 170           unless $self->port == 443;
 171         $url .= "/$path";
 172
 173         my $ua = new LWP::UserAgent;
 174         foreach my $hdr ( keys %headers ) {
 175             $ua->default_header( $hdr => $headers{$hdr} );
 176         }
 177         my $res = $ua->request( GET($url) );
 178
 179         my @res_headers = map { $_ => $res->header($_) }
 180                               $res->header_field_names;
 181
 182         $self->response_page( $res->content );
 183         $self->response_code( $res->code );
 184         $self->response_headers( { @res_headers } );
 185
 186         ( $res->content, $res->code, @res_headers );
 187
 188     } else {
 189         die "unknown SSL module $ssl_module";
 190     }
 191
 192 }
 193
 194 =item https_post [ \%options ] SCALAR | HASHREF | FIELD => VALUE, ...
 195
 196 Accepts form fields and values as either a hashref or a list.  In the
 197 latter case, ordering is preserved (see L<Tie::IxHash> to do so when
 198 passing a hashref).
 199
 200 Also accepts instead a simple scalar containing the raw content.
 201
 202 Returns a list consisting of the page content as a string, the HTTP
 203 response code, and a list of key/value pairs representing the HTTP
 204 response headers.
 205
 206 The options hashref supports setting headers and Content-Type:
 207
 208   {
 209       headers => { 'X-Header1' => 'value', ... },
 210       Content-Type => 'text/namevalue',
 211   }
 212
 213 =cut
 214
 215 sub https_post {
 216     my $self = shift;
 217
 218     # handle optional options hashref
 219     my $opts;
 220     if ( scalar(@_) > 1 and ref( $_[0] ) eq "HASH" ) {
 221         $opts = shift;
 222     }
 223
 224     # accept a hashref or a list (keep it ordered)
 225     my $post_data;
 226     if ( ref( $_[0] ) eq 'HASH' ) {
 227         $post_data = shift;
 228     }
 229     elsif ( scalar(@_) > 1 ) {
 230         tie my %hash, 'Tie::IxHash', @_;
 231         $post_data = \%hash;
 232     }
 233     elsif ( scalar(@_) == 1 ) {
 234         $post_data = shift;
 235     }
 236     else {
 237         die "https_post called with no params\n";
 238     }
 239
 240     $opts->{"Content-Type"} ||= "application/x-www-form-urlencoded";
 241
 242     ### XXX referer!!!
 243     my %headers;
 244     if ( ref( $opts->{headers} ) eq "HASH" ) {
 245         %headers = %{ $opts->{headers} };
 246     }
 247     $headers{'Host'} ||= $self->server;
 248
 249     if ( $DEBUG && ref($post_data) ) {
 250         warn "post data:\n",
 251           join( '',
 252             map { "  $_ => " . $post_data->{$_} . "\n" } keys %$post_data );
 253     }
 254
 255     $self->build_subs(qw( response_page response_code response_headers ));
 256
 257     if ( $ssl_module eq 'Net::SSLeay' ) {
 258
 259         import Net::SSLeay qw(post_https make_headers make_form);
 260         my $headers = make_headers(%headers);
 261
 262         if ($DEBUG) {
 263             no warnings 'uninitialized';
 264             warn $self->server . ':' . $self->port . $self->path . "\n";
 265             $Net::SSLeay::trace = $DEBUG;
 266         }
 267
 268         my $raw_data = ref($post_data) ? make_form(%$post_data) : $post_data;
 269
 270         my( $res_page, $res_code, @res_headers ) =
 271           post_https( $self->server,
 272                       $self->port,
 273                       $self->path,
 274                       $headers,
 275                       $raw_data,
 276                       $opts->{"Content-Type"},
 277                     );
 278
 279         $self->response_page( $res_page );
 280         $self->response_code( $res_code );
 281         $self->response_headers( { @res_headers } );
 282
 283         ( $res_page, $res_code, @res_headers );
 284
 285     } elsif ( $ssl_module eq 'Crypt::SSLeay' ) {
 286
 287         import HTTP::Request::Common qw(POST);
 288
 289         my $url = 'https://' . $self->server;
 290         $url .= ':' . $self->port
 291           unless $self->port == 443;
 292         $url .= $self->path;
 293
 294         if ($DEBUG) {
 295             warn $url;
 296         }
 297
 298         my $ua = new LWP::UserAgent;
 299         foreach my $hdr ( keys %headers ) {
 300             $ua->default_header( $hdr => $headers{$hdr} );
 301         }
 302
 303         my $res;
 304         if ( ref($post_data) ) {
 305             $res = $ua->request( POST( $url, [%$post_data] ) );
 306         }
 307         else {
 308             my $req = new HTTP::Request( 'POST' => $url );
 309             $req->content_type( $opts->{"Content-Type"} );
 310             $req->content($post_data);
 311             $res = $ua->request($req);
 312         }
 313
 314         my @res_headers = map { $_ => $res->header($_) }
 315                               $res->header_field_names;
 316
 317         $self->response_page( $res->content );
 318         $self->response_code( $res->code );
 319         $self->response_headers( { @res_headers } );
 320
 321         ( $res->content, $res->code, @res_headers );
 322
 323     } else {
 324         die "unknown SSL module $ssl_module";
 325     }
 326
 327 }
 328
 329 =back
 330
 331 =head1 SEE ALSO
 332
 333 L<Business::OnlinePayment>
 334
 335 =cut
 336
 337 1;