FS/FS/part_export/http.pm

   1 package FS::part_export::http;
   2
   3 use base qw( FS::part_export );
   4 use vars qw( %options %info );
   5 use Tie::IxHash;
   6 use LWP::UserAgent;
   7 use HTTP::Request::Common qw( POST );
   8 use IO::Socket::SSL;
   9
  10 tie %options, 'Tie::IxHash',
  11   'method' => { label   =>'Method',
  12                 type    =>'select',
  13                 #options =>[qw(POST GET)],
  14                 options =>[qw(POST)],
  15                 default =>'POST' },
  16   'url'    => { label   => 'URL', default => 'http://', },
  17   'ssl_no_verify' => { label => 'Skip SSL certificate validation',
  18                        type  => 'checkbox',
  19                      },
  20   'insert_data' => {
  21     label   => 'Insert data',
  22     type    => 'textarea',
  23     default => join("\n",
  24       'DomainName $svc_x->domain',
  25       'Email ( grep { $_ !~ /^(POST|FAX)$/ } $svc_x->cust_svc->cust_pkg->cust_main->invoicing_list)[0]',
  26       'test 1',
  27       'reseller $svc_x->cust_svc->cust_pkg->part_pkg->pkg =~ /reseller/i',
  28     ),
  29   },
  30   'delete_data' => {
  31     label   => 'Delete data',
  32     type    => 'textarea',
  33     default => join("\n",
  34     ),
  35   },
  36   'replace_data' => {
  37     label   => 'Replace data',
  38     type    => 'textarea',
  39     default => join("\n",
  40     ),
  41   },
  42   'suspend_data' => {
  43     label   => 'Suspend data',
  44     type    => 'textarea',
  45     default => join("\n",
  46     ),
  47   },
  48   'unsuspend_data' => {
  49     label   => 'Unsuspend data',
  50     type    => 'textarea',
  51     default => join("\n",
  52     ),
  53   },
  54   'success_regexp' => {
  55     label  => 'Success Regexp',
  56     default => '',
  57   },
  58 ;
  59
  60 %info = (
  61   'svc'     => 'svc_domain',
  62   'desc'    => 'Send an HTTP or HTTPS GET or POST request, for domains1',
  63   'options' => \%options,
  64   'no_machine' => 1,
  65   'notes'   => <<'END'
  66 Send an HTTP or HTTPS GET or POST to the specified URL on domain addition,
  67 modification and deletion.
  68 <p>Each "Data" option takes a list of <i>name value</i> pairs on successive
  69 lines.
  70 <ul><li><i>name</i> is an unquoted, literal string without whitespace.</li>
  71 <li><i>value</i> is a Perl expression that will be evaluated.  If it's a
  72 literal string, it must be quoted.  This expression has access to the
  73 svc_domain object as '$svc_x' (or '$new' and '$old' in "Replace Data")
  74 and the customer record as '$cust_main'.</li></ul>
  75 If "Success Regexp" is specified, the response from the server will be
  76 tested against it to determine if the export succeeded.</p>
  77 END
  78 );
  79
  80 sub rebless { shift; }
  81
  82 sub _export_insert {
  83   my $self = shift;
  84   $self->_export_command('insert', @_);
  85 }
  86
  87 sub _export_delete {
  88   my $self = shift;
  89   $self->_export_command('delete', @_);
  90 }
  91
  92 sub _export_suspend {
  93   my $self = shift;
  94   $self->_export_command('suspend', @_);
  95 }
  96
  97 sub _export_unsuspend {
  98   my $self = shift;
  99   $self->_export_command('unsuspend', @_);
 100 }
 101
 102 sub _export_command {
 103   my( $self, $action, $svc_x ) = ( shift, shift, shift );
 104
 105   return unless $self->option("${action}_data");
 106
 107   my $cust_main = $svc_x->cust_main or return;
 108
 109   $self->http_queue( $svc_x->svcnum,
 110     ( $self->option('ssl_no_verify') ? 'ssl_no_verify' : '' ),
 111     $self->option('method'),
 112     $self->option('url'),
 113     $self->option('success_regexp'),
 114     map {
 115       /^\s*(\S+)\s+(.*)$/ or /()()/;
 116       my( $field, $value_expression ) = ( $1, $2 );
 117       my $value = eval $value_expression;
 118       die $@ if $@;
 119       ( $field, $value );
 120     } split(/\n/, $self->option("${action}_data") )
 121   );
 122
 123 }
 124
 125 sub _export_replace {
 126   my( $self, $new, $old ) = ( shift, shift, shift );
 127
 128   return unless $self->option('replace_data');
 129
 130   my $new_cust_main = $new->cust_main or return;
 131   my $cust_main = $new_cust_main; #so folks can use $new_cust_main or $cust_main
 132
 133   $self->http_queue( $new->svcnum,
 134     ( $self->option('ssl_no_verify') ? 'ssl_no_verify' : '' ),
 135     $self->option('method'),
 136     $self->option('url'),
 137     $self->option('success_regexp'),
 138     map {
 139       /^\s*(\S+)\s+(.*)$/ or /()()/;
 140       my( $field, $value_expression ) = ( $1, $2 );
 141       my $value = eval $value_expression;
 142       die $@ if $@;
 143       ( $field, $value );
 144     } split(/\n/, $self->option('replace_data') )
 145   );
 146
 147 }
 148
 149 sub http_queue {
 150   my($self, $svcnum) = (shift, shift);
 151   my $queue = new FS::queue { 'job' => "FS::part_export::http::http" };
 152   $queue->svcnum($svcnum) if $svcnum;
 153   $queue->insert( @_ );
 154 }
 155
 156 sub http {
 157   my $ssl_no_verify = ( $_[0] eq 'ssl_no_verify' || $_[0] eq '' ) ? shift : '';
 158   my($method, $url, $success_regexp, @data) = @_;
 159
 160   $method = lc($method);
 161
 162   my @lwp_opts = ();
 163   push @lwp_opts, 'ssl_opts' => {
 164                     verify_hostname => 0,
 165                     SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
 166                   }
 167     if $ssl_no_verify;
 168   my $ua = LWP::UserAgent->new(@lwp_opts);
 169
 170   #my $response = $ua->$method(
 171   #  $url, \%data,
 172   #  'Content-Type'=>'application/x-www-form-urlencoded'
 173   #);
 174   my $req = HTTP::Request::Common::POST( $url, \@data );
 175   my $response = $ua->request($req);
 176
 177   die $response->error_as_HTML if $response->is_error;
 178
 179   if(length($success_regexp) > 1) {
 180     my $response_content = $response->content;
 181     die $response_content unless $response_content =~ /$success_regexp/;
 182   }
 183
 184 }
 185
 186 1;
 187