]> scm.dxcluster.org Git - spider.git/blob - perl/cluster.pl
add a modicum of security to the remote key get
[spider.git] / perl / cluster.pl
1 #!/usr/bin/perl -w
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         umask 002;
18         
19         # root of directory tree for this system
20         $root = "/spider"; 
21         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
22         
23         unshift @INC, "$root/perl";     # this IS the right way round!
24         unshift @INC, "$root/local";
25
26         # do some validation of the input
27         die "The directory $root doesn't exist, please RTFM" unless -d $root;
28         die "$root/local doesn't exist, please RTFM" unless -d "$root/local";
29         die "$root/local/DXVars.pm doesn't exist, please RTFM" unless -e "$root/local/DXVars.pm";
30         
31         mkdir "$root/local_cmd", 0777 unless -d "$root/local_cmd";
32         
33
34         # try to create and lock a lockfile (this isn't atomic but 
35         # should do for now
36         $lockfn = "$root/local/cluster.lck";       # lock file name
37         if (-e $lockfn) {
38                 open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!";
39                 my $pid = <CLLOCK>;
40                 chomp $pid;
41                 die "Lockfile ($lockfn) and process $pid exist, another cluster running?" if kill 0, $pid;
42                 close CLLOCK;
43         }
44         open(CLLOCK, ">$lockfn") or die "Can't open Lockfile ($lockfn) $!";
45         print CLLOCK "$$\n";
46         close CLLOCK;
47
48         $is_win = ($^O =~ /^MS/ || $^O =~ /^OS-2/) ? 1 : 0; # is it Windows?
49         $systime = time;
50 }
51
52 use DXVars;
53 use Msg;
54 use IntMsg;
55 use Internet;
56 use Listeners;
57 use ExtMsg;
58 use AGWConnect;
59 use AGWMsg;
60 use DXDebug;
61 use DXLog;
62 use DXLogPrint;
63 use DXUtil;
64 use DXChannel;
65 use DXUser;
66 use DXM;
67 use DXCommandmode;
68 use DXProtVars;
69 use DXProtout;
70 use DXProt;
71 use QXProt;
72 use DXMsg;
73 use DXCron;
74 use DXConnect;
75 use DXBearing;
76 use DXDb;
77 use DXHash;
78 use DXDupe;
79 use Script;
80 use Prefix;
81 use Spot;
82 use Bands;
83 use Keps;
84 use Minimuf;
85 use Sun;
86 use Geomag;
87 use CmdAlias;
88 use Filter;
89 use AnnTalk;
90 use BBS;
91 use WCY;
92 use BadWords;
93 use Timer;
94 use Route;
95 use Route::Node;
96 use Route::User;
97 use Editable;
98 use Mrtg;
99 use USDB;
100 use UDPMsg;
101 use QSL;
102
103 use Data::Dumper;
104 use IO::File;
105 use Fcntl ':flock'; 
106 use POSIX ":sys_wait_h";
107
108 use Local;
109
110 package main;
111
112 use strict;
113 use vars qw(@inqueue $systime $version $starttime $lockfn @outstanding_connects 
114                         $zombies $root @listeners $lang $myalias @debug $userfn $clusteraddr 
115                         $clusterport $mycall $decease $is_win $routeroot $me $reqreg
116                    );
117
118 @inqueue = ();                                  # the main input queue, an array of hashes
119 $systime = 0;                                   # the time now (in seconds)
120 $version = "1.51";                              # the version no of the software
121 $starttime = 0;                 # the starting time of the cluster   
122 #@outstanding_connects = ();     # list of outstanding connects
123 @listeners = ();                                # list of listeners
124 $reqreg = 0;                                    # 1 = registration required, 2 = deregister people
125
126 use vars qw($VERSION $BRANCH $build $branch);
127 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
128 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
129 $main::build += 5;                              # add an offset to make it bigger than last system
130 $main::build += $VERSION;
131 $main::branch += $BRANCH;
132
133       
134 # send a message to call on conn and disconnect
135 sub already_conn
136 {
137         my ($conn, $call, $mess) = @_;
138
139         $conn->disable_read(1);
140         dbg("-> D $call $mess\n") if isdbg('chan'); 
141         $conn->send_now("D$call|$mess");
142         sleep(2);
143         $conn->disconnect;
144 }
145
146 sub error_handler
147 {
148         my $dxchan = shift;
149         $dxchan->{conn}->set_error(undef) if exists $dxchan->{conn};
150         $dxchan->disconnect(1);
151 }
152
153 # handle incoming messages
154 sub new_channel
155 {
156         my ($conn, $msg) = @_;
157         my ($sort, $call, $line) = DXChannel::decode_input(0, $msg);
158         return unless defined $sort;
159
160         unless (is_callsign($call)) {
161                 already_conn($conn, $call, DXM::msg($lang, "illcall", $call));
162                 return;
163         }
164
165         # set up the basic channel info
166         # is there one already connected to me - locally? 
167         my $user = DXUser->get_current($call);
168         my $dxchan = DXChannel->get($call);
169         if ($dxchan) {
170                 my $mess = DXM::msg($lang, ($user && $user->is_node) ? 'concluster' : 'conother', $call, $main::mycall);
171                 already_conn($conn, $call, $mess);
172                 return;
173         }
174
175         # is he locked out ?
176         my $basecall = $call;
177         $basecall =~ s/-\d+$//;
178         my $baseuser = DXUser->get_current($basecall);
179         my $lock = $user->lockout if $user;
180         if ($baseuser && $baseuser->lockout || $lock) {
181                 if (!$user || !defined $lock || $lock) {
182                         my $host = $conn->{peerhost} || "unknown";
183                         Log('DXCommand', "$call on $host is locked out, disconnected");
184                         $conn->disconnect;
185                         return;
186                 }
187         }
188         
189         if ($user) {
190                 $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems
191         } else {
192                 $user = DXUser->new($call);
193         }
194         
195
196         # create the channel
197         if ($user->wantnp) {
198                 if ($user->passphrase && $main::me->user->passphrase) {
199                         $dxchan = QXProt->new($call, $conn, $user);
200                 } else {
201                         unless ($user->passphrase) {
202                                 Log('DXCommand', "$call using NP but has no passphrase");
203                                 dbg("$call using NP but has no passphrase");
204                         }
205                         unless ($main::me->user->passphrase) {
206                                 Log('DXCommand', "$main::mycall using NP but has no passphrase");
207                                 dbg("$main::mycall using NP but has no passphrase");
208                         }
209                         already_conn($conn, $call, "Need to exchange passphrases");
210                         return;
211                 }
212         } elsif ($user->is_node) {
213                 $dxchan = DXProt->new($call, $conn, $user);
214         } elsif ($user->is_user) {
215                 $dxchan = DXCommandmode->new($call, $conn, $user);
216         } elsif ($user->is_bbs) {
217                 $dxchan = BBS->new($call, $conn, $user);
218         } else {
219                 die "Invalid sort of user on $call = $sort";
220         }
221
222         # check that the conn has a callsign
223         $conn->conns($call) if $conn->isa('IntMsg');
224
225         # set callbacks
226         $conn->set_error(sub {error_handler($dxchan)});
227         $conn->set_rproc(sub {my ($conn,$msg) = @_; rec($dxchan, $conn, $msg);});
228         rec($dxchan, $conn, $msg);
229 }
230
231 sub rec 
232 {
233         my ($dxchan, $conn, $msg) = @_;
234         
235         # queue the message and the channel object for later processing
236         if (defined $msg) {
237                 my $self = bless {}, "inqueue";
238                 $self->{dxchan} = $dxchan;
239                 $self->{data} = $msg;
240                 push @inqueue, $self;
241         }
242 }
243
244 # remove any outstanding entries on the inqueue after a disconnection (usually)
245 sub clean_inqueue
246 {
247         my $dxchan = shift;
248         @inqueue = grep {$_->{dxchan} != $dxchan} @inqueue;
249 }
250
251 sub login
252 {
253         return \&new_channel;
254 }
255
256 # cease running this program, close down all the connections nicely
257 sub cease
258 {
259         my $dxchan;
260
261         unless ($is_win) {
262                 $SIG{'TERM'} = 'IGNORE';
263                 $SIG{'INT'} = 'IGNORE';
264         }
265         
266         DXUser::sync;
267
268         eval {
269                 Local::finish();   # end local processing
270         };
271         dbg("Local::finish error $@") if $@;
272
273         # disconnect nodes
274         foreach $dxchan (DXChannel->get_all_nodes) {
275             $dxchan->disconnect(2) unless $dxchan == $main::me;
276         }
277         Msg->event_loop(100, 0.01);
278
279         # disconnect users
280         foreach $dxchan (DXChannel->get_all_users) {
281                 $dxchan->disconnect;
282         }
283
284         # disconnect AGW
285         AGWMsg::finish();
286
287         # disconnect UDP customers
288         UDPMsg::finish();
289
290         # end everything else
291         Msg->event_loop(100, 0.01);
292         DXUser::finish();
293         DXDupe::finish();
294
295         # close all databases
296         DXDb::closeall;
297
298         # close all listeners
299         foreach my $l (@listeners) {
300                 $l->close_server;
301         }
302
303         dbg("DXSpider version $version, build $build ended") if isdbg('chan');
304         Log('cluster', "DXSpider V$version, build $build ended");
305         dbgclose();
306         Logclose();
307         unlink $lockfn;
308 #       $SIG{__WARN__} = $SIG{__DIE__} =  sub {my $a = shift; cluck($a); };
309         exit(0);
310 }
311
312 # the reaper of children
313 sub reap
314 {
315         my $cpid;
316         while (($cpid = waitpid(-1, WNOHANG)) > 0) {
317                 dbg("cpid: $cpid") if isdbg('reap');
318 #               Msg->pid_gone($cpid);
319                 $zombies-- if $zombies > 0;
320         }
321         dbg("cpid: $cpid") if isdbg('reap');
322 }
323
324 # this is where the input queue is dealt with and things are dispatched off to other parts of
325 # the cluster
326 sub process_inqueue
327 {
328         while (@inqueue) {
329                 my $self = shift @inqueue;
330                 return if !$self;
331
332                 my $data = $self->{data};
333                 my $dxchan = $self->{dxchan};
334                 my $error;
335                 my ($sort, $call, $line) = DXChannel::decode_input($dxchan, $data);
336                 return unless defined $sort;
337         
338                 # do the really sexy console interface bit! (Who is going to do the TK interface then?)
339                 dbg("<- $sort $call $line") if $sort ne 'D' && isdbg('chan');
340                 if ($self->{disconnecting}) {
341                         dbg('In disconnection, ignored');
342                         next;
343                 }
344                 
345                 # handle A records
346                 my $user = $dxchan->user;
347                 if ($sort eq 'A' || $sort eq 'O') {
348                         $dxchan->start($line, $sort);  
349                 } elsif ($sort eq 'I') {
350                         die "\$user not defined for $call" if !defined $user;
351
352                         # normal input
353                         $dxchan->normal($line);
354                 } elsif ($sort eq 'Z') {
355                         $dxchan->disconnect;
356                 } elsif ($sort eq 'D') {
357                         ;                                       # ignored (an echo)
358                 } elsif ($sort eq 'G') {
359                         $dxchan->enhanced($line);
360                 } else {
361                         print STDERR atime, " Unknown command letter ($sort) received from $call\n";
362                 }
363         }
364 }
365
366 sub uptime
367 {
368         my $t = $systime - $starttime;
369         my $days = int $t / 86400;
370         $t -= $days * 86400;
371         my $hours = int $t / 3600;
372         $t -= $hours * 3600;
373         my $mins = int $t / 60;
374         return sprintf "%d %02d:%02d", $days, $hours, $mins;
375 }
376
377 sub AGWrestart
378 {
379         AGWMsg::init(\&new_channel);
380 }
381
382 #############################################################
383 #
384 # The start of the main line of code 
385 #
386 #############################################################
387
388 $starttime = $systime = time;
389 $lang = 'en' unless $lang;
390
391 # open the debug file, set various FHs to be unbuffered
392 dbginit(\&DXCommandmode::broadcast_debug);
393 foreach (@debug) {
394         dbgadd($_);
395 }
396 STDOUT->autoflush(1);
397
398 # calculate build number
399 $build += $main::version;
400 $build = "$build.$branch" if $branch;
401
402 Log('cluster', "DXSpider V$version, build $build started");
403
404 # banner
405 dbg("Copyright (c) 1998-2002 Dirk Koopman G1TLH");
406 dbg("DXSpider Version $version, build $build started");
407
408 # load Prefixes
409 dbg("loading prefixes ...");
410 my $r = Prefix::init();
411 confess $r if $r;
412 dbg(USDB::init());
413
414 # load band data
415 dbg("loading band data ...");
416 Bands::load();
417
418 # initialise User file system
419 dbg("loading user file system ..."); 
420 DXUser->init($userfn, 1);
421
422 # look for the sysop and the alias user and complain if they aren't there
423 {
424         my $ref = DXUser->get($mycall);
425         die "$mycall missing, run the create_sysop.pl script and please RTFM" unless $ref && $ref->priv == 9;
426         $ref = DXUser->get($myalias);
427         die "$myalias missing, run the create_sysop.pl script and please RTFM" unless $ref && $ref->priv == 9;
428 }
429
430 # start listening for incoming messages/connects
431 dbg("starting listeners ...");
432 my $conn = IntMsg->new_server($clusteraddr, $clusterport, \&login);
433 $conn->conns("Server $clusteraddr/$clusterport");
434 push @listeners, $conn;
435 dbg("Internal port: $clusteraddr $clusterport");
436 foreach my $l (@main::listen) {
437         $conn = ExtMsg->new_server($l->[0], $l->[1], \&login);
438         $conn->conns("Server $l->[0]/$l->[1]");
439         push @listeners, $conn;
440         dbg("External Port: $l->[0] $l->[1]");
441 }
442
443 dbg("AGW Listener") if $AGWMsg::enable;
444 AGWrestart();
445
446 dbg("UDP Listener") if $UDPMsg::enable;
447 UDPMsg::init(\&new_channel);
448
449 # load bad words
450 dbg("load badwords: " . (BadWords::load or "Ok"));
451
452 # prime some signals
453 unless ($DB::VERSION) {
454         $SIG{INT} = $SIG{TERM} = sub { $decease = 1 };
455 }
456
457 unless ($is_win) {
458         $SIG{HUP} = 'IGNORE';
459         $SIG{CHLD} = sub { $zombies++ };
460         
461         $SIG{PIPE} = sub {      dbg("Broken PIPE signal received"); };
462         $SIG{IO} = sub {        dbg("SIGIO received"); };
463         $SIG{WINCH} = $SIG{STOP} = $SIG{CONT} = 'IGNORE';
464         $SIG{KILL} = 'DEFAULT';     # as if it matters....
465
466         # catch the rest with a hopeful message
467         for (keys %SIG) {
468                 if (!$SIG{$_}) {
469                         #               dbg("Catching SIG $_") if isdbg('chan');
470                         $SIG{$_} = sub { my $sig = shift;       DXDebug::confess("Caught signal $sig");  }; 
471                 }
472         }
473 }
474
475 # start dupe system
476 dbg("Starting Dupe system");
477 DXDupe::init();
478
479 # read in system messages
480 dbg("Read in Messages");
481 DXM->init();
482
483 # read in command aliases
484 dbg("Read in Aliases");
485 CmdAlias->init();
486
487 # initialise the Geomagnetic data engine
488 dbg("Start WWV");
489 Geomag->init();
490 dbg("Start WCY");
491 WCY->init();
492
493 # initial the Spot stuff
494 dbg("Starting DX Spot system");
495 Spot->init();
496
497 # initialise the protocol engine
498 dbg("Start Protocol Engines ...");
499 DXProt->init();
500 QXProt->init();
501
502 # put in a DXCluster node for us here so we can add users and take them away
503 $routeroot = Route::Node->new($mycall, $version*100+5300, Route::here($main::me->here)|Route::conf($main::me->conf));
504
505 # make sure that there is a routing OUTPUT node default file
506 #unless (Filter::read_in('route', 'node_default', 0)) {
507 #       my $dxcc = $main::me->dxcc;
508 #       $Route::filterdef->cmd($main::me, 'route', 'accept', "node_default call $mycall" );
509 #}
510
511 # read in any existing message headers and clean out old crap
512 dbg("reading existing message headers ...");
513 DXMsg->init();
514 DXMsg::clean_old();
515
516 # read in any cron jobs
517 dbg("reading cron jobs ...");
518 DXCron->init();
519
520 # read in database descriptors
521 dbg("reading database descriptors ...");
522 DXDb::load();
523
524 # starting local stuff
525 dbg("doing local initialisation ...");
526 QSL::init(1);
527 eval {
528         Local::init();
529 };
530 dbg("Local::init error $@") if $@;
531
532 # this, such as it is, is the main loop!
533 dbg("orft we jolly well go ...");
534 my $script = new Script "startup";
535 $script->run($main::me) if $script;
536
537 #open(DB::OUT, "|tee /tmp/aa");
538
539 for (;;) {
540 #       $DB::trace = 1;
541         
542         Msg->event_loop(10, 0.010);
543         my $timenow = time;
544         process_inqueue();                      # read in lines from the input queue and despatch them
545 #       $DB::trace = 0;
546         
547         # do timed stuff, ongoing processing happens one a second
548         if ($timenow != $systime) {
549                 reap if $zombies;
550                 $systime = $timenow;
551                 DXCron::process();      # do cron jobs
552                 DXCommandmode::process(); # process ongoing command mode stuff
553                 DXProt::process();              # process ongoing ak1a pcxx stuff
554                 QXProt::process();
555                 DXConnect::process();
556                 DXMsg::process();
557                 DXDb::process();
558                 DXUser::process();
559                 DXDupe::process();
560                 AGWMsg::process();
561                                 
562                 eval { 
563                         Local::process();       # do any localised processing
564                 };
565                 dbg("Local::process error $@") if $@;
566         }
567         if ($decease) {
568                 last if --$decease <= 0;
569         }
570 }
571 cease(0);
572 exit(0);
573
574