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