]> scm.dxcluster.org Git - spider.git/blob - perl/AsyncMsg.pm
remove typo in dxprothandle
[spider.git] / 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("AsyncMsg: $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->{_assort} = $sort;
181         
182         $r = $conn->connect($host, $port);
183         if ($r) {
184                 _send_later($conn, "$sort $path HTTP/1.1\r\n");
185
186                 my $h = delete $args{Host} || $host;
187                 my $u = delete $args{'User-Agent'} || "DxSpider;$main::version;$main::build;$^O;$main::mycall"; 
188                 my $d = delete $args{data};
189                 
190             _send_later($conn, "Host: $h\r\n");
191                 _send_later($conn, "User-Agent: $u\r\n");
192                 while (my ($k,$v) = each %args) {
193                         _send_later($conn, "$k: $v\r\n");
194                 }
195                 _send_later($conn, "\r\n$d") if defined $d;
196                 _send_later($conn, "\r\n");
197         }
198         
199         return $r ? $conn : undef;
200 }
201
202 sub get
203 {
204         my $pkg = shift;
205         _getpost($pkg, "GET", @_);
206 }
207
208 sub post
209 {
210         my $pkg = shift;
211         _getpost($pkg, "POST", @_);
212 }
213
214 # do a raw connection
215 #
216 # Async->raw($self, <host>, <port>, [handler => CODE ref], [prefix => <string>]);
217 #
218 # With no handler defined, everything sent by the connection will be sent to
219 # the caller.
220 #
221 # One can send stuff out on the connection by doing a standard "$conn->send_later(...)" 
222 # inside the (custom) handler.
223
224 sub raw
225 {
226         my $pkg = shift;
227         my $call = shift;
228         my $host = shift;
229         my $port = shift;
230
231         my %args = @_;
232
233         my $handler = delete $args{handler} || \&handle_raw;
234         my $conn = $pkg->new($call, $handler);
235         $conn->{prefix} = delete $args{prefix} if exists $args{prefix};
236         $r = $conn->connect($host, $port);
237         return $r ? $conn : undef;
238 }
239
240 sub connect
241 {
242         my $conn = shift;
243         my $host = shift;
244         my $port = shift;
245         
246         # start a connection
247         my $r = $conn->SUPER::connect($host, $port);
248         if ($r) {
249                 dbg("AsyncMsg: Connected $conn->{cnum} to $host $port") if isdbg('async');
250         } else {
251                 dbg("AsyncMsg: ***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('async');
252         }
253         
254         return $r;
255 }
256
257 sub disconnect
258 {
259         my $conn = shift;
260
261         if (my $ondisc = $conn->{on_disconnect}) {
262                 my $dxchan = DXChannel::get($conn->{caller});
263                 if ($dxchan) {
264                         no strict 'refs';
265                         $ondisc->($conn, $dxchan)
266                 }
267         }
268         delete $outstanding{$conn};
269         $conn->SUPER::disconnect;
270 }
271
272 sub _send_later
273 {
274         my $conn = shift;
275         my $m = shift;
276         
277         if (isdbg('async')) {
278                 my $s = $m;
279                 $s =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
280                 dbg("AsyncMsg: send $s");
281         }
282         $conn->send_later($m);
283 }
284
285 sub DESTROY
286 {
287         my $conn = shift;
288         delete $outstanding{$conn};
289         $conn->SUPER::DESTROY;
290 }
291
292 1;
293