perl/Aranea.pm

   1 #
   2 # The new protocol for real at last
   3 #
   4 # $Id$
   5 #
   6 # Copyright (c) 2005 Dirk Koopman G1TLH
   7 #
   8
   9 package Aranea;
  10
  11 use strict;
  12
  13 use DXUtil;
  14 use DXChannel;
  15 use DXUser;
  16 use DXM;
  17 use DXLog;
  18 use DXDebug;
  19 use Filter;
  20 use Time::HiRes qw(gettimeofday tv_interval);
  21 use DXHash;
  22 use Route;
  23 use Route::Node;
  24 use Script;
  25 use Verify;
  26 use DXDupe;
  27
  28 use vars qw($VERSION $BRANCH);
  29 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  30 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  31 $main::build += $VERSION;
  32 $main::branch += $BRANCH;
  33
  34 use vars qw(@ISA $ntpflag $dupeage);
  35
  36 @ISA = qw(DXChannel);
  37
  38 $ntpflag = 0;                                   # should be set in startup if NTP in use
  39 $dupeage = 12*60*60;                    # duplicates stored half a day
  40
  41 my $seqno = 0;
  42 my $dayno = 0;
  43
  44 sub init
  45 {
  46
  47 }
  48
  49 sub new
  50 {
  51         my $self = DXChannel::alloc(@_);
  52
  53         # add this node to the table, the values get filled in later
  54         my $pkg = shift;
  55         my $call = shift;
  56         $main::routeroot->add($call, '5000', Route::here(1)) if $call ne $main::mycall;
  57         $self->{'sort'} = 'W';
  58         return $self;
  59 }
  60
  61 sub start
  62 {
  63         my ($self, $line, $sort) = @_;
  64         my $call = $self->{call};
  65         my $user = $self->{user};
  66
  67         # log it
  68         my $host = $self->{conn}->{peerhost} || "unknown";
  69         Log('Aranea', "$call connected from $host");
  70
  71         # remember type of connection
  72         $self->{consort} = $line;
  73         $self->{outbound} = $sort eq 'O';
  74         my $priv = $user->priv;
  75         $priv = $user->priv(1) unless $priv;
  76         $self->{priv} = $priv;     # other clusters can always be 'normal' users
  77         $self->{lang} = $user->lang || 'en';
  78         $self->{consort} = $line;       # save the connection type
  79         $self->{here} = 1;
  80         $self->{width} = 80;
  81
  82         # sort out registration
  83         $self->{registered} = 1;
  84
  85         # get the output filters
  86         $self->{spotsfilter} = Filter::read_in('spots', $call, 0) || Filter::read_in('spots', 'node_default', 0);
  87         $self->{wwvfilter} = Filter::read_in('wwv', $call, 0) || Filter::read_in('wwv', 'node_default', 0);
  88         $self->{wcyfilter} = Filter::read_in('wcy', $call, 0) || Filter::read_in('wcy', 'node_default', 0);
  89         $self->{annfilter} = Filter::read_in('ann', $call, 0) || Filter::read_in('ann', 'node_default', 0) ;
  90         $self->{routefilter} = Filter::read_in('route', $call, 0) || Filter::read_in('route', 'node_default', 0) unless $self->{isolate} ;
  91
  92
  93         # get the INPUT filters (these only pertain to Clusters)
  94         $self->{inspotsfilter} = Filter::read_in('spots', $call, 1) || Filter::read_in('spots', 'node_default', 1);
  95         $self->{inwwvfilter} = Filter::read_in('wwv', $call, 1) || Filter::read_in('wwv', 'node_default', 1);
  96         $self->{inwcyfilter} = Filter::read_in('wcy', $call, 1) || Filter::read_in('wcy', 'node_default', 1);
  97         $self->{inannfilter} = Filter::read_in('ann', $call, 1) || Filter::read_in('ann', 'node_default', 1);
  98         $self->{inroutefilter} = Filter::read_in('route', $call, 1) || Filter::read_in('route', 'node_default', 1) unless $self->{isolate};
  99
 100         $self->conn->echo(0) if $self->conn->can('echo');
 101
 102         # ping neighbour node stuff
 103         my $ping = $user->pingint;
 104         $ping = $DXProt::pingint unless defined $ping;
 105         $self->{pingint} = $ping;
 106         $self->{nopings} = $user->nopings || $DXProt::obscount;
 107         $self->{pingtime} = [ ];
 108         $self->{pingave} = 999;
 109         $self->{metric} ||= 100;
 110         $self->{lastping} = $main::systime;
 111
 112         $self->state('init');
 113         $self->{pc50_t} = $main::systime;
 114
 115         # send info to all logged in thingies
 116         $self->tell_login('loginn');
 117
 118         # run a script send the output to the debug file
 119         my $script = new Script(lc $call) || new Script('node_default');
 120         $script->run($self) if $script;
 121         $self->send("Hello?");
 122 }
 123
 124 #
 125 # This is the normal despatcher
 126 #
 127 sub normal
 128 {
 129         my ($self, $line) = @_;
 130
 131
 132 }
 133
 134 #
 135 # periodic processing
 136 #
 137
 138 sub process
 139 {
 140
 141         # calc day number
 142         $dayno = (gmtime($main::systime))[3];
 143 }
 144
 145 #
 146 # generate new header (this is a general subroutine, not a method
 147 # because it has to be used before a channel is fully initialised).
 148 #
 149
 150 sub genheader
 151 {
 152         my $mycall = shift;
 153         my $to = shift;
 154         my $from = shift;
 155
 156         my $date = ((($dayno << 1) | $ntpflag) << 18) |  ($main::systime % 86400);
 157         my $r = "$mycall,$to," . sprintf('%06X%04X,0', $date, $seqno);
 158         $r .= ",$from" if $from;
 159         $seqno++;
 160         $seqno = 0 if $seqno > 0x0ffff;
 161         return $r;
 162 }
 163
 164 # subroutines to encode and decode values in lists
 165 sub tencode
 166 {
 167         my $s = shift;
 168         $s =~ s/([\%=|,\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
 169         return $s;
 170 }
 171
 172 sub tdecode
 173 {
 174         my $s = shift;
 175         $s =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
 176         return $s;
 177 }
 178
 179 sub genmsg
 180 {
 181         my $thing = shift;
 182         my $name = shift;
 183         my $head = genheader($thing->{origin},
 184                                                  ($thing->{group} || $thing->{touser} || $thing->{tonode}),
 185                                                  ($thing->{user} || $thing->{fromuser} || $thing->{fromnode})
 186                                                 );
 187         my $data = "$name,";
 188         while (@_) {
 189                 my $k = lc shift;
 190                 my $v = tencode(shift);
 191                 $data .= "$k=$v,";
 192         }
 193         chop $data;
 194         return "$head|$data";
 195 }
 196
 197 sub input
 198 {
 199         my $line = shift;
 200         my ($head, $data) = split /\|/, $line, 2;
 201         return unless $head && $data;
 202         my ($origin, $group, $dts, $hop, $user) = split /,/, $head;
 203         return if DXDupe::add("Ara,$origin,$dts", $dupeage);
 204         $hop++;
 205         my ($cmd, $rdata) = split /,/, $data, 2;
 206         my $class = 'Thingy::' . ucfirst $cmd;
 207         my $thing;
 208
 209         # create the appropriate Thingy
 210         if (defined *$class) {
 211                 $thing = $class->new();
 212
 213                 # reconstitute the header but wth hop increased by one
 214                 $head = join(',', $origin, $group, $dts, $hop);
 215                 $head .= ",$user" if $user;
 216                 $thing->{Aranea} = "$head|$data";
 217
 218                 # store useful data
 219                 $thing->{origin} = $origin;
 220                 $thing->{group} = $group;
 221                 $thing->{time} = decode_dts($dts);
 222                 $thing->{user} = $user if $user;
 223                 $thing->{hopsaway} = $hop;
 224
 225                 while (my ($k,$v) = split /,/, $rdata) {
 226                         $thing->{$k} = tdecode($v);
 227                 }
 228         }
 229         return $thing;
 230 }
 231
 232 1;