perl/HTTPMsg.pm

   1 #
   2 # This class is the internal subclass that does the equivalent of a
   3 # GET http://<some site>/<some path> and passes the result back to the caller.
   4 #
   5 # This merely starts up a Msg handler (and no DXChannel) ($conn in other words)
   6 # does the GET, parses out the result and the data and then (assuming a positive
   7 # result and that the originating callsign is still online) punts out the data
   8 # to the caller.
   9 #
  10 # It isn't designed to be very clever.
  11 #
  12 # Copyright (c) 2013 - Dirk Koopman G1TLH
  13 #
  14
  15 package HTTPMsg;
  16
  17 use Msg;
  18 use DXDebug;
  19 use DXUtil;
  20 use DXChannel;
  21
  22 use vars qw(@ISA $deftimeout);
  23
  24 @ISA = qw(Msg);
  25 $deftimeout = 15;
  26
  27 my %outstanding;
  28
  29 sub handle
  30 {
  31         my $conn = shift;
  32         my $msg = shift;
  33
  34         my $state = $conn->{state};
  35
  36         dbg("httpmsg: $msg") if isdbg('http');
  37
  38         # no point in going on if there is no-one wanting the output anymore
  39         my $dxchan = DXChannel::get($conn->{caller});
  40         return unless $dxchan;
  41
  42         if ($state eq 'waitreply') {
  43                 # look at the reply code and decide whether it is a success
  44                 my ($http, $code, $ascii) = $msg =~ m|(HTTP/\d\.\d)\s+(\d+)\s+(.*)|;
  45                 if ($code == 200) {
  46                         # success
  47                         $conn->{state} = 'waitblank';
  48                 } else {
  49                         $dxchan->send("$code $ascii");
  50                         $conn->disconnect;
  51                 }
  52         } elsif ($state eq 'waitblank') {
  53                 unless ($msg) {
  54                         $conn->{state} = 'indata';
  55                 }
  56         } else {
  57                 if (my $filter = $conn->{filter}) {
  58                         no strict 'refs';
  59                         # this will crash if the command has been redefined and the filter is a
  60                         # function defined there whilst the request is in flight,
  61                         # but this isn't exactly likely in a production environment.
  62                         $filter->($conn, $msg, $dxchan);
  63                 } else {
  64                         $dxchan->send($msg);
  65                 }
  66         }
  67 }
  68
  69 sub get
  70 {
  71         my $pkg = shift;
  72         my $call = shift;
  73         my $host = shift;
  74         my $port = shift;
  75         my $path = shift;
  76         my $filter = shift;
  77
  78         my $conn = $pkg->new(\&handle);
  79         $conn->{caller} = $call;
  80         $conn->{state} = 'waitreply';
  81         $conn->{host} = $host;
  82         $conn->{port} = $port;
  83         $conn->{filter} = $filter if $filter;
  84
  85         # make it persistent
  86         $outstanding{$conn} = $conn;
  87
  88         $r = $conn->connect($host, $port);
  89         if ($r) {
  90                 dbg("Sending 'GET $path HTTP/1.0'") if isdbg('http');
  91                 $conn->send_later("GET $path HTTP/1.0\nHost: $host\nUser-Agent: DxSpider;$main::version;$main::build;$^O;$main::mycall;$call\n\n");
  92         }
  93
  94         return $r;
  95 }
  96
  97 sub connect
  98 {
  99         my $conn = shift;
 100         my $host = shift;
 101         my $port = shift;
 102
 103         # start a connection
 104         my $r = $conn->SUPER::connect($host, $port);
 105         if ($r) {
 106                 dbg("HTTPMsg: Connected $conn->{cnum} to $host $port") if isdbg('http');
 107         } else {
 108                 dbg("HTTPMsg: ***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('http');
 109         }
 110
 111         return $r;
 112 }
 113
 114 sub disconnect
 115 {
 116         my $conn = shift;
 117         delete $outstanding{$conn};
 118         $conn->SUPER::disconnect;
 119 }
 120
 121 sub DESTROY
 122 {
 123         my $conn = shift;
 124         delete $outstanding{$conn};
 125         $conn->SUPER::DESTROY;
 126 }
 127
 128 1;
 129