]> scm.dxcluster.org Git - spider.git/blob - perl/cluster.pl
1. Upped the version no !!!!
[spider.git] / perl / cluster.pl
1 #!/usr/bin/perl
2 #
3 # This is the DX cluster 'daemon'. It sits in the middle of its little
4 # web of client routines sucking and blowing data where it may.
5 #
6 # Hence the name of 'spider' (although it may become 'dxspider')
7 #
8 # Copyright (c) 1998 Dirk Koopman G1TLH
9 #
10 # $Id$
11
12
13 require 5.004;
14
15 # make sure that modules are searched in the order local then perl
16 BEGIN {
17         # root of directory tree for this system
18         $root = "/spider"; 
19         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
20         
21         unshift @INC, "$root/perl";     # this IS the right way round!
22         unshift @INC, "$root/local";
23
24 #       require Exporter;
25 #       $Exporter::Verbose = 1;
26 }
27
28 use Msg;
29 use DXVars;
30 use DXDebug;
31 use DXLog;
32 use DXLogPrint;
33 use DXUtil;
34 use DXChannel;
35 use DXUser;
36 use DXM;
37 use DXCommandmode;
38 use DXProt;
39 use DXMsg;
40 use DXCluster;
41 use DXCron;
42 use DXConnect;
43 use Prefix;
44 use Bands;
45 use Geomag;
46 use CmdAlias;
47 use Local;
48
49 use Carp;
50
51 package main;
52
53 @inqueue = ();                                  # the main input queue, an array of hashes
54 $systime = 0;                                   # the time now (in seconds)
55 $version = "1.20";                              # the version no of the software
56 $starttime = 0;                 # the starting time of the cluster   
57  
58 # handle disconnections
59 sub disconnect
60 {
61         my $dxchan = shift;
62         return if !defined $dxchan;
63         $dxchan->disconnect();
64 }
65
66 # send a message to call on conn and disconnect
67 sub already_conn
68 {
69         my ($conn, $call, $mess) = @_;
70         
71         dbg('chan', "-> D $call $mess\n"); 
72         $conn->send_now("D$call|$mess");
73         sleep(1);
74         dbg('chan', "-> Z $call bye\n");
75         $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect
76 }
77
78 # handle incoming messages
79 sub rec
80 {
81         my ($conn, $msg, $err) = @_;
82         my $dxchan = DXChannel->get_by_cnum($conn); # get the dxconnnect object for this message
83         
84         if (defined $err && $err) {
85                 disconnect($dxchan) if defined $dxchan;
86                 return;
87         }
88         
89         # set up the basic channel info - this needs a bit more thought - there is duplication here
90         if (!defined $dxchan) {
91                 my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
92                 
93                 # is there one already connected elsewhere in the cluster (and not a cluster)
94                 my $user = DXUser->get($call);
95                 if ($user) {
96                         if (($user->sort eq 'A' || $call eq $myalias) && !DXCluster->get_exact($call)) {
97                                 ;
98                         } else {
99                                 if (DXCluster->get($call) || DXChannel->get($call)) {
100                                         my $mess = DXM::msg($lang, $user->sort eq 'A' ? 'concluster' : 'conother', $call);
101                                         already_conn($conn, $call, $mess);
102                                         return;
103                                 }
104                         }
105                         $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems
106                 } else {
107                         if (DXCluster->get($call)) {
108                                 my $mess = DXM::msg($lang, 'conother', $call);
109                                 already_conn($conn, $call, $mess);
110                                 return;
111                         }
112                         $user = DXUser->new($call);
113                 }
114
115                 # is he locked out ?
116                 if ($user->lockout) {
117                         Log('DXCommand', "$call is locked out, disconnected");
118                         $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect
119                         return;
120                 }
121
122                 # create the channel
123                 $dxchan = DXCommandmode->new($call, $conn, $user) if ($user->sort eq 'U');
124                 $dxchan = DXProt->new($call, $conn, $user) if ($user->sort eq 'A');
125                 die "Invalid sort of user on $call = $sort" if !$dxchan;
126         }
127         
128         # queue the message and the channel object for later processing
129         if (defined $msg) {
130                 my $self = bless {}, "inqueue";
131                 $self->{dxchan} = $dxchan;
132                 $self->{data} = $msg;
133                 push @inqueue, $self;
134         }
135 }
136
137 sub login
138 {
139         return \&rec;
140 }
141
142 # cease running this program, close down all the connections nicely
143 sub cease
144 {
145         my $dxchan;
146         
147         eval {
148                 Local::finish();   # end local processing
149         };
150         dbg('local', "Local::finish error $@") if $@;
151         
152         foreach $dxchan (DXChannel->get_all()) {
153                 disconnect($dxchan) unless $dxchan == $DXProt::me;
154         }
155         Log('cluster', "DXSpider V$version stopped");
156         exit(0);
157 }
158
159 # the reaper of children
160 sub reap
161 {
162         $SIG{'CHLD'} = \&reap;
163         my $cpid = wait;
164 }
165
166 # this is where the input queue is dealt with and things are dispatched off to other parts of
167 # the cluster
168 sub process_inqueue
169 {
170         my $self = shift @inqueue;
171         return if !$self;
172         
173         my $data = $self->{data};
174         my $dxchan = $self->{dxchan};
175         my ($sort, $call, $line) = $data =~ /^(\w)(\S+)\|(.*)$/;
176         
177         # do the really sexy console interface bit! (Who is going to do the TK interface then?)
178         dbg('chan', "<- $sort $call $line\n") unless $sort eq 'D';
179         
180         # handle A records
181         my $user = $dxchan->user;
182         if ($sort eq 'A' || $sort eq 'O') {
183                 $dxchan->start($line, $sort);  
184         } elsif ($sort eq 'I') {
185                 die "\$user not defined for $call" if !defined $user;
186                 
187                 # normal input
188                 $dxchan->normal($line);
189                 
190                 disconnect($dxchan) if ($dxchan->{state} eq 'bye');
191         } elsif ($sort eq 'Z') {
192                 disconnect($dxchan);
193         } elsif ($sort eq 'D') {
194                 ;                       # ignored (an echo)
195         } else {
196                 print STDERR atime, " Unknown command letter ($sort) received from $call\n";
197         }
198 }
199
200 sub uptime
201 {
202         my $t = $systime - $starttime;
203         my $days = int $t / 86400;
204         $t -= $days * 86400;
205         my $hours = int $t / 3600;
206         $t -= $hours * 3600;
207         my $mins = int $t / 60;
208         return sprintf "%d %02d:%02d", $days, $hours, $mins;
209 }
210 #############################################################
211 #
212 # The start of the main line of code 
213 #
214 #############################################################
215
216 $starttime = $systime = time;
217
218 # open the debug file, set various FHs to be unbuffered
219 foreach (@debug) {
220         dbgadd($_);
221 }
222 STDOUT->autoflush(1);
223
224 Log('cluster', "DXSpider V$version started");
225
226 # banner
227 print "DXSpider DX Cluster Version $version\nCopyright (c) 1998 Dirk Koopman G1TLH\n";
228
229 # load Prefixes
230 print "loading prefixes ...\n";
231 Prefix::load();
232
233 # load band data
234 print "loading band data ...\n";
235 Bands::load();
236
237 # initialise User file system
238 print "loading user file system ...\n"; 
239 DXUser->init($userfn);
240
241 # start listening for incoming messages/connects
242 print "starting listener ...\n";
243 Msg->new_server("$clusteraddr", $clusterport, \&login);
244
245 # prime some signals
246 $SIG{'INT'} = \&cease;
247 $SIG{'TERM'} = \&cease;
248 $SIG{'HUP'} = 'IGNORE';
249 $SIG{'CHLD'} = \&reap;
250
251 # read in system messages
252 DXM->init();
253
254 # read in command aliases
255 CmdAlias->init();
256
257 # initialise the Geomagnetic data engine
258 Geomag->init();
259
260 # initial the Spot stuff
261 Spot->init();
262
263 # initialise the protocol engine
264 print "reading in duplicate spot and WWV info ...\n";
265 DXProt->init();
266
267
268 # put in a DXCluster node for us here so we can add users and take them away
269 DXNode->new(0, $mycall, 0, 1, $DXProt::myprot_version); 
270
271 # read in any existing message headers and clean out old crap
272 print "reading existing message headers ...\n";
273 DXMsg->init();
274 DXMsg::clean_old();
275
276 # read in any cron jobs
277 print "reading cron jobs ...\n";
278 DXCron->init();
279
280 # starting local stuff
281 print "doing local initialisation ...\n";
282 eval {
283         Local::init();
284 };
285 dbg('local', "Local::init error $@") if $@;
286
287
288
289 # print various flags
290 #print "useful info - \$^D: $^D \$^W: $^W \$^S: $^S \$^P: $^P\n";
291
292 # this, such as it is, is the main loop!
293 print "orft we jolly well go ...\n";
294 for (;;) {
295         my $timenow;
296         Msg->event_loop(1, 0.001);
297         $timenow = time;
298         process_inqueue();                      # read in lines from the input queue and despatch them
299         
300         # do timed stuff, ongoing processing happens one a second
301         if ($timenow != $systime) {
302                 $systime = $timenow;
303                 $cldate = &cldate();
304                 $ztime = &ztime();
305                 DXCron::process();      # do cron jobs
306                 DXCommandmode::process(); # process ongoing command mode stuff
307                 DXProt::process();              # process ongoing ak1a pcxx stuff
308                 DXConnect::process();
309                 eval { 
310                         Local::process();       # do any localised processing
311                 };
312                 dbg('local', "Local::process error $@") if $@;
313         }
314         if ($decease) {
315                 last if --$decease <= 0;
316         }
317 }
318
319