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 LWP::UserAgent;
   8 use HTTP::Request::Common;
   9 use Email::Valid;
  10
  11 tie my %options, 'Tie::IxHash',
  12   'url' => { label => 'URL', },
  13   'blacklist_add_url' => { label => 'Optional blacklist add URL', },
  14   'blacklist_del_url' => { label => 'Optional blacklist delete URL', },
  15   'whitelist_add_url' => { label => 'Optional whitelist add URL', },
  16   'whitelist_del_url' => { label => 'Optional whitelist delete URL', },
  17   #'user'     => { label => 'Username', default=>'' },
  18   #'password' => { label => 'Password', default => '' },
  19 ;
  20
  21 %info = (
  22   'svc'     => [ 'svc_acct', 'svc_dsl', ],
  23   'desc'    => 'Retrieve status information via HTTP or HTTPS',
  24   'options' => \%options,
  25   'no_machine' => 1,
  26   'notes'   => <<'END'
  27 Fields from the service can be substituted in the URL as $field.
  28
  29 Optionally, spam black/whitelist addresses may be via HTTP or HTTPS as well.
  30 END
  31 );
  32
  33 $DEBUG = 0;
  34
  35 sub rebless { shift; }
  36
  37 our %addl_fields = (
  38   'svc_acct' => [qw( email ) ],
  39   'svc_dsl'  => [qw( gateway_access_or_phonenum ) ],
  40 );
  41
  42 sub export_getstatus {
  43   my( $self, $svc_x, $htmlref, $hashref ) = @_;
  44
  45   my $url;
  46   my $urlopt = $self->option('url');
  47   no strict 'vars';
  48   {
  49     no strict 'refs';
  50     ${$_} = $svc_x->getfield($_) foreach $svc_x->fields;
  51     ${$_} = $svc_x->$_()         foreach @{ $addl_fields{ $svc_x->table } };
  52     $url = eval(qq("$urlopt"));
  53   }
  54
  55   my $req = HTTP::Request::Common::GET( $url );
  56   my $ua = LWP::UserAgent->new;
  57   my $response = $ua->request($req);
  58
  59   if ( $svc_x->table eq 'svc_dsl' ) {
  60
  61     $$htmlref = $response->is_error ? $response->error_as_HTML
  62                                     : $response->content;
  63
  64     #hash data not yet implemented for svc_dsl
  65
  66   } elsif ( $svc_x->table eq 'svc_acct' ) {
  67
  68     #this whole section is rather specific to fibernetics and should be an
  69     # option or callback or something
  70
  71     # to,from,wb_value
  72
  73     use Text::CSV_XS;
  74     my $csv = Text::CSV_XS->new;
  75
  76     my @lines = split("\n", $response->content);
  77     pop @lines if $lines[-1] eq '';
  78     my $header = shift @lines;
  79     $csv->parse($header) or return;
  80     my @header = $csv->fields;
  81
  82     while ( my $line = shift @lines ) {
  83       $csv->parse($line) or next;
  84       my @fields = $csv->fields;
  85       my %hash = map { $_ => shift(@fields) } @header;
  86
  87       if ( $hash{'wb_value'} =~ /^[WA]/i ) { #Whitelist/Allow
  88         push @{ $hashref->{'whitelist'} }, $hash{'from'};
  89       } else { # if ( $hash{'wb_value'} =~ /^[BD]/i ) { #Blacklist/Deny
  90         push @{ $hashref->{'blacklist'} }, $hash{'from'};
  91       }
  92     }
  93
  94   } #else { die 'guru meditation #295'; }
  95
  96 }
  97
  98 sub export_setstatus_listadd {
  99   my( $self, $svc_x, $hr ) = @_;
 100   $self->export_setstatus_listX( $svc_x, 'add', $hr->{list}, $hr->{address} );
 101 }
 102
 103 sub export_setstatus_listdel {
 104   my( $self, $svc_x, $hr ) = @_;
 105   $self->export_setstatus_listX( $svc_x, 'del', $hr->{list}, $hr->{address} );
 106 }
 107
 108 sub export_setstatus_listX {
 109   my( $self, $svc_x, $action, $list, $address ) = @_;
 110
 111   my $option;
 112   if ( $list =~ /^[WA]/i ) { #Whitelist/Allow
 113     $option = 'whitelist_';
 114   } else { # if ( $hash{'wb_value'} =~ /^[BD]/i ) { #Blacklist/Deny
 115     $option = 'blacklist_';
 116   }
 117   $option .= $action. '_url';
 118
 119   $address = Email::Valid->address($address)
 120     or die "address failed $Email::Valid::Details check.\n";
 121
 122   #some false laziness w/export_getstatus above
 123   my $url;
 124   my $urlopt = $self->option($option) or return; #DIFF
 125   no strict 'vars';
 126   {
 127     no strict 'refs';
 128     ${$_} = $svc_x->getfield($_) foreach $svc_x->fields;
 129     ${$_} = $svc_x->$_()         foreach @{ $addl_fields{ $svc_x->table } };
 130     $url = eval(qq("$urlopt"));
 131   }
 132
 133   my $req = HTTP::Request::Common::GET( $url );
 134   my $ua = LWP::UserAgent->new;
 135   my $response = $ua->request($req);
 136
 137   die $response->code. ' '. $response->message if $response->is_error;
 138
 139 }
 140
 141 1;
 142
 143 1;