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->{_asstate};
  39
  40         dbg("asyncmsg: $state $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->{_asstate} = 'waitblank';
  55                 } elsif ($code == 302) {
  56                         # redirect
  57                         $conn->{_asstate} = 'waitlocation';
  58                 } else {
  59                         $dxchan->send("$code $ascii");
  60                         $conn->disconnect;
  61                 }
  62         } elsif ($state  eq 'waitlocation') {
  63                 my ($path) = $msg =~ m|Location:\s*(.*)|;
  64                 if ($path) {
  65                         my $newconn;
  66                         my @uri = split m|/+|, $path;
  67                         if ($uri[0] eq 'http:') {
  68                                 shift @uri;
  69                                 my $host = shift @uri;
  70                                 my $newpath = '/' . join('/', @uri);
  71                                 $newpath .= '/' if $path =~ m|/$|;
  72                                 $newconn = _getpost(ref $conn, $conn->{_assort}, $conn->{caller}, $host, 80, $newpath, @{$conn->{_asargs}});
  73                         } elsif ($path =~ m|^/|) {
  74                                 $newconn = _getpost(ref $conn, $conn->{_assort}, $conn->{caller}, $conn->{peerhost}, $conn->{peerport}, $path, @{$conn->{_asargs}});
  75                         }
  76                         if ($newconn) {
  77                                 # copy over any elements in $conn that are not in $newconn
  78                                 while (my ($k,$v) = each %$conn) {
  79                                         dbg("async: $state copying over $k -> \$newconn") if isdbg('async');
  80                                         $newconn{$k} = $v unless exists $newconn{$k};
  81                                 }
  82                         }
  83                         delete $conn->{on_disconnect};
  84                         $conn->disconnect;
  85                 }
  86         } elsif ($state eq 'waitblank') {
  87                 unless ($msg) {
  88                         $conn->{_asstate} = 'indata';
  89                 }
  90         } elsif ($conn->{_asstate} eq 'indata') {
  91                 if (my $filter = $conn->{_asfilter}) {
  92                         no strict 'refs';
  93                         # this will crash if the command has been redefined and the filter is a
  94                         # function defined there whilst the request is in flight,
  95                         # but this isn't exactly likely in a production environment.
  96                         $filter->($conn, $msg, $dxchan);
  97                 } else {
  98                         my $prefix = $conn->{prefix} || '';
  99                         $dxchan->send("$prefix$msg");
 100                 }
 101         }
 102 }
 103
 104 #
 105 # simple raw handler
 106 #
 107 # Just outputs everything
 108 #
 109 sub handle_raw
 110 {
 111         my $conn = shift;
 112         my $msg = shift;
 113
 114         # no point in going on if there is no-one wanting the output anymore
 115         my $dxchan = DXChannel::get($conn->{caller});
 116         unless ($dxchan) {
 117                 $conn->disconnect;
 118                 return;
 119         }
 120
 121         # send out the data
 122         my $prefix = $conn->{prefix} || '';
 123         $dxchan->send("$prefix$msg");
 124 }
 125
 126 sub new
 127 {
 128         my $pkg = shift;
 129         my $call = shift;
 130         my $handler = shift;
 131
 132         my $conn = $pkg->SUPER::new($handler);
 133         $conn->{caller} = ref $call ? $call->call : $call;
 134
 135         # make it persistent
 136         $outstanding{$conn} = $conn;
 137
 138         return $conn;
 139 }
 140
 141 # This does a http get on a path on a host and
 142 # returns the result (through an optional filter)
 143 #
 144 # expects to be called something like from a cmd.pl file:
 145 #
 146 # AsyncMsg->get($self, <host>, <port>, <path>, [<key=>value>...]
 147 #
 148 # Standard key => value pairs are:
 149 #
 150 # filter => CODE ref (e.g. sub { ... })
 151 # prefix => <string>                 prefix output with this string
 152 #
 153 # Anything else is taken and sent as (extra) http header stuff e.g:
 154 #
 155 # 'User-Agent' => qq{DXSpider;$main::version;$main::build;$^O}
 156 # 'Content-Type' => q{text/xml; charset=utf-8}
 157 # 'Content-Length' => $lth
 158 #
 159 # Host: is always set to the name of the host (unless overridden)
 160 # User-Agent: is set to default above (unless overridden)
 161 #
 162 sub _getpost
 163 {
 164         my $pkg = shift;
 165         my $sort = shift;
 166         my $call = shift;
 167         my $host = shift;
 168         my $port = shift;
 169         my $path = shift;
 170         my %args = @_;
 171
 172
 173         my $conn = $pkg->new($call, \&handle_get);
 174         $conn->{_asargs} = [@_];
 175         $conn->{_asstate} = 'waitreply';
 176         $conn->{_asfilter} = delete $args{filter} if exists $args{filter};
 177         $conn->{prefix} = delete $args{prefix} if exists $args{prefix};
 178         $conn->{on_disconnect} = delete $args{on_disc} || delete $args{on_disconnect};
 179         $conn->{path} = $path;
 180         $conn->{host} = $host;
 181         $conn->{port} = $port;
 182         $conn->{_assort} = $sort;
 183
 184         $r = $conn->connect($host, $port, on_connect=>sub {$conn->_on_getpost_connect(@_)});
 185
 186         return $r ? $conn : undef;
 187 }
 188
 189 sub _on_getpost_connect
 190 {
 191         my $conn = shift;
 192
 193         dbg("Sending '$conn->{_assort} $conn->{path} HTTP/1.0'") if isdbg('async');
 194         $conn->send_later("$conn->{_assort} $conn->{path} HTTP/1.0\n");
 195
 196         my $h = delete $args{Host} || $host;
 197         my $u = delete $args{'User-Agent'} || "DxSpider;$main::version;$main::build;$^O;$main::mycall";
 198         my $d = delete $args{data};
 199
 200         $conn->send_later("Host: $h\n");
 201         $conn->send_later("User-Agent: $u\n");
 202         while (my ($k,$v) = each %args) {
 203                 $conn->send_later("$k: $v\n");
 204         }
 205         $conn->send_later("\n$d") if defined $d;
 206 }
 207
 208 sub get
 209 {
 210         my $pkg = shift;
 211         _getpost($pkg, "GET", @_);
 212 }
 213
 214 sub post
 215 {
 216         my $pkg = shift;
 217         _getpost($pkg, "POST", @_);
 218 }
 219
 220 # do a raw connection
 221 #
 222 # Async->raw($self, <host>, <port>, [handler => CODE ref], [prefix => <string>]);
 223 #
 224 # With no handler defined, everything sent by the connection will be sent to
 225 # the caller.
 226 #
 227 # One can send stuff out on the connection by doing a standard "$conn->send_later(...)"
 228 # inside the (custom) handler.
 229
 230 sub raw
 231 {
 232         my $pkg = shift;
 233         my $call = shift;
 234         my $host = shift;
 235         my $port = shift;
 236
 237         my %args = @_;
 238
 239         my $handler = delete $args{handler} || \&handle_raw;
 240         my $conn = $pkg->new($call, $handler);
 241         $conn->{prefix} = delete $args{prefix} if exists $args{prefix};
 242         $r = $conn->connect($host, $port, on_connect => &_on_raw_connect);
 243         return $r ? $conn : undef;
 244 }
 245
 246 sub _on_raw_connect
 247 {
 248         my $conn = shift;
 249         my $handle = shift;
 250         dbg("AsyncMsg: Connected $conn->{cnum} to $conn->{host}:$conn->{port}") if isdbg('async');
 251 }
 252
 253 sub _on_error
 254 {
 255         my $conn = shift;
 256         my $msg = shift;
 257         dbg("AsyncMsg: ***Connect $conn->{cnum} Failed to $conn->{host}:$conn->{port} $!") if isdbg('async');
 258 }
 259
 260 sub connect
 261 {
 262         my $conn = shift;
 263         my $host = shift;
 264         my $port = shift;
 265
 266         # start a connection
 267         my $r = $conn->SUPER::connect($host, $port, @_);
 268
 269         return $r;
 270 }
 271
 272 sub disconnect
 273 {
 274         my $conn = shift;
 275
 276         if (my $ondisc = $conn->{on_disconnect}) {
 277                 my $dxchan = DXChannel::get($conn->{caller});
 278                 if ($dxchan) {
 279                         no strict 'refs';
 280                         $ondisc->($conn, $dxchan)
 281                 }
 282         }
 283         delete $outstanding{$conn};
 284         $conn->SUPER::disconnect;
 285 }
 286
 287 sub DESTROY
 288 {
 289         my $conn = shift;
 290         delete $outstanding{$conn};
 291         $conn->SUPER::DESTROY;
 292 }
 293
 294 1;
 295