From fd2d8314dd4fcdd7997ef80e7740702e0bad618d Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Sat, 7 Sep 2013 00:10:36 +0100 Subject: [PATCH] Add HTTPMsg.pm an async HTTP agent This is a start of making all the Net::Telnet things redundant. HTTPMsg.pm is likely to be substantially modified or replaced. W.I.P --- cmd/show/contest.pl | 105 ++++++++++++++-------------------- cmd/show/ik3qar.pl | 65 +++++++++------------ cmd/show/wm7d.pl | 52 +++++++++-------- perl/DXCommandmode.pm | 4 +- perl/HTTPMsg.pm | 129 ++++++++++++++++++++++++++++++++++++++++++ perl/Messages | 1 + perl/Msg.pm | 20 ++++--- perl/Version.pm | 4 +- 8 files changed, 244 insertions(+), 136 deletions(-) create mode 100644 perl/HTTPMsg.pm diff --git a/cmd/show/contest.pl b/cmd/show/contest.pl index 33b98903..94d8402a 100644 --- a/cmd/show/contest.pl +++ b/cmd/show/contest.pl @@ -7,80 +7,59 @@ # # -my ($self, $line) = @_; +sub handle +{ + my ($self, $line) = @_; -#return (1, "usage: sh/contest [] [], e g sh/contest sep 2012") unless $line; + return (1, $self->msg('e24')) unless $Internet::allow; -my @out; + my @out; -my $mon;; + #$DB::single = 1; -#$DB::single = 1; + # trying to make the syntax abit more user friendly... + # and yes, I have been here and it *is* all my fault (dirk) + $line = lc $line; + my ($m,$y); + ($y) = $line =~ /(\d+)/; + ($m) = $line =~ /([a-z]{3})/; -# trying to make the syntax abit more user friendly... -# and yes, I have been here and it *is* all my fault (dirk) -$line = lc $line; -my ($m,$y); -($y) = $line =~ /(\d+)/; -($m) = $line =~ /([a-z]{3})/; - -unless ($y) { - ($y) = (gmtime)[5]; - $y += 1900; -} -unless ($m) { - ($m) = (gmtime)[4]; - $m = lc $DXUtil::month[$m]; -} -$y += 2000 if $y <= 50; -$y += 1900 if $y > 50 && $y <= 99; -$m = substr $m, 0, 3 if length $m > 3; -$m = 'oct' if $m eq 'okt'; -$m = 'may' if $m eq 'mai' || $m eq 'maj'; -$mon = "$y$m"; - -dbg("sh/contest: month=$mon") if isdbg('contest'); - -my $filename = "c" . $mon . ".txt"; -my $host = $Internet::contest_host || 'www.sk3bg.se'; -my $port = 80; + unless ($y) { + ($y) = (gmtime)[5]; + $y += 1900; + } + unless ($m) { + ($m) = (gmtime)[4]; + $m = lc $DXUtil::month[$m]; + } + $y += 2000 if $y <= 50; + $y += 1900 if $y > 50 && $y <= 99; + $m = substr $m, 0, 3 if length $m > 3; + $m = 'oct' if $m eq 'okt'; + $m = 'may' if $m eq 'mai' || $m eq 'maj'; + my $mon = "$y$m"; -dbg("sh/contest: host=$host:$port") if isdbg('contest'); + dbg("sh/contest: month=$mon") if isdbg('contest'); -my $url = $Internet::contest_url || "/contest/text"; -$url .= "/$filename"; + my $filename = "c" . $mon . ".txt"; + my $host = $Internet::contest_host || 'www.sk3bg.se'; + my $port = 80; -dbg("sh/contest: url=$url") if isdbg("contest"); + dbg("sh/contest: host=$host:$port") if isdbg('contest'); -my $t = new Net::Telnet (Telnetmode => 0); -eval { $t->open(Host => $host, Port => $port, Timeout => 15); }; + my $url = $Internet::contest_url || "/contest/text"; + $url .= "/$filename"; -if (!$t || $@) { - push @out, $self->msg('e18','sk3bg.se'); -} else { - my $s = "GET $url HTTP/1.0"; - dbg("sh/contest: get='$s'") if isdbg('contest'); - - $t->print($s); - $t->print("Host: $host\n"); - $t->print("\n\n"); + dbg("sh/contest: url=$url") if isdbg("contest"); - my $notfound = $t->getline(Timeout => 10); - if (!$notfound || $notfound =~ /404 Object Not Found/) { - push @out, "there is no contest info for $mon at $host/$url"; - return (1, @out); - } else { - push @out, $notfound; + my $r = HTTPMsg->get($self->call, $host, $port, $url); + if ($r) { + push @out, $self->msg('m21', "show/contest"); + } + else { + push @out, $self->msg('e18','sk3bg.se'); } - while (!$t->eof) { - eval { push @out, $t->getline(Timeout => 10); }; - if ($@) { - push @out, $self->msg('e18', 'sk3bg.se'); - last; - } - } -} -$t->close; -return (1, @out); + return (1, @out); +} diff --git a/cmd/show/ik3qar.pl b/cmd/show/ik3qar.pl index cc1d67d5..d18906ae 100644 --- a/cmd/show/ik3qar.pl +++ b/cmd/show/ik3qar.pl @@ -5,47 +5,34 @@ # # $Id$ # -my ($self, $line) = @_; -my @list = map {uc} split /\s+/, $line; # generate a list of callsigns -my $op; -my $call = $self->call; -my @out; -return (1, $self->msg('e24')) unless $Internet::allow; -return (1, "SHOW/IK3QAR \n e.g. SH/IK3QAR II5I, SH/IK3QAR V51AS\n") unless @list; +sub handle +{ + my ($self, $line) = @_; + my $op; + my $call = $self->call; + my @out; -my $target = $Internet::ik3qar_url; -my $port = 80; -my $url = "http://".$target; + return (1, $self->msg('e24')) unless $Internet::allow; + return (1, "SHOW/IK3QAR \n e.g. SH/IK3QAR II5I, SH/IK3QAR V51AS\n") unless $line; -use Net::Telnet; -my $t = new Net::Telnet; -eval {$t->open( Host => $target, - Port => $port, - Timeout => 30); -}; + my $target = $Internet::ik3qar_url; + my $port = 80; + my $url = "http://".$target; -if (!$t || $@) { - push @out, $self->msg('e18', 'Open(IK3QAR.it)'); -} else { - dbg($list[0]."|".$list[1]) if isdbg('IK3QAR'); - $op="call=".$list[0]."&node=".$main::mycall."&passwd=".$Internet::ik3qar_pw."&user=".$call; - my $s = "GET $url/manager/dxc/dxcluster.php?$op HTTP/1.0\n" - ."User-Agent:DxSpider;$main::version;$main::build;$^O;$main::mycall;$call\n\n"; - dbg($s) if isdbg('IK3QAR'); - $t->print($s); - Log('call', "$call: SH/IK3QAR $list[0]"); - my $state = "blank"; - my $count = 1; - while (my $result = eval { $t->getline(Timeout => 30) } || $@) { - dbg($result) if isdbg('IK3QAR') && $result; - ++$count; - if ($count > 9) { - push @out, $result; - } - } - $t->close; - push @out, $self->msg('e3', 'Search(IK3QAR.it)', uc $list[0]) unless @out; + $line = uc $line; + dbg("IK3QAR: call = $line") if isdbg('ik3qar'); + $op="call=$line\&node=$main::mycall\&passwd=$Internet::ik3qar_pw\&user=$call"; + my $path = "/manager/dxc/dxcluster.php?$op"; + dbg("IK3QAR: url=$path") if isdbg('ik3qar'); + Log('call', "$call: SH/IK3QAR $line"); + + my $r = HTTPMsg->get($self->call, $target, $port, $path); + if ($r) { + push @out, $self->msg('m21', "show/ik3qar"); + } else { + push @out, $self->msg('e18', 'Open(IK3QAR.it)'); + } + + return (1, @out); } - -return (1, @out); diff --git a/cmd/show/wm7d.pl b/cmd/show/wm7d.pl index 6dfb5b14..313fb0fe 100644 --- a/cmd/show/wm7d.pl +++ b/cmd/show/wm7d.pl @@ -9,35 +9,41 @@ # # wm7d accepts only single callsign -my ($self, $line) = @_; -my $call = $self->call; -my @out; +sub handle +{ -# send 'e24' if allow in Internet.pm is not set to 1 -return (1, $self->msg('e24')) unless $Internet::allow; -return (1, "SHOW/WM7D , e.g. SH/WM7D k1xx") unless $line; -my $target = $Internet::wm7d_url || 'www.wm7d.net'; -my $port = 5000; -my $cmdprompt = '/query->.*$/'; + my ($self, $line) = @_; + my $call = $self->call; + my @out; -my($info, $t); + # send 'e24' if allow in Internet.pm is not set to 1 + return (1, $self->msg('e24')) unless $Internet::allow; + return (1, "SHOW/WM7D , e.g. SH/WM7D k1xx") unless $line; + my $target = $Internet::wm7d_url || 'www.wm7d.net'; + my $port = 5000; + my $cmdprompt = '/query->.*$/'; + + my($info, $t); -$t = new Net::Telnet; -$info = $t->open(Host => $target, - Port => $port, - Timeout => 20); + $t = new Net::Telnet; + $info = $t->open(Host => $target, + Port => $port, + Timeout => 20); -if (!$info) { - push @out, $self->msg('e18', 'WM7D.net'); -} else { + if (!$info) { + push @out, $self->msg('e18', 'WM7D.net'); + } + else { ## Wait for prompt and respond with callsign. $t->waitfor($cmdprompt); - $t->print($line); + $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; + # Log the lookup + Log('call', "$call: show/wm7d \U$line"); + $t->close; + push @out, split /[\r\n]+/, $info; + } + return (1, @out); } -return (1, @out); + diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 0218aafe..d6319f3f 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -32,11 +32,11 @@ use WCY; use Sun; use Internet; use Script; -use Net::Telnet; use QSL; use DB_File; use VE7CC; use DXXml; +use HTTPMsg; 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; our \@ISA = qw{DXCommandmode}; ); + 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}; ); if ($sub =~ m|\s*sub\s+handle\n|) { diff --git a/perl/HTTPMsg.pm b/perl/HTTPMsg.pm new file mode 100644 index 00000000..7918b932 --- /dev/null +++ b/perl/HTTPMsg.pm @@ -0,0 +1,129 @@ +# +# This class is the internal subclass that does the equivalent of a +# GET http:/// 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; + diff --git a/perl/Messages b/perl/Messages index 911f7c89..71218892 100644 --- a/perl/Messages +++ b/perl/Messages @@ -206,6 +206,7 @@ package DXM; m18 => 'Sorry, message $_[0] is currently set to KEEP', m19 => 'Startup Script for $_[0] saved, $_[1] lines', m20 => 'Empty Startup Script for $_[0] deleted', + m21 => '$_[0] Working...', maxconnect => 'Max connections on $_[0] set to $_[1]', msg1 => 'Bulletin Messages Queued', msg2 => 'Private Messages Queued', diff --git a/perl/Msg.pm b/perl/Msg.pm index 6cad5010..9251a120 100644 --- a/perl/Msg.pm +++ b/perl/Msg.pm @@ -123,7 +123,7 @@ sub new $noconns++; - dbg("Connection created ($noconns)") if isdbg('connll'); + dbg("$class Connection $conn->{cnum} created (total $noconns)") if isdbg('connll'); return bless $conn, $class; } @@ -170,11 +170,11 @@ sub conns if (ref $pkg) { $call = $pkg->{call} unless $call; return undef unless $call; - dbg("changing $pkg->{call} to $call") if isdbg('connll') && exists $pkg->{call} && $call ne $pkg->{call}; + dbg((ref $pkg) . " changing $pkg->{call} to $call") if isdbg('connll') && exists $pkg->{call} && $call ne $pkg->{call}; delete $conns{$pkg->{call}} if exists $pkg->{call} && exists $conns{$pkg->{call}} && $pkg->{call} ne $call; $pkg->{call} = $call; $ref = $conns{$call} = $pkg; - dbg("Connection $pkg->{cnum} $call stored") if isdbg('connll'); + dbg((ref $pkg) . " Connection $pkg->{cnum} $call stored") if isdbg('connll'); } else { $ref = $conns{$call}; } @@ -221,6 +221,8 @@ sub connect { $conn->{peerhost} = $to_host; $conn->{peerport} = $to_port; $conn->{sort} = 'Outgoing'; + + dbg((ref $conn) . " connecting $conn->{cnum} to $to_host:$to_port") if isdbg('connll'); my $sock; if ($blocking_supported) { @@ -245,7 +247,9 @@ sub connect { } $conn->{sock} = $sock; - $conn->{peerhost} = $sock->peerhost; # for consistency +# $conn->{peerhost} = $sock->peerhost; # for consistency + + dbg((ref $conn) . " connected $conn->{cnum} to $to_host:$to_port") if isdbg('connll'); if ($conn->{rproc}) { my $callback = sub {$conn->_rcv}; @@ -320,7 +324,7 @@ sub disconnect delete $conns{$call} if $ref && $ref == $conn; } $call ||= 'unallocated'; - dbg("Connection $conn->{cnum} $call disconnected") if isdbg('connll'); + dbg((ref $conn) . " Connection $conn->{cnum} $call disconnected") if isdbg('connll'); # get rid of any references for (keys %$conn) { @@ -500,7 +504,8 @@ sub nolinger sub dequeue { my $conn = shift; - + return if $conn->{disconnecting}; + if ($conn->{msg} =~ /\n/) { my @lines = split /\r?\n/, $conn->{msg}; if ($conn->{msg} =~ /\n$/) { @@ -509,6 +514,7 @@ sub dequeue $conn->{msg} = pop @lines; } for (@lines) { + last if $conn->{disconnecting}; &{$conn->{rproc}}($conn, defined $_ ? $_ : ''); } } @@ -717,8 +723,8 @@ sub DESTROY my $call = $conn->{call} || 'unallocated'; my $host = $conn->{peerhost} || ''; my $port = $conn->{peerport} || ''; - dbg("Connection $conn->{cnum} $call [$host $port] being destroyed") if isdbg('connll'); $noconns--; + dbg((ref $conn) . " Connection $conn->{cnum} $call [$host $port] being destroyed (total $noconns)") if isdbg('connll'); } 1; diff --git a/perl/Version.pm b/perl/Version.pm index 8ae04795..a45b4768 100644 --- a/perl/Version.pm +++ b/perl/Version.pm @@ -11,7 +11,7 @@ use vars qw($version $subversion $build $gitversion); $version = '1.55'; $subversion = '0'; -$build = '124'; -$gitversion = 'c675748'; +$build = '125'; +$gitversion = 'a554922'; 1; -- 2.43.0