]> scm.dxcluster.org Git - spider.git/blob - perl/callbot.pl
made the communications between clients and server completely ascii (no
[spider.git] / perl / callbot.pl
1 #!/usr/bin/perl -w
2 #
3 # an attempt at producing a general purpose 'bot' for going and getting
4 # things orf the web and presenting them to user in a form they want
5 #
6 # This program uses LWP::Parallel::UserAgent to do its business
7 #
8 # each sub bot has the same structure and calling interface, but the actual
9 # input and output data formats are completely arbitrary
10 #
11 # Copyright (c) 1999 - Dirk Koopman, Tobit Computer Co Ltd
12 #
13 # $Id$
14 #
15
16 package main;
17
18 BEGIN {
19         unshift @INC, '.';
20 }
21
22 use strict;
23 use ForkingServer;
24 require LWP::Parallel::UserAgent;
25 use HTTP::Request;
26 use URI::Escape;
27 use IO::File;
28 use Carp;
29 use Text::ParseWords;
30 use QRZ;
31 use Buck;
32 use K4UTE;
33
34 use vars qw($version);
35
36 $version = "1.1";
37
38 sub cease
39 {
40         $SIG{INT} = $SIG{TERM} = 'IGNORE';
41         exit(0);
42 }
43
44 sub trancode
45 {
46         $_ = shift;
47
48         return 'Continue' if /100/;
49         return 'Switching protocols' if /101/;
50         
51         return 'Ok' if /200/;
52         return 'Created' if /201/;
53         return 'Accepted' if /202/;
54         return 'Non Authoritive' if /203/;
55         return 'No Content' if /204/;
56         return 'Reset Content' if /205/;
57         return 'Partial Content' if /206/;
58
59         return 'Multiple Choices' if /300/;
60         return 'Moved Permanently' if /301/;
61         return 'Found, redirect' if /302/;
62         return 'See Other' if /303/;
63         return 'Not modified' if /304/;
64         return 'Use proxy' if /305/;
65
66         return 'Bad request' if /400/;
67         return 'Unauthorized' if /401/;
68         return 'Payment required' if /402/;
69         return 'Forbidden' if /403/;
70         return 'Not Found' if /404/;
71         return 'Method not allowed' if /405/;
72         return 'Not acceptable' if /406/;
73         return 'Proxy authentication required' if /407/;
74         return 'Request timeout' if /408/;
75         return 'Conflict' if /409/;
76         return 'Gone' if /410/;
77         return 'Length required' if /411/;
78         return 'Precondition failed' if /412/;
79         return 'Request entity too large' if /413/;
80         return 'Request-URI too long' if /414/;
81         return 'Unsupported media type' if /415/;
82         return 'Requested range not satifiable' if /416/;
83         return 'Expectation failed' if /417/;
84         
85     return 'Internal server error' if /500/;
86         return 'Not implemented' if /501/;
87         return 'Bad gateway' if /502/;
88         return 'Service unavailable' if /503/;
89         return 'Gateway timeout' if /504/;
90         return 'HTTP version not supported' if /505/;
91         
92         return 'Unknown';
93 }
94
95 sub genpat
96 {
97         my $s = shift;
98         $s =~ s/\*/\\S+/g;
99         $s =~ s/\b(?:THE|\&|A|AND|OR|NOT)\b//gi;
100         $s =~ s/(?:\(|\))//g;
101         return join('|', split(/\s+/, $s));
102 }
103
104 # qrz specific routines
105 sub req_qrz
106 {
107         my ($ua, $call, $title) = @_;
108         my $sreq = "http://www.qrz.com/callsign.html?callsign=$call"; 
109 #       print "$sreq\n";
110         my $req = HTTP::Request->new('GET', $sreq);
111     return $ua->register($req);
112 }
113
114 sub parse_qrz
115 {
116         my ($fh, $call, $title, $code, $content) = @_;
117         if ($code != 200) {
118                 print $fh "QRZ|$code|", trancode($code), "\n";
119                 return;
120         }
121
122         # parse the HTML
123         my $r = new QRZ $call;
124         $r->debug(0);
125         my $i;
126     my $chunk;
127         my $l = length $content;
128         for ($i = 0; $i < $l && ($chunk = substr($content, $i, 512)); $i += 512) {
129                 $r->parse($chunk);
130         }
131         $r->eof;
132         
133         my @lines = $r->answer;
134         for (@lines) {
135                 print $fh "QRZ|$code|$_\n" if $_;
136         }
137         print "lines: ", scalar @lines, "\n";
138 }
139
140 # k4ute specific routines
141 sub req_ute
142 {
143         my ($ua, $call, $title) = @_;
144         my $sreq = "http://no4j.com/nfdxa/qsl/index.asp?dx=$call"; 
145 #       print "$sreq\n";
146         my $req = HTTP::Request->new('GET', $sreq);
147     return $ua->register($req);
148 }
149
150 sub parse_ute
151 {
152         my ($fh, $call, $title, $code, $content) = @_;
153         if ($code != 200) {
154                 print $fh "UTE|$code|", trancode($code), "\n";
155                 return;
156         }
157
158         # parse the HTML
159         my $r = new K4UTE $call;
160         $r->debug(0);
161         my $i;
162     my $chunk;
163         my $l = length $content;
164         for ($i = 0; $i < $l && ($chunk = substr($content, $i, 512)); $i += 512) {
165                 $r->parse($chunk);
166         }
167         $r->eof;
168         
169         my @lines = $r->answer;
170         for (@lines) {
171                 print $fh "UTE|$code|$_\n" if $_;
172         }
173         print "lines: ", scalar @lines, "\n";
174 }
175
176 # buckmaster specific routines
177 sub req_buck
178 {
179         my ($ua, $call, $title) = @_;
180         my $sreq = "http://www.buck.com/cgi-bin/do_hamcallexe"; 
181 #       print "$sreq\n";
182         my $req = HTTP::Request->new('POST', $sreq);
183         $req->add_content("entry=$call");
184     return $ua->register($req);
185 }
186
187 sub parse_buck
188 {
189         my ($fh, $call, $title, $code, $content) = @_;
190         if ($code != 200) {
191                 print $fh "BCK|$code|", trancode($code), "\n";
192                 return;
193         }
194
195         # parse the HTML
196         my $r = new Buck $call;
197         $r->debug(0);
198         my $i;
199     my $chunk;
200         my $l = length $content;
201         for ($i = 0; $i < $l && ($chunk = substr($content, $i, 512)); $i += 512) {
202                 $r->parse($chunk);
203         }
204         $r->eof;
205         
206         my @lines = $r->answer;
207         for (@lines) {
208                 print $fh "BCK|$code|$_\n" if $_;
209         }
210         print "lines: ", scalar @lines, "\n";
211 }
212
213
214 # this is what is called when an incoming request is taken
215 sub child
216 {
217         my $fh = shift;
218         
219         my $line;
220
221         if (defined ($line = <$fh>)) {
222                 $line =~ s/[\r\n]+$//g;
223                 print "{$line}\n";
224         } else {
225                 return;
226         }
227
228         $line =~ s/^[^[A-Za-z0-9\|]]+//g;
229         
230         my ($call, $title) = split /\|/, $line;
231         return if $call eq 'quit' || $call eq 'QUIT';
232
233         print "{A = '$call'";
234         print $title ?  ", T = '$title'}\n" : "}\n";
235
236         my $ua = LWP::Parallel::UserAgent->new;
237
238         # set up various UA things
239         $ua->duplicates(0);      # ignore duplicates
240         $ua->timeout(30);        
241         $ua->redirect(1);        # follow 302 redirects 
242         $ua->agent("DXSpider callbot $version");
243
244         my $res;
245         my $art = uri_escape($call);
246         my $tit = uri_escape($title);
247
248         # qrz
249         if ($res = req_qrz($ua, $art, $tit)) {
250                 print $fh "QRZ|500\n";
251         }
252         # buckmaster
253         if ($res = req_buck($ua, $art, $tit)) {
254                 print $fh "BCK|500\n";
255         }
256         # ute
257         if ($res = req_ute($ua, $art, $tit)) {
258                 print $fh "UTE|500\n";
259         }
260
261         # wait for all the results to come back
262         my $entries = $ua->wait();
263         
264         for (keys %$entries) {
265                 $res = $entries->{$_}->response;
266                 my $uri = $res->request->url;
267                 my $code = $res->code;
268                 print "url: ", $uri, " code: ", $code, "\n";
269
270                 # now parse each result
271                 for ($uri) {
272                         parse_qrz($fh, $call, $title, $code, $res->content), last if /www.qrz.com/i;
273                         parse_buck($fh, $call, $title, $code, $res->content), last if /www.buck.com/i;
274                         parse_ute($fh, $call, $title, $code, $res->content), last if /no4j.com/i;
275                 }
276         }
277         cease(0);
278 }
279
280 $SIG{INT} = \&cease;
281 $SIG{QUIT} = \&cease;
282 $SIG{HUP} = 'IGNORE';
283 STDOUT->autoflush(1);
284
285 my $server = new ForkingServer \&child;
286
287 $server->allow('.*');
288 $server->run;
289
290 cease(0);
291
292
293
294
295