mirror of
git://scm.dxcluster.org/scm/spider
synced 2024-09-21 07:47:10 +00:00
mv HTTPMsg to AsyncMsg, add 'raw' method
Convert sh/wm7d command to AsyncMsg. Modify all the HTTPMsg converted cmds to use AsyncMsg. Add a 'raw' 'telnet' handler. This allows one to query things with command prompts or stuff that isn't a HTTP server. But it ain't always easy. See the messing around in sh/wm7d I had to do, to get something that is stable given that the thing that I am looking doesn't have a \n at the end. It's just a prompt.
This commit is contained in:
Dirk Koopman
parent
1ec21f9257
commit
9fc2ec1708
@ -53,7 +53,7 @@ sub handle
|
||||
|
||||
dbg("sh/contest: url=$url") if isdbg("contest");
|
||||
|
||||
my $r = HTTPMsg->get($self->call, $host, $port, $url);
|
||||
my $r = AsyncMsg->get($self->call, $host, $port, $url, prefix=>'ctst> ');
|
||||
if ($r) {
|
||||
push @out, $self->msg('m21', "show/contest");
|
||||
}
|
||||
|
||||
@ -27,7 +27,8 @@ sub handle
|
||||
dbg("IK3QAR: url=$path") if isdbg('ik3qar');
|
||||
Log('call', "$call: SH/IK3QAR $line");
|
||||
|
||||
my $r = HTTPMsg->get($self->call, $target, $port, $path);
|
||||
my $r = AsyncMsg->get($self, $target, $port, $path, prefix=>'qar> ',
|
||||
'User-Agent' => "DxSpider;$main::version;$main::build;$^O;$main::mycall;$call");
|
||||
if ($r) {
|
||||
push @out, $self->msg('m21', "show/ik3qar");
|
||||
} else {
|
||||
|
||||
@ -9,6 +9,8 @@
|
||||
#
|
||||
#
|
||||
|
||||
use Minimuf;
|
||||
|
||||
my ($self, $line) = @_;
|
||||
my @f = split /\s+/, $line;
|
||||
|
||||
|
||||
@ -1,13 +1,41 @@
|
||||
#
|
||||
# Query the WM7D Database server for a callsign
|
||||
#
|
||||
# Largely based on "sh/qrz" and info in the Net::Telnet documentation
|
||||
# Was Largely based on "sh/qrz" and info in the Net::Telnet documentation
|
||||
#
|
||||
# Copyright (c) 2002 Charlie Carroll K1XX
|
||||
# Original Copyright (c) 2002 Charlie Carroll K1XX
|
||||
#
|
||||
# Async version (c) Dirk Koopman G1TLH
|
||||
#
|
||||
#
|
||||
use Net::Telnet;
|
||||
|
||||
sub waitfor
|
||||
{
|
||||
my $conn = shift;
|
||||
my $msg = shift;
|
||||
$msg =~ s/\cM//g;
|
||||
|
||||
my $buf = $conn->{msg};
|
||||
$buf =~ s/\r/\\r/g;
|
||||
$buf =~ s/\n/\\n/g;
|
||||
dbg "state $conn->{state} '$msg' '$buf'";
|
||||
|
||||
if ($conn->{state} eq 'waitfor') {
|
||||
if ($msg =~ /utc$/ ) {
|
||||
$conn->send_later("$conn->{target_call}\n");
|
||||
$conn->{state} = 'working';
|
||||
}
|
||||
} elsif ($conn->{state} eq 'working') {
|
||||
if ($conn->{msg} =~ /^\rquery->\s*$/) {
|
||||
$conn->send_later("QUIT\n");
|
||||
$conn->{state} = 'ending';
|
||||
}
|
||||
return if $msg =~ /^query->/;
|
||||
$conn->handle_raw($msg);
|
||||
} else {
|
||||
return if $msg =~ /^query->/ || $msg =~ /bye/;
|
||||
$conn->handle_raw($msg);
|
||||
}
|
||||
}
|
||||
|
||||
# wm7d accepts only single callsign
|
||||
sub handle
|
||||
@ -17,6 +45,9 @@ sub handle
|
||||
my $call = $self->call;
|
||||
my @out;
|
||||
|
||||
# $DB::single = 1;
|
||||
|
||||
|
||||
# send 'e24' if allow in Internet.pm is not set to 1
|
||||
return (1, $self->msg('e24')) unless $Internet::allow;
|
||||
return (1, "SHOW/WM7D <callsign>, e.g. SH/WM7D k1xx") unless $line;
|
||||
@ -24,27 +55,19 @@ sub handle
|
||||
my $port = 5000;
|
||||
my $cmdprompt = '/query->.*$/';
|
||||
|
||||
my($info, $t);
|
||||
|
||||
$t = new Net::Telnet;
|
||||
$info = $t->open(Host => $target,
|
||||
Port => $port,
|
||||
Timeout => 20);
|
||||
Log('call', "$call: show/wm7d \U$line");
|
||||
|
||||
if (!$info) {
|
||||
my $conn = AsyncMsg->raw($self, $target, $port,
|
||||
handler => \&waitfor, prefix=>'wm7d> ');
|
||||
if ($conn) {
|
||||
$conn->{state} = 'waitfor';
|
||||
$conn->{target_call} = $line;
|
||||
|
||||
push @out, $self->msg('m21', "show/wm7d");
|
||||
} else {
|
||||
push @out, $self->msg('e18', 'WM7D.net');
|
||||
}
|
||||
else {
|
||||
## Wait for prompt and respond with callsign.
|
||||
$t->waitfor($cmdprompt);
|
||||
$t->print($line);
|
||||
($info) = $t->waitfor($cmdprompt);
|
||||
|
||||
# Log the lookup
|
||||
Log('call', "$call: show/wm7d \U$line");
|
||||
$t->close;
|
||||
push @out, split /[\r\n]+/, $info;
|
||||
}
|
||||
|
||||
return (1, @out);
|
||||
}
|
||||
|
||||
|
||||
227
perl/AsyncMsg.pm
Normal file
227
perl/AsyncMsg.pm
Normal file
@ -0,0 +1,227 @@
|
||||
#
|
||||
# This class is the internal subclass that does various Async connects and
|
||||
# retreivals of info. Typical uses (and specific support) include http get and
|
||||
# post.
|
||||
#
|
||||
# This merely starts up a Msg handler (and no DXChannel) ($conn in other words)
|
||||
# does the GET, parses out the result and the data and then (assuming a positive
|
||||
# result and that the originating callsign is still online) punts out the data
|
||||
# to the caller.
|
||||
#
|
||||
# It isn't designed to be very clever.
|
||||
#
|
||||
# Copyright (c) 2013 - Dirk Koopman G1TLH
|
||||
#
|
||||
|
||||
package AsyncMsg;
|
||||
|
||||
use Msg;
|
||||
use DXDebug;
|
||||
use DXUtil;
|
||||
use DXChannel;
|
||||
|
||||
use vars qw(@ISA $deftimeout);
|
||||
|
||||
@ISA = qw(Msg);
|
||||
$deftimeout = 15;
|
||||
|
||||
my %outstanding;
|
||||
|
||||
#
|
||||
# standard http get handler
|
||||
#
|
||||
sub handle_get
|
||||
{
|
||||
my $conn = shift;
|
||||
my $msg = shift;
|
||||
|
||||
my $state = $conn->{state};
|
||||
|
||||
dbg("asyncmsg: $msg") if isdbg('async');
|
||||
|
||||
# no point in going on if there is no-one wanting the output anymore
|
||||
my $dxchan = DXChannel::get($conn->{caller});
|
||||
unless ($dxchan) {
|
||||
$conn->disconnect;
|
||||
return;
|
||||
}
|
||||
|
||||
if ($state eq 'waitreply') {
|
||||
# look at the reply code and decide whether it is a success
|
||||
my ($http, $code, $ascii) = $msg =~ m|(HTTP/\d\.\d)\s+(\d+)\s+(.*)|;
|
||||
if ($code == 200) {
|
||||
# success
|
||||
$conn->{state} = 'waitblank';
|
||||
} else {
|
||||
$dxchan->send("$code $ascii");
|
||||
$conn->disconnect;
|
||||
}
|
||||
} elsif ($state eq 'waitblank') {
|
||||
unless ($msg) {
|
||||
$conn->{state} = 'indata';
|
||||
}
|
||||
} else {
|
||||
if (my $filter = $conn->{filter}) {
|
||||
no strict 'refs';
|
||||
# this will crash if the command has been redefined and the filter is a
|
||||
# function defined there whilst the request is in flight,
|
||||
# but this isn't exactly likely in a production environment.
|
||||
$filter->($conn, $msg, $dxchan);
|
||||
} else {
|
||||
my $prefix = $conn->{prefix} || '';
|
||||
$dxchan->send("$prefix$msg");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# simple raw handler
|
||||
#
|
||||
# Just outputs everything
|
||||
#
|
||||
sub handle_raw
|
||||
{
|
||||
my $conn = shift;
|
||||
my $msg = shift;
|
||||
|
||||
# no point in going on if there is no-one wanting the output anymore
|
||||
my $dxchan = DXChannel::get($conn->{caller});
|
||||
unless ($dxchan) {
|
||||
$conn->disconnect;
|
||||
return;
|
||||
}
|
||||
|
||||
# send out the data
|
||||
my $prefix = $conn->{prefix} || '';
|
||||
$dxchan->send("$prefix$msg");
|
||||
}
|
||||
|
||||
sub new
|
||||
{
|
||||
my $pkg = shift;
|
||||
my $call = shift;
|
||||
my $handler = shift;
|
||||
|
||||
my $conn = $pkg->SUPER::new($handler);
|
||||
$conn->{caller} = ref $call ? $call->call : $call;
|
||||
|
||||
# make it persistent
|
||||
$outstanding{$conn} = $conn;
|
||||
|
||||
return $conn;
|
||||
}
|
||||
|
||||
# This does a http get on a path on a host and
|
||||
# returns the result (through an optional filter)
|
||||
#
|
||||
# expects to be called something like from a cmd.pl file:
|
||||
#
|
||||
# AsyncMsg->get($self, <host>, <port>, <path>, [<key=>value>...]
|
||||
#
|
||||
# Standard key => value pairs are:
|
||||
#
|
||||
# filter => CODE ref (e.g. sub { ... })
|
||||
# prefix => <string> prefix output with this string
|
||||
#
|
||||
# Anything else is taken and sent as (extra) http header stuff e.g:
|
||||
#
|
||||
# 'User-Agent' => qq{DXSpider;$main::version;$main::build;$^O}
|
||||
# 'Content-Type' => q{text/xml; charset=utf-8}
|
||||
# 'Content-Length' => $lth
|
||||
#
|
||||
# Host: is always set to the name of the host (unless overridden)
|
||||
# User-Agent: is set to default above (unless overridden)
|
||||
#
|
||||
sub get
|
||||
{
|
||||
my $pkg = shift;
|
||||
my $call = shift;
|
||||
my $host = shift;
|
||||
my $port = shift;
|
||||
my $path = shift;
|
||||
my %args = @_;
|
||||
|
||||
my $filter = shift;
|
||||
|
||||
my $conn = $pkg->new($call, \&handle_get);
|
||||
$conn->{state} = 'waitreply';
|
||||
$conn->{filter} = delete $args{filter} if exists $args{filter};
|
||||
$conn->{prefix} = delete $args{prefix} if exists $args{prefix};
|
||||
$conn->{path} = $path;
|
||||
|
||||
$r = $conn->connect($host, $port);
|
||||
if ($r) {
|
||||
dbg("Sending 'GET $path HTTP/1.0'") if isdbg('async');
|
||||
$conn->send_later("GET $path HTTP/1.0\n");
|
||||
my $h = delete $args{Host} || $host;
|
||||
my $u = delete $args{'User-Agent'} || "DxSpider;$main::version;$main::build;$^O;$main::mycall";
|
||||
$conn->send_later("Host: $h\n");
|
||||
$conn->send_later("User-Agent: $u\n");
|
||||
while (my ($k,$v) = each %args) {
|
||||
$conn->send_later("$k: $v\n");
|
||||
}
|
||||
$conn->send_later("\n");
|
||||
}
|
||||
|
||||
return $r ? $conn : undef;
|
||||
}
|
||||
|
||||
# do a raw connection
|
||||
#
|
||||
# Async->raw($self, <host>, <port>, [handler => CODE ref], [prefix => <string>]);
|
||||
#
|
||||
# With no handler defined, everything sent by the connection will be sent to
|
||||
# the caller.
|
||||
#
|
||||
# One can send stuff out on the connection by doing a standard "$conn->send_later(...)"
|
||||
# inside the (custom) handler.
|
||||
|
||||
sub raw
|
||||
{
|
||||
my $pkg = shift;
|
||||
my $call = shift;
|
||||
my $host = shift;
|
||||
my $port = shift;
|
||||
|
||||
my %args = @_;
|
||||
|
||||
my $handler = delete $args{handler} || \&handle_raw;
|
||||
my $conn = $pkg->new($call, $handler);
|
||||
$conn->{prefix} = delete $args{prefix} if exists $args{prefix};
|
||||
$r = $conn->connect($host, $port);
|
||||
return $r ? $conn : undef;
|
||||
}
|
||||
|
||||
sub connect
|
||||
{
|
||||
my $conn = shift;
|
||||
my $host = shift;
|
||||
my $port = shift;
|
||||
|
||||
# start a connection
|
||||
my $r = $conn->SUPER::connect($host, $port);
|
||||
if ($r) {
|
||||
dbg("HTTPMsg: Connected $conn->{cnum} to $host $port") if isdbg('async');
|
||||
} else {
|
||||
dbg("HTTPMsg: ***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('async');
|
||||
}
|
||||
|
||||
return $r;
|
||||
}
|
||||
|
||||
sub disconnect
|
||||
{
|
||||
my $conn = shift;
|
||||
delete $outstanding{$conn};
|
||||
$conn->SUPER::disconnect;
|
||||
}
|
||||
|
||||
sub DESTROY
|
||||
{
|
||||
my $conn = shift;
|
||||
delete $outstanding{$conn};
|
||||
$conn->SUPER::DESTROY;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@ -36,7 +36,7 @@ use QSL;
|
||||
use DB_File;
|
||||
use VE7CC;
|
||||
use DXXml;
|
||||
use HTTPMsg;
|
||||
use AsyncMsg;
|
||||
|
||||
use strict;
|
||||
use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase %nothereslug
|
||||
@ -803,7 +803,7 @@ sub find_cmd_name {
|
||||
};
|
||||
|
||||
#wrap the code into a subroutine inside our unique package
|
||||
my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; use Minimuf; use Sun; use HTTPMsg; our \@ISA = qw{DXCommandmode}; );
|
||||
my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; our \@ISA = qw{DXCommandmode}; );
|
||||
|
||||
|
||||
if ($sub =~ m|\s*sub\s+handle\n|) {
|
||||
|
||||
129
perl/HTTPMsg.pm
129
perl/HTTPMsg.pm
@ -1,129 +0,0 @@
|
||||
#
|
||||
# This class is the internal subclass that does the equivalent of a
|
||||
# GET http://<some site>/<some path> and passes the result back to the caller.
|
||||
#
|
||||
# This merely starts up a Msg handler (and no DXChannel) ($conn in other words)
|
||||
# does the GET, parses out the result and the data and then (assuming a positive
|
||||
# result and that the originating callsign is still online) punts out the data
|
||||
# to the caller.
|
||||
#
|
||||
# It isn't designed to be very clever.
|
||||
#
|
||||
# Copyright (c) 2013 - Dirk Koopman G1TLH
|
||||
#
|
||||
|
||||
package HTTPMsg;
|
||||
|
||||
use Msg;
|
||||
use DXDebug;
|
||||
use DXUtil;
|
||||
use DXChannel;
|
||||
|
||||
use vars qw(@ISA $deftimeout);
|
||||
|
||||
@ISA = qw(Msg);
|
||||
$deftimeout = 15;
|
||||
|
||||
my %outstanding;
|
||||
|
||||
sub handle
|
||||
{
|
||||
my $conn = shift;
|
||||
my $msg = shift;
|
||||
|
||||
my $state = $conn->{state};
|
||||
|
||||
dbg("httpmsg: $msg") if isdbg('http');
|
||||
|
||||
# no point in going on if there is no-one wanting the output anymore
|
||||
my $dxchan = DXChannel::get($conn->{caller});
|
||||
return unless $dxchan;
|
||||
|
||||
if ($state eq 'waitreply') {
|
||||
# look at the reply code and decide whether it is a success
|
||||
my ($http, $code, $ascii) = $msg =~ m|(HTTP/\d\.\d)\s+(\d+)\s+(.*)|;
|
||||
if ($code == 200) {
|
||||
# success
|
||||
$conn->{state} = 'waitblank';
|
||||
} else {
|
||||
$dxchan->send("$code $ascii");
|
||||
$conn->disconnect;
|
||||
}
|
||||
} elsif ($state eq 'waitblank') {
|
||||
unless ($msg) {
|
||||
$conn->{state} = 'indata';
|
||||
}
|
||||
} else {
|
||||
if (my $filter = $conn->{filter}) {
|
||||
no strict 'refs';
|
||||
# this will crash if the command has been redefined and the filter is a
|
||||
# function defined there whilst the request is in flight,
|
||||
# but this isn't exactly likely in a production environment.
|
||||
$filter->($conn, $msg, $dxchan);
|
||||
} else {
|
||||
$dxchan->send($msg);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub get
|
||||
{
|
||||
my $pkg = shift;
|
||||
my $call = shift;
|
||||
my $host = shift;
|
||||
my $port = shift;
|
||||
my $path = shift;
|
||||
my $filter = shift;
|
||||
|
||||
my $conn = $pkg->new(\&handle);
|
||||
$conn->{caller} = $call;
|
||||
$conn->{state} = 'waitreply';
|
||||
$conn->{host} = $host;
|
||||
$conn->{port} = $port;
|
||||
$conn->{filter} = $filter if $filter;
|
||||
|
||||
# make it persistent
|
||||
$outstanding{$conn} = $conn;
|
||||
|
||||
$r = $conn->connect($host, $port);
|
||||
if ($r) {
|
||||
dbg("Sending 'GET $path HTTP/1.0'") if isdbg('http');
|
||||
$conn->send_later("GET $path HTTP/1.0\nHost: $host\nUser-Agent: DxSpider;$main::version;$main::build;$^O;$main::mycall;$call\n\n");
|
||||
}
|
||||
|
||||
return $r;
|
||||
}
|
||||
|
||||
sub connect
|
||||
{
|
||||
my $conn = shift;
|
||||
my $host = shift;
|
||||
my $port = shift;
|
||||
|
||||
# start a connection
|
||||
my $r = $conn->SUPER::connect($host, $port);
|
||||
if ($r) {
|
||||
dbg("HTTPMsg: Connected $conn->{cnum} to $host $port") if isdbg('http');
|
||||
} else {
|
||||
dbg("HTTPMsg: ***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('http');
|
||||
}
|
||||
|
||||
return $r;
|
||||
}
|
||||
|
||||
sub disconnect
|
||||
{
|
||||
my $conn = shift;
|
||||
delete $outstanding{$conn};
|
||||
$conn->SUPER::disconnect;
|
||||
}
|
||||
|
||||
sub DESTROY
|
||||
{
|
||||
my $conn = shift;
|
||||
delete $outstanding{$conn};
|
||||
$conn->SUPER::DESTROY;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@ -506,9 +506,9 @@ sub dequeue
|
||||
my $conn = shift;
|
||||
return if $conn->{disconnecting};
|
||||
|
||||
if ($conn->{msg} =~ /\n/) {
|
||||
my @lines = split /\r?\n/, $conn->{msg};
|
||||
if ($conn->{msg} =~ /\n$/) {
|
||||
if ($conn->{msg} =~ /\cJ/) {
|
||||
my @lines = split /\cM?\cJ/, $conn->{msg};
|
||||
if ($conn->{msg} =~ /\cM?\cJ$/) {
|
||||
delete $conn->{msg};
|
||||
} else {
|
||||
$conn->{msg} = pop @lines;
|
||||
|
||||
@ -11,7 +11,7 @@ use vars qw($version $subversion $build $gitversion);
|
||||
|
||||
$version = '1.55';
|
||||
$subversion = '0';
|
||||
$build = '125';
|
||||
$gitversion = 'a554922';
|
||||
$build = '128';
|
||||
$gitversion = '1ec21f9';
|
||||
|
||||
1;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user