FS/FS/part_export/http_status.pm

   1 package FS::part_export::http_status;
   2 use base qw( FS::part_export );
   3
   4 use strict;
   5 use warnings;
   6 use vars qw( %info $DEBUG );
   7 use URI::Escape;
   8 use LWP::UserAgent;
   9 use HTTP::Request::Common;
  10 use Email::Valid;
  11 use Carp qw(carp);
  12
  13 tie my %options, 'Tie::IxHash',
  14   'url' => { label => 'URL', },
  15   'blacklist_add_url' => { label => 'Optional blacklist add URL', },
  16   'blacklist_del_url' => { label => 'Optional blacklist delete URL', },
  17   'whitelist_add_url' => { label => 'Optional whitelist add URL', },
  18   'whitelist_del_url' => { label => 'Optional whitelist delete URL', },
  19   'vacation_add_url'  => { label => 'Optional vacation message add URL', },
  20   'vacation_del_url'  => { label => 'Optional vacation message delete URL', },
  21
  22   #'user'     => { label => 'Username', default=>'' },
  23   #'password' => { label => 'Password', default => '' },
  24 ;
  25
  26 %info = (
  27   'svc'     => [ 'svc_acct', 'svc_dsl', ],
  28   'desc'    => 'Retrieve status information via HTTP or HTTPS',
  29   'options' => \%options,
  30   'no_machine' => 1,
  31   'notes'   => <<'END'
  32 Fields from the service can be substituted in the URL as $field.
  33
  34 Optionally, spam black/whitelist addresees and a vacation message may be
  35 modified via HTTP or HTTPS as well.
  36 END
  37 );
  38
  39 $DEBUG = 1;
  40
  41 sub rebless { shift; }
  42
  43 our %addl_fields = (
  44   'svc_acct' => [qw( email ) ],
  45   'svc_dsl'  => [qw( gateway_access_or_phonenum ) ],
  46 );
  47
  48 #some NOPs for required subroutines, to avoid throwing the exceptions in the
  49 # part_export.pm fallbacks
  50 sub _export_insert  { '' };
  51 sub _export_replace { '' };
  52 sub _export_delete  { '' };
  53
  54 sub export_getstatus {
  55   my( $self, $svc_x, $htmlref, $hashref ) = @_;
  56
  57   if ( $FS::svc_Common::noexport_hack ) {
  58     carp 'export_getstatus() suppressed by noexport_hack'
  59       if $self->option('debug') || $DEBUG;
  60     return;
  61   }
  62
  63   my $url;
  64   my $urlopt = $self->option('url');
  65   no strict 'vars';
  66   {
  67     no strict 'refs';
  68     ${$_} = $svc_x->getfield($_) foreach $svc_x->fields;
  69     ${$_} = $svc_x->$_()         foreach @{ $addl_fields{ $svc_x->table } };
  70     $url = eval(qq("$urlopt"));
  71   }
  72
  73   my $req = HTTP::Request::Common::GET( $url );
  74   my $ua = LWP::UserAgent->new;
  75   my $response = $ua->request($req);
  76
  77   if ( $svc_x->table eq 'svc_dsl' ) {
  78
  79     $$htmlref = $response->is_error ? $response->error_as_HTML
  80                                     : $response->content;
  81
  82     #hash data not yet implemented for svc_dsl
  83
  84   } elsif ( $svc_x->table eq 'svc_acct' ) {
  85
  86     #this whole section is rather specific to fibernetics and should be an
  87     # option or callback or something
  88
  89     # to,from,wb_value
  90
  91     use Text::CSV_XS;
  92     my $csv = Text::CSV_XS->new;
  93
  94     my @lines = split("\n", $response->content);
  95     pop @lines if $lines[-1] eq '';
  96     my $header = shift @lines;
  97     $csv->parse($header) or return;
  98     my @header = $csv->fields;
  99
 100     while ( my $line = shift @lines ) {
 101       $csv->parse($line) or next;
 102       my @fields = $csv->fields;
 103       my %hash = map { $_ => shift(@fields) } @header;
 104
 105       if ( defined $hash{'wb_value'} ) {
 106         if ( $hash{'wb_value'} =~ /^[WA]/i ) { #Whitelist/Allow
 107           push @{ $hashref->{'whitelist'} }, $hash{'from'};
 108         } else { # if ( $hash{'wb_value'} =~ /^[BD]/i ) { #Blacklist/Deny
 109           push @{ $hashref->{'blacklist'} }, $hash{'from'};
 110         }
 111       }
 112
 113       for (qw( created enddate )) {
 114         $hash{$_} = '' if $hash{$_} =~ /^0000-/;
 115         $hash{$_} = (split(' ', $hash{$_}))[0];
 116       }
 117
 118       next unless $hash{'active'};
 119       $hashref->{"vacation_$_"} = $hash{$_} || ''
 120         foreach qw( active subject body created enddate );
 121
 122     }
 123
 124   } #else { die 'guru meditation #295'; }
 125
 126 }
 127
 128 sub export_setstatus_listadd {
 129   my( $self, $svc_x, $hr ) = @_;
 130   $self->export_setstatus_listX( $svc_x, 'add', $hr->{list}, $hr->{address} );
 131 }
 132
 133 sub export_setstatus_listdel {
 134   my( $self, $svc_x, $hr ) = @_;
 135   $self->export_setstatus_listX( $svc_x, 'del', $hr->{list}, $hr->{address} );
 136 }
 137
 138 sub export_setstatus_listX {
 139   my( $self, $svc_x, $action, $list, $address_item ) = @_;
 140
 141   if ( $FS::svc_Common::noexport_hack ) {
 142     carp 'export_setstatus_listX() suppressed by noexport_hack'
 143       if $self->option('debug') || $DEBUG;
 144     return;
 145   }
 146
 147   my $option;
 148   if ( $list =~ /^[WA]/i ) { #Whitelist/Allow
 149     $option = 'whitelist_';
 150   } else { # if ( $hash{'wb_value'} =~ /^[BD]/i ) { #Blacklist/Deny
 151     $option = 'blacklist_';
 152   }
 153   $option .= $action. '_url';
 154
 155   my $address;
 156   unless ( $address = Email::Valid->address($address_item) ) {
 157
 158     if ( $address_item =~ /^(\@[\w\-\.]+\.\w{2,63})$/ ) { # "@domain"
 159       $address = $1;
 160     } else {
 161       die "address failed $Email::Valid::Details check.\n";
 162     }
 163
 164   }
 165
 166   #some false laziness w/export_getstatus above
 167   my $url;
 168   my $urlopt = $self->option($option) or return; #DIFF
 169   no strict 'vars';
 170   {
 171     no strict 'refs';
 172     ${$_} = $svc_x->getfield($_) foreach $svc_x->fields;
 173     ${$_} = $svc_x->$_()         foreach @{ $addl_fields{ $svc_x->table } };
 174     $url = eval(qq("$urlopt"));
 175   }
 176
 177   my $req = HTTP::Request::Common::GET( $url );
 178   my $ua = LWP::UserAgent->new;
 179   my $response = $ua->request($req);
 180
 181   die $response->code. ' '. $response->message if $response->is_error;
 182
 183 }
 184
 185 sub export_setstatus_vacationadd {
 186   my( $self, $svc_x, $hr ) = @_;
 187   $self->export_setstatus_vacationX( $svc_x, 'add', $hr );
 188 }
 189
 190 sub export_setstatus_vacationdel {
 191   my( $self, $svc_x, $hr ) = @_;
 192   $self->export_setstatus_vacationX( $svc_x, 'del', $hr );
 193 }
 194
 195 sub export_setstatus_vacationX {
 196   my( $self, $svc_x, $action, $hr ) = @_;
 197
 198   if ( $FS::svc_Common::noexport_hack ) {
 199     carp 'export_setstatus_vacationX() suppressed by noexport_hack'
 200       if $self->option('debug') || $DEBUG;
 201     return;
 202   }
 203
 204   my $option = 'vacation_'. $action. '_url';
 205
 206   my $subject = uri_escape($hr->{subject});
 207   my $body    = uri_escape($hr->{body});
 208   for (qw( created enddate )) {
 209     if ( $hr->{$_} =~ /^(\d{4}-\d{2}-\d{2})$/ ) {
 210       $hr->{$_} = $1;
 211     } else {
 212       $hr->{$_} = '';
 213     }
 214   }
 215   my $created = $hr->{created};
 216   my $enddate = $hr->{enddate};
 217
 218   #some false laziness w/export_getstatus above
 219   my $url;
 220   my $urlopt = $self->option($option) or return; #DIFF
 221   no strict 'vars';
 222   {
 223     no strict 'refs';
 224     ${$_} = $svc_x->getfield($_) foreach $svc_x->fields;
 225     ${$_} = $svc_x->$_()         foreach @{ $addl_fields{ $svc_x->table } };
 226     $url = eval(qq("$urlopt"));
 227   }
 228
 229   my $req = HTTP::Request::Common::GET( $url );
 230   my $ua = LWP::UserAgent->new;
 231   my $response = $ua->request($req);
 232
 233   die $response->code. ' '. $response->message if $response->is_error;
 234
 235 }
 236
 237 1;