perl/AsyncMsg.pm

   1 #
   2 # This class is the internal subclass that does various Async connects and
   3 # retreivals of info. Typical uses (and specific support) include http get and
   4 # post.
   5 #
   6 # This merely starts up a Msg handler (and no DXChannel) ($conn in other words)
   7 # does the GET, parses out the result and the data and then (assuming a positive
   8 # result and that the originating callsign is still online) punts out the data
   9 # to the caller.
  10 #
  11 # It isn't designed to be very clever.
  12 #
  13 # Copyright (c) 2013 - Dirk Koopman G1TLH
  14 #
  15
  16 package AsyncMsg;
  17
  18 use Msg;
  19 use DXDebug;
  20 use DXUtil;
  21 use DXChannel;
  22
  23 use vars qw(@ISA $deftimeout);
  24
  25 @ISA = qw(Msg);
  26 $deftimeout = 15;
  27
  28 my %outstanding;
  29
  30 #
  31 # standard http get handler
  32 #
  33 sub handle_get
  34 {
  35         my $conn = shift;
  36         my $msg = shift;
  37
  38         my $state = $conn->{state};
  39
  40         dbg("asyncmsg: $msg") if isdbg('async');
  41
  42         # no point in going on if there is no-one wanting the output anymore
  43         my $dxchan = DXChannel::get($conn->{caller});
  44         unless ($dxchan) {
  45                 $conn->disconnect;
  46                 return;
  47         }
  48
  49         if ($state eq 'waitreply') {
  50                 # look at the reply code and decide whether it is a success
  51                 my ($http, $code, $ascii) = $msg =~ m|(HTTP/\d\.\d)\s+(\d+)\s+(.*)|;
  52                 if ($code == 200) {
  53                         # success
  54                         $conn->{state} = 'waitblank';
  55                 } else {
  56                         $dxchan->send("$code $ascii");
  57                         $conn->disconnect;
  58                 }
  59         } elsif ($state eq 'waitblank') {
  60                 unless ($msg) {
  61                         $conn->{state} = 'indata';
  62                 }
  63         } else {
  64                 if (my $filter = $conn->{filter}) {
  65                         no strict 'refs';
  66                         # this will crash if the command has been redefined and the filter is a
  67                         # function defined there whilst the request is in flight,
  68                         # but this isn't exactly likely in a production environment.
  69                         $filter->($conn, $msg, $dxchan);
  70                 } else {
  71                         my $prefix = $conn->{prefix} || '';
  72                         $dxchan->send("$prefix$msg");
  73                 }
  74         }
  75 }
  76
  77 #
  78 # simple raw handler
  79 #
  80 # Just outputs everything
  81 #
  82 sub handle_raw
  83 {
  84         my $conn = shift;
  85         my $msg = shift;
  86
  87         # no point in going on if there is no-one wanting the output anymore
  88         my $dxchan = DXChannel::get($conn->{caller});
  89         unless ($dxchan) {
  90                 $conn->disconnect;
  91                 return;
  92         }
  93
  94         # send out the data
  95         my $prefix = $conn->{prefix} || '';
  96         $dxchan->send("$prefix$msg");
  97 }
  98
  99 sub new
 100 {
 101         my $pkg = shift;
 102         my $call = shift;
 103         my $handler = shift;
 104
 105         my $conn = $pkg->SUPER::new($handler);
 106         $conn->{caller} = ref $call ? $call->call : $call;
 107
 108         # make it persistent
 109         $outstanding{$conn} = $conn;
 110
 111         return $conn;
 112 }
 113
 114 # This does a http get on a path on a host and
 115 # returns the result (through an optional filter)
 116 #
 117 # expects to be called something like from a cmd.pl file:
 118 #
 119 # AsyncMsg->get($self, <host>, <port>, <path>, [<key=>value>...]
 120 #
 121 # Standard key => value pairs are:
 122 #
 123 # filter => CODE ref (e.g. sub { ... })
 124 # prefix => <string>                 prefix output with this string
 125 #
 126 # Anything else is taken and sent as (extra) http header stuff e.g:
 127 #
 128 # 'User-Agent' => qq{DXSpider;$main::version;$main::build;$^O}
 129 # 'Content-Type' => q{text/xml; charset=utf-8}
 130 # 'Content-Length' => $lth
 131 #
 132 # Host: is always set to the name of the host (unless overridden)
 133 # User-Agent: is set to default above (unless overridden)
 134 #
 135 sub _getpost
 136 {
 137         my $pkg = shift;
 138         my $sort = shift;
 139         my $call = shift;
 140         my $host = shift;
 141         my $port = shift;
 142         my $path = shift;
 143         my %args = @_;
 144
 145         my $filter = shift;
 146
 147         my $conn = $pkg->new($call, \&handle_get);
 148         $conn->{state} = 'waitreply';
 149         $conn->{filter} = delete $args{filter} if exists $args{filter};
 150         $conn->{prefix} = delete $args{prefix} if exists $args{prefix};
 151         $conn->{on_disconnect} = delete $args{on_disc} || delete $args{on_disconnect};
 152         $conn->{path} = $path;
 153
 154         $r = $conn->connect($host, $port);
 155         if ($r) {
 156                 dbg("Sending '$sort $path HTTP/1.0'") if isdbg('async');
 157                 $conn->send_later("$sort $path HTTP/1.0\n");
 158
 159                 my $h = delete $args{Host} || $host;
 160                 my $u = delete $args{'User-Agent'} || "DxSpider;$main::version;$main::build;$^O;$main::mycall";
 161                 my $d = delete $args{data};
 162
 163             $conn->send_later("Host: $h\n");
 164                 $conn->send_later("User-Agent: $u\n");
 165                 while (my ($k,$v) = each %args) {
 166                         $conn->send_later("$k: $v\n");
 167                 }
 168                 $conn->send_later("\n$d") if defined $d;
 169                 $conn->send_later("\n");
 170         }
 171
 172         return $r ? $conn : undef;
 173 }
 174
 175 sub get
 176 {
 177         my $pkg = shift;
 178         _getpost($pkg, "GET", @_);
 179 }
 180
 181 sub post
 182 {
 183         my $pkg = shift;
 184         _getpost($pkg, "POST", @_);
 185 }
 186
 187 # do a raw connection
 188 #
 189 # Async->raw($self, <host>, <port>, [handler => CODE ref], [prefix => <string>]);
 190 #
 191 # With no handler defined, everything sent by the connection will be sent to
 192 # the caller.
 193 #
 194 # One can send stuff out on the connection by doing a standard "$conn->send_later(...)"
 195 # inside the (custom) handler.
 196
 197 sub raw
 198 {
 199         my $pkg = shift;
 200         my $call = shift;
 201         my $host = shift;
 202         my $port = shift;
 203
 204         my %args = @_;
 205
 206         my $handler = delete $args{handler} || \&handle_raw;
 207         my $conn = $pkg->new($call, $handler);
 208         $conn->{prefix} = delete $args{prefix} if exists $args{prefix};
 209         $r = $conn->connect($host, $port);
 210         return $r ? $conn : undef;
 211 }
 212
 213 sub connect
 214 {
 215         my $conn = shift;
 216         my $host = shift;
 217         my $port = shift;
 218
 219         # start a connection
 220         my $r = $conn->SUPER::connect($host, $port);
 221         if ($r) {
 222                 dbg("HTTPMsg: Connected $conn->{cnum} to $host $port") if isdbg('async');
 223         } else {
 224                 dbg("HTTPMsg: ***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('async');
 225         }
 226
 227         return $r;
 228 }
 229
 230 sub disconnect
 231 {
 232         my $conn = shift;
 233
 234         if (my $ondisc = $conn->{on_disconnect}) {
 235                 my $dxchan = DXChannel::get($conn->{caller});
 236                 if ($dxchan) {
 237                         no strict 'refs';
 238                         $ondisc->($conn, $dxchan)
 239                 }
 240         }
 241         delete $outstanding{$conn};
 242         $conn->SUPER::disconnect;
 243 }
 244
 245 sub DESTROY
 246 {
 247         my $conn = shift;
 248         delete $outstanding{$conn};
 249         $conn->SUPER::DESTROY;
 250 }
 251
 252 1;
 253