Here is rflinkserver.pl from my server, it works. Does your version look the same ? Rein: Could we have failed to sync properly when checking in or something ? I include a somewhat cleaned version of serverbeacons as well, comments are cleaned and old commented code removed. 73 de Per
#! /usr/bin/perl -w # ARQ module rflinkserver.pl by PA0R. This module is part of the PSK_ARQ suite of # programs. Rflinkserver contains the server protocol engine which adds an arq layer # to keyboard oriented protocols like PSK31, PSK63, MFSK, MT63 etc. # Rflinkserver.pl includes the arq primitives for the server. # This program is published under the GPL license. # Copyright (C) 2005, 2006, 2007 # Rein Couperus PA0R (rein@xxxxxxxxxxxx) # # * rflinkserver.pl is free software; you can redistribute it and/or modify # * it under the terms of the GNU General Public License as published by # * the Free Software Foundation; either version 2 of the License, or # * (at your option) any later version. # * # * rflinkserver.pl is distributed in the hope that it will be useful, # * but WITHOUT ANY WARRANTY; without even the implied warranty of # * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # * GNU General Public License for more details.3 # * # * You should have received a copy of the GNU General Public License # * along with this program; if not, write to the Free Software # * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA #Last change: 210207 use arq; #use Net::POP3; use Mail::POP3Client; use Net::SMTP; use DB_File; use IO::Handle; use MIME::Base64; use Time::Local; use Email::LocalDelivery; use Email::Folder; my $debug_mail = 1; my $monitor = 1; my $opensystem = 1; my $Use_ssl = 0; my ($ServerCall, $Inputfile, $output, $dbfile, $dbpass, $dbaddress, $relay, $Max_retries, $Maxidle,$Maxwebpage, $nosession, $commandcall, $Beaconminute, $Aprs_connect, $Aprs_beacon, $Aprs_port, $Aprs_address, @prefixes, $posit_time, $scheduler, @schedule, $rigtype, $rigrate, $rigdevice, $scanner, $qrgfile, $freq_offset, @freq_corrections, @Beaconarray); if (-e "pskmailrc.pl") { eval `cat pskmailrc.pl` or die "No config file: $@\n"; } if (-e "$ENV{HOME}/scheduler.pl") { eval `cat $ENV{HOME}/scheduler.pl` or die "Could not interpret scheduler file\n"; # get the schedule if there is one... $scheduler = 1; } my $modem = "PSK125"; setmode ($modem); my ($reader, $writer); pipe($reader, $writer); $writer->autoflush(1); my $ConnectStatus = "Listening"; my $TextFromFile = ""; my $Status = "Listen"; my $RxStatus = ""; my $Systemstatus = ""; my $Retries = 0; my $RxReady = 0; my $outputstring = ""; my $Version = "0.2.9"; my $Pop_host = ""; # pop3 provider my $Pop_user = ""; # pop user my $Pop_pass = ""; # pop password my $address = ""; # set return address for SMTP.... my $mailuser = ".mailuser"; # data store where the mail is received with fetchmail... my $findupasswd = ""; # password for APRS my $Usercalls = ""; my $usrmessage = ""; my $call = ""; my $dummy = 0; # dummy variable my $mymailnumber = 0; my @msgarray = (); #scheduler my $systime = 0; my $lasthour = 0; #scanner my $oldhour = 0; my $oldmins = 0; my @freqs = (); my @modes = (); my @freqhrs = (); # beacon my $Beacon_sent = 0; my @Beacons_sent = qw (0 0 0 0 0); # Keeps track of beacons, have they been sent this time around ? if ($scanner && -e "./qrg/freqs.txt") { open ($fh, $qrgfile) or die "Cannot open the scanner file!"; @freqhrs = <$fh>; close ($fh); $hour = (time / 3600) % 24; $cat = $freqhrs[0]; print "Scanning: $cat"; print "Offset = $freq_offset minute(s)\n"; chomp $cat; @freqs = split (",", $cat); my $pskmodes = $freqhrs[1]; @modes = split (",", $pskmodes); } $ConnectStatus = "Listening"; print "$Aprs_connect\n"; # open aprs write port #my ($udp_ipaddr,$udp_portaddr); $error = `echo "none" > PSKmailsession`; $error = `touch zb`; initialize(); open SESSIONDATA, ">PSKmailsession"; print SESSIONDATA $nosession; close SESSIONDATA; #get users from data base getusercalls(); { my @shortcallusers = split (" ", ($ServerCall . " " . $Usercalls)); open (CALLS, ">calls.txt"); foreach my $call (@shortcallusers) { print CALLS $call, "\n"; } close CALLS; } if ($pid = fork) { close $writer; while (1) { my $readline= ""; select undef, undef, undef, 0.1; eval { local $SIG{ALRM} = sub { die "timeout" }; alarm 10; eval { $readline = <$reader>; }; }; alarm 0; die if $@ && $@ !~ /timeout/; if ($readline) { chomp($readline); if ($monitor) { print $readline, "\n"; } $_ = $readline; if (m/~TEST/) { `cat testfile >> TxInputfile`; } elsif (m/~QUIET!/) { ####### switch beacon off ################################# if (get_session() eq $commandcall) { $nosession = "none"; print "Beacon off...\n"; `echo "Beacon off" > TxInputfile`; } } elsif (m/~BEACON!/) { ####### switch beacon on ################################# if (get_session() eq $commandcall) { $nosession = "beacon"; `echo "Beacon on" > TxInputfile`; } } elsif (m/~SPEEDUP!/) { ####### switch modem ################################# sleep 10; open (CMD, $output); # print CMD '<cmd><mode>PSK125></mode></cmd>'; close (CMD); open (CMD, ">.modem"); print CMD 'PSK125'; close (CMD); } elsif (m/~SPEEDDOWN!/) { ####### switch modem ################################# sleep 10; open (CMD, $output); # print CMD '<cmd><mode>PSK63></mode></cmd>'; close (CMD); open (CMD, ">.modem"); print CMD 'PSK63'; close (CMD); } elsif (m/~STATUS?/) { ####### switch beacon on ################################# if (get_session() eq $commandcall) { my $uptime = `uptime`; my $mem = `df | grep hda`; if ($mem =~ /(\d*%)/) { $mem = "MM = " . $1 . "\n";} my $pingout = "No internet connection"; my @ping = (); eval { @ping = `ping -c 1 pskmail.org 2>/dev/null`; }; if($ping[1] && $ping[1] =~ /(time=\d*\.*\d* ms)/) { $pingout = "Ping " . $1; } `echo "\nServer status:\n$uptime$mem$pingout\n" > TxInputfile`; } } elsif (m/~GETBEACONS/) { ####### switch beacon on ################################# my $call = get_session(); my $beacons = getbeacons($call); `echo "$beacons" > TxInputfile`; }elsif (m/~QTC\?/) { ####### get list of headers ################################# getuserdata(get_session()); if ($Pop_host) { eval { list_mail() ; # get mail from pop server }; if ($@) { `echo "Cannot get the mail headers...$@" > TxInputfile`; } else { logprint ("QTC received...\n"); if ($monitor && $debug_mail) { print `cat mailheaders`; } if (-s "mailheaders" < 10) { `echo "No mail" > TxInputfile`; }elsif (-e "mailheaders") { my $hdrlength = length (`cat mailheaders`); `echo "Your mail:" >> TxInputfile`; my $headers = `cat mailheaders >> TxInputfile`; `echo "-end-" >> TxInputfile`; unlink "mailheaders"; } } } else { `echo "Cannot get your mail!" >> TxInputfile`; } }elsif (m/~QTC (\d*)\+/) { ####### get list of headers from nr. ######################### my $starthdr = $1; getuserdata(get_session()); print "Req. QTC from $starthdr\n"; if ($Pop_host) { eval { list_mail() ; # get mail from pop server }; if ($@) { `echo "Cannot get the mail headers...$@" > TxInputfile`; } else { logprint ("QTC received...\n"); if ($monitor && $debug_mail) { print `cat mailheaders`; } if (-s "mailheaders" < 10) { `echo "No mail" > TxInputfile`; }elsif (-e "mailheaders") { my $hdrlines = `wc -l "mailheaders"`; if ($hdrlines =~ m/(\d*)/) { $hdrlines = $1; } my $newhdrs = $hdrlines - $starthdr; if ($newhdrs > 1) { `echo "Your mail:" >> TxInputfile`; my $headers = `tail -n $newhdrs mailheaders >> TxInputfile`; `echo "-end-" >> TxInputfile`; unlink "mailheaders"; } else { my $hdrs = $hdrlines - 2; `echo "Sorry, only $hdrs mails" >> TxInputfile`; } } } } else { `echo "Cannot get your mail!" >> TxInputfile`; } } elsif (m/~MAIL/) { ####### get ALL mail ################################# getuserdata(get_session()); if ($Pop_host) { eval { read_mail(1 ... $Count) ; # get mail from pop server }; if ($@) { `echo "Cannot get your mail: $@ > TxInputfile`; } else { filter($mailuser, 0); if ($debug_mail) {`cat mailfile`;} `mv mailfile TxInputfile`; `echo "-end-" >> TxInputfile`; } } else { `echo "Cannot get your mail!" >> TxInputfile`; } } elsif (m/~LISTLOCAL(.*)/) { ####### list local mails ################################# my $call = get_session(); if (-e "localmail/$call") { my $folder = Email::Folder->new("localmail/$call"); my $mails = ""; my $count = 0; for my $msg ($folder->messages) { $count++; print $count, " ", $msg->header("From"), " ", $msg->header("Subject"), "\n"; $mails .= $count . " ". $msg->header("From") . " " . $msg->header("Subject") . "\n"; } `echo "Local mail for $call:\n" >> TxInputfile`; `echo "$mails" >> TxInputfile`; `echo "-end-" >> TxInputfile`; } else { `echo "No local mail for $call:\n" >> TxInputfile`; } } elsif (m/~DELETELOCAL (.*)/) { ####### delete local mails ################################# my $call = get_session(); my $msgnr = 1 unless $1; my @numbers = split / /, $1; if (-e "localmail/$call") { my $folder = Email::Folder->new("localmail/$call"); my $mails = ""; my $count = 0; for my $msg ($folder->messages) { $count++; my $del = 1; for $msgnr (@numbers) { if ($count == $msgnr) { $del = 0; } } if ($del) { $mails .= "From $call " . $msg->header("Date") . "\n" . $msg->as_string . "\n\n"; } } open (MAILS, ">", "localmail/$call"); print MAILS $mails; close (MAILS); `echo "Mails $1 deleted..." >> TxInputfile`; } else { `echo "No local mail for $call:\n" >> TxInputfile`; } } elsif (m/~READLOCAL (.*)/) { ####### read local mails ################################# my $call = get_session(); my $msgnr = 1 unless $1; my @numbers = split / /, $1; if (-e "localmail/$call") { my $folder = Email::Folder->new("localmail/$call"); my $mails = ""; my $count = 0; for my $msg ($folder->messages) { $count++; for $msgnr (@numbers) { if ($count == $msgnr) { $mails .= "Message $count for $call:\n" . "From: ". $msg->header("From") . "\nSubject: " . $msg->header("Subject") . "\n" . "Date: " . $msg->header("Date") . "\n\n" . $msg->body . "\n" ; } } } `echo "$mails" >> TxInputfile`; `echo "\n-end-\n" >> TxInputfile`; } else { `echo "No local mail for $call:\n" >> TxInputfile`; } } elsif (m/~READBIN(.*)/) { ####### get single mails ################################# getuserdata(get_session()); my @numbers = split / /, $1; eval { read_mail(@numbers); }; if ($@) { `echo "Cannot get your mail: $@" > TxInputfile`; } else { filter($mailuser, 0); `./.cbh/cbh_code.pl -f mailfile -o TxInputfile`; if ($debug_mail) {`cat mailfile`;} unlink "mailfile"; } } elsif (m/~READ(.*)/) { ####### get single mails ################################# getuserdata(get_session()); my @numbers = split / /, $1; eval { read_mail(@numbers); }; if ($@) { `echo "Cannot get your mail: $@" > TxInputfile`; } else { filter($mailuser, 0); my $msglen = -s "mailfile"; `echo "Your msg: $msglen" >> TxInputfile`; `cat mailfile >> TxInputfile`; `echo "-end-" >> TxInputfile`; if ($debug_mail) {`cat mailfile`;} unlink "mailfile"; } } elsif (m/~KEEP(.*)/) { ####### send mail to archive ################################# ####### changer subject to [Mailarchive]date ################# getuserdata(get_session()); my @numbers = split / /, $1; eval { read_mail(@numbers); }; if ($@) { `echo "Cannot get your mail: $@" > TxInputfile`; } else { filter($mailuser, 1); @message = (); my $call = get_session(); getuserdata($call); my $subject = "[Mailarchive] " . `date`; my $to = $address; push @message, $to; push @message, $address; push @message, $subject; open ($MA, "mailfile"); my @body = <$MA>; close ($MA); foreach my $messageline (@body) { chomp $messageline; } push @message, @body; eval { send_mail(@message); # send the mail via smtp }; if ($@) { `echo "Error sending mail : $@" >> TxInputfile`; } else { `echo "\nArchive $1 sent...\n" >> TxInputfile`; } @message = (); unlink "mailfile"; } } elsif (m/~GETFILE (.*)/) { ####### get file from ./pskdownload dir ################################# my $grb = `cat ./pskdownload/$1`; $grb =~ s/\r\n/\n/g; `echo "$grb" > TxInputfile`; `echo "-end-" >> TxInputfile`; } elsif (m/~GETBIN (.*)/) { ####### get file from ./pskdownload dir ################################# my $filenm = $1; print "$filenm\n"; my $grb = ""; if (-e "./pskdownload/$1") { if (substr ($filenm, -2) ne "gz" && substr ($filenm, -3) ne "bz2") { `gzip -f -9 ./pskdownload/$filenm`; $filenm .= ".gz"; $grb = `cat ./pskdownload/$filenm`; `gunzip ./pskdownload/$filenm`; } else { $grb = `cat ./pskdownload/$filenm`; } $grb = encode_base64 ($grb); $lqrb = length ($grb); `echo "Your file:$filenm $lqrb" >> TxInputfile`; `echo "$grb" >> TxInputfile`; `echo "-end-" >> TxInputfile`; } else { `echo "File not found!" >> TxInputfile`; } } elsif (m/~LISTFILES/) { ####### list files from ./pskdownload dir ################################# my $filelist = `ls -l ./pskdownload`; @filelines = split ("\n", $filelist); $filelist = ""; foreach $fileline (@filelines) { if ($fileline =~ /.*1(.*) (.*) (.*) (.*) (.*)/) { $filelist = $filelist . $5 . " " . $3 . " " . $4 . " " . $2 . "\n"; } } my $grb = `echo "$filelist" >> TxInputfile`; $grb = `echo "-end-" >> TxInputfile`; $filelist = ""; } elsif (m/~TGET (.*)/) { ####### dump web page with elinks ################################# my $URL = $1; my $webpage = ""; if ($monitor) { print "Trying $URL\n"; } `echo "Trying $URL\n" >> TxInputfile`; eval { $webpage = `elinks -dump $URL 2>&1` or die "No page"; }; if ($webpage =~ /^Alert!/m) { $webpage = "Timeout!\n"; } if ($@ && $@ =~ /No page/) { if ($monitor) { print "404\n"; } `echo "404\n" > TxInputfile`; } else { if (length $webpage > $Maxwebpage) { $webpage = substr ($webpage, 0, $Maxwebpage); $webpage .= "\n-truncated -\n\n"; } my $weblength = length ($webpage); `echo "Your wwwpage: $weblength" >> TxInputfile`; `echo "$webpage \n\n" >> TxInputfile`; `echo "-end-\n" >> TxInputfile`; if ($monitor) { print $webpage; } } } elsif (m/~GETPOS\s*(.*)/) { ####### get position from findu.com ################################# my $poscall = ""; my $webpage = ""; if (-e ".internet") { if (defined $1 && $1) { $poscall = $1; } else { $poscall = get_session(); } my $URL = "http://loudmouth.findu.com/cgi-bin/find.cgi?call="; . $poscall; eval { # $webpage = `lynx -dump -connect_timeout=10 $URL 2>&1` or die "No page"; $webpage = `elinks -dump $URL 2>&1` or die "No page"; print $webpage; }; if ($webpage =~ /^Alert!/m) { $webpage = ""; } } if ($webpage) { if ($@ && $@ =~ /No page/) { if ($monitor) { print "404\n"; } `echo "Sorry, page not available\n" > TxInputfile`; } else { my @positpage = split /\n/, $webpage; my $positline = ""; my @outarray = (); foreach $positline (@positpage) { if ($positline =~ /Position of/) {push @outarray, $positline; } if ($positline =~ /received/) {push @outarray, $positline; } if ($positline =~ /Raw packet/) {push @outarray, $positline; } } $webpage = join "\n", @outarray; `echo "$webpage \n\n" >> TxInputfile`; `echo "-end-\n" >> TxInputfile`; if ($monitor) { print $webpage; } } } else { `echo "Cannot get position\n" >> TxInputfile`; } } elsif (m/~GETMSG\s*(\d*)/) { ####### get messages from findu.com ################################# my $msgnr = ""; if (-e ".internet"){ if ( $1 && $1 > 0) { $msgnr = $1; } else { $msgnr = 10; } my $URL = "http://www.findu.com/cgi-bin/msg.cgi?call="; . get_session(); my $webpage = ""; eval { $webpage = `lynx -connect_timeout=10 -dump $URL 2>&1` or die "No page"; }; if ($webpage =~ /^Alert!/m) { $webpage = "Cannot connect\n";} if ($@ && $@ =~ /No page/) { if ($monitor) { print "404\n"; } `echo "Sorry, page not available\n" > TxInputfile`; } else { my @positpage = split /\n/, $webpage; my $positline = ""; my @outarray = (); my $counter = 0; foreach $positline (@positpage) { if ($positline !~ /\+---/) { push @outarray, $positline; $counter++; if ($counter > $msgnr) { last; } } } $webpage = join "\n", @outarray; `echo "$webpage \n\n" >> TxInputfile`; `echo "-end-\n" >> TxInputfile`; if ($monitor) { print $webpage; } } } else { `echo "Sorry, internet not available\n" > TxInputfile`; } } elsif (m/~MSG (\w*)\s*(\S*\@\S*)\s*(.*)/) { ####### send aprs mail ################################# my $call = $1; getuserdata($call); $to = $2; $subject = "PSKaprs message from $1"; @message = (); push @message, $to; push @message, $address; push @message, $subject; push @message, $3; logprint ("sending mail message to $2\n"); eval { send_mail(@message); # send the mail via smtp }; if ($@) { logprint ("Could not send aprs email message\n"); } } elsif (m/~POSITION (\d+\.\d+) (\d+\.\d+)/) { ####### send position to findu.com ################################# if (-e ".internet") { my $call = get_session(); getuserdata($call); if ($findupasswd) { my $pos_string = "call=$call&passwd=$findupasswd&lat=$1&lon=$2\n"; $to = "posit\@findu.com"; $subject = "none"; @message = (); push @message, $to; push @message, $address; push @message, $subject; push @message, $pos_string; eval { send_mail(@message); # send the mail via smtp }; if ($@) { `echo "Cannot send position: $@" >> TxInputfile`; } else { `echo "\nPosition sent...\n" >> TxInputfile`; @message = (); } } else { `echo "Sorry, no password on file!\n" >> TxInputfile`; } } else { `echo "Sorry, internet not available\n" > TxInputfile`; } } elsif (m/~QUIT/) { ####### Quit connect ################################# logprint ("Disconnect received\n"); # disconnect(); $ConnectStatus = "Disconnected"; open SESSIONDATA, ">PSKmailsession"; print SESSIONDATA $nosession; close SESSIONDATA; } elsif (m/~DELETE(.*)/) { ####### delete message(s) from POP ################################# my @numbers = split / /, $1; eval { delete_mail(@numbers); }; if ($@) { `echo "Cannot delete mail: $@" > TxInputfile`; } else { filter($mailuser, 0); `echo "Mail $1 deleted...\n" >> TxInputfile`; } } elsif (m/~RECx(.*)$/) { ####### Update user database for CALL ################################# my $call = get_session(); eval { my $rec = decode_base64($1); my @values = split (/,/ , $rec); $Pop_host = shift @values; my $record = $Pop_host . ","; $Pop_user = shift @values; $record .= ($Pop_user . ","); $Pop_pass = shift @values; $record .= ($Pop_pass . ","); $record .= ("smtp_host,"); $address = shift @values; $record .= ($address . ","); $mailuser = ".mailuser"; $record .= ($mailuser . ","); $findupasswd = shift @values; chomp $findupasswd; $record .= ($findupasswd . ","); tie (%db, "DB_File", $dbfile) or die "Cannot open user database\n"; $db{$call} = $record; untie %db; }; if ($@) { print "Error in database: $@\n"; } else { print "Updating database for $call\n"; `echo "Updated database for $call" >> TxInputfile`; } } elsif (m/~SEND/) { ####### send message file ################################# my @message = (); # $to, $from, $subject, @body my $mailstatus = "receive"; logprint ("Receiving mail \n"); @body = (); while ($mailstatus eq "receive") { my $readline = <$reader>; if ($readline) { reset_idle(); chomp($readline); if ($monitor) { print $readline, "\n"; } $_ = $readline; if (m/^\.$/) { $mailstatus = "end_of_mail"; @message = (); my $call = get_session(); getuserdata($call); push @message, $to; push @message, $address; push @message, $subject; push @message, @body; # $dummy = pop @body; if ($to =~ /(.*)\@$ServerCall/) { # local mbox print "Local mbox $1\n"; if (-e "localmail/$1") { print "Local mbox $1 exists\n"; } else { `touch "localmail/$1"`; print "Local mbox $1 made\n"; } my $mydate = `date`; my $msg = "From $call $mydate" . "To: $to" . "\n" . "From: $address" . "\n" . "Subject: " . $subject . "\n" . "Date: $mydate" . "\n" . join ("\n", @body) . "\n\n"; my @boxes = ("localmail/$1"); my @delivered_to = Email::LocalDelivery->deliver($msg, @boxes); @message = (); `echo "\nMessage sent...\n" >> TxInputfile`; } else { # internet mbox eval { send_mail(@message); # send the mail via smtp }; if ($@) { `echo "Error sending mail : $@" >> TxInputfile`; } else { `echo "\nMessage sent...\n" >> TxInputfile`; } @message = (); } } elsif (m/~ABORTSEND/) { # in case we are stuck in a loop # stop..... $to = ""; $subject = ""; @body = (); last; } elsif (m/Subject: /) { # add subject my $subjectline = substr($readline, 9); $subject = $subjectline ; } elsif (m/To: /) { # write To: $to = substr($readline, 4); } else { push @body, $readline; } } } # end mail receive } $readline = ""; } else { ####### scheduler ################################# if ($scheduler) { # try the scheduler... $thishour = (gmtime)[2]; if ($thishour != $lasthour) { if ($schedule[$thishour]) { if (get_session() eq $nosession) { my $cmd = ''; my $outfreq = 0; if ($scheduler[0] eq 'C' ) { $cmd = 'H'; # set channel } elsif ($scheduler[0] eq 'M' ) { $cmd = 'E'; # set memory } else { $cmd = 'F'; $outfreq = $freqs[$mins] + $freq_corrections[$mins]; } eval { $error = `rigctl -m $rigtype -r $rigdevice -s $rigrate $cmd $outfreq` or die "cannot use hamlib? $@\n"; }; if ($@) { print "Freq set error?\n"; } } } $lasthour = $thishour; } } ####### scanner ################################# if ($scanner) { scanner(); } ####### beacon ################################ my $minu = (time / 60 ) % 60; # What minute is this ? if ($minu>=0 && $minu <5){ serverbeacons(); } ####### send aprs beacon ################################# if ($Aprs_connect == 1) { if (time() - $systime >= 60 * $posit_time) { ## 10 mins aprs beacon... $systime = time(); # now do what we want.... my ($month, $hour, $min) = (gmtime) [3, 2, 1]; $month = substr (("0" . $month), -2, 2); $hour = substr (("0" . $hour), -2, 2); $min = substr (("0" . $min), -2, 2); my $mytime = $month . $hour . $min . "z"; my $MSG = "$ServerCall" . ">PSKAPRS:" . "@" . $mytime . $Aprs_beacon . "\n"; aprs_send ($MSG); # end } } } # end if 'read' } # end while loop close $reader; waitpid($pid, 0); } else { die "Cannot fork: $!" unless defined $pid; close $reader; pskserver($ServerCall, "$Inputfile", "$output"); close $writer; $error = `killall rflinkserver.pl`; # kill all children still running..... exit; } $error = `killall rflinkserver.pl`; # kill all children still running..... exit (1); ######################################################## sub pskserver { # main, server ######################################################## my ($ServerCall, $Inputfile, $output) = @_; $outputfile = substr ($output, 1); my $STAT = ""; my $teststatus = "Listening"; `cp zb "$Inputfile"`; `cp zb "$outputfile"`; $ConnectStatus = "Listening"; while (1) { logprint ("Listening to the radio\n"); set_txstatus("TXDisconnect"); # just in case... send_frame(); reset_arq(); $ConnectStatus = "Listening"; if ($ConnectStatus eq "Listening") { until (get_rxstatus() eq "Connect_req") { if (get_session() eq $nosession) { if (get_rxqueue()) { my $mystring = get_rxqueue(); printf $writer ("%s", $mystring); reset_rxqueue(); } } eval { local $SIG{ALRM} = sub { die "alarm!!" }; alarm 10; eval { listening(); }; alarm 0; }; alarm 0; die if $@ && $@ !~ /alarm!!/; sleep(1); inc_idle(); if (get_rxstatus() eq "Poll_rx") { set_txstatus("TXAbortreq"); send_frame(); } } if (get_rxstatus() eq "Connect_req") { $ConnectStatus = "Connected"; # send connect_ack set_txstatus("TXConnect_ack"); send_frame(); reset_arq(); my $Reconnect_possible = 0; ## we are now connected print $writer "~ABORTSEND\n"; $call=get_call(); if (index ($Usercalls, $call) < 0) { if (getuserdata ($call) ne "Unknown") { $Usercalls .= $call; # add it to the list of users $Usercalls .= " "; }elsif ($opensystem) { $Usercalls .= $call; # add it to the list of users anyway $Usercalls .= " "; $Pop_host = ""; print "added call to list of known calls\n"; $usrmessage = "pse update your record!\n"; } } $_ = $Usercalls; my @callfrags = split ("\/", $call); foreach my $frag(@callfrags) { if (m/$frag/) { # from Usercalls list if (length($frag) > 3) { $call = $frag; logprint ("Call $call o.k.\n"); open SESSIONDATA, ">PSKmailsession"; print SESSIONDATA $call; # put it away safely close SESSIONDATA; sleep(2); my $mailcall = get_session(); getuserdata($mailcall); $sstate = ""; @ping = (); if (-e ".internet") { unlink ".internet";} eval { # check if internet present @ping = `ping -c 1 google.com 2>/dev/null`; }; if($ping[1] && $ping[1] =~ /(time=\d*\.*\d* ms)/) { $sstate = "I"; `touch .internet`; } if (-e "./localmail/$mailcall") { # see if there is local mail my $folder = Email::Folder->new("./localmail/$call"); my $mails = ""; my $count = 0; for my $msg ($folder->messages) { $count++; } if ($count) { $sstate .= "L$count"; } } if ($Pop_host && -e ".internet") { # check if interner mail my $count = 0; $usrmessage = ""; eval { local $SIG{ALRM} = sub { die "alarm"}; alarm 20; eval { $count = count_mail() ; # get mail from pop server print "$count\n"; }; alarm 0; }; # $count = 0 unless $count; alarm 0; if ($@ && $@ =~ /alarm/) { $usrmessage = " Timeout reading the mail...\n"; } else { if ($count > 1) { $usrmessage = $count . " mails.\n"; } elsif ($count ==1) { $usrmessage = $count . " email.\n"; } elsif ($count < 0) { $usrmessage = "Could not list mail.\n"; } else { $usrmessage = "No mail.\n"; } if (-e "mailheaders") {unlink "mailheaders";} } } if ($count) {$sstate .= "M" . $count}; if ($usrmessage !~ /Could not list mail/) { `echo "$ServerCall $Version-$sstate>\n" > TxInputfile`; } else { `echo "$ServerCall $Version\nHi $call, pse update your record" > TxInputfile`; } $STAT = getuserdata($call); last; } } else { `echo "Sorry, $call not registered...\n" > TxInputfile`; sleep 10; } } $RxReady = 1; $Retries = 0; while ($ConnectStatus eq "Connected") { # Connected loop... until (get_idle() > $Maxidle) { sleep(1); inc_idle(); # update idle counter reset_rxstatus(); eval { local $SIG{ALRM} = sub { die "Alarm!!" }; alarm 10; eval { listening(); }; alarm 0; }; alarm 0; die if $@ && $@ !~ /Alarm!!/; $RxStatus = get_rxstatus(); if (check_lastblock()) { last; } } $RxStatus = get_rxstatus(); $txqlen = gettxtqueue(); if ($RxStatus eq "Abort") { $ConnectStatus = "Listening"; last; } elsif ($RxStatus eq "Status_rx"){ if ($txqlen) { $RxReady = 1; $Retries = 0; } else { $RxReady = 1; $Retries++; } } elsif ($RxStatus eq "Poll_rx"){ $RxReady = 0; $Retries++; set_txstatus ("TXStat"); send_frame(); } elsif ($RxStatus eq "Connect_req"){ $Reconnect_possible++; $Retries = 0; if ($Reconnect_possible >= 1) { $Reconnect_possible = 0; print "Reconnect received!!\n"; $ConnectStatus = "Listening"; last; } } elsif ($RxStatus eq "Disconnect_req"){ disconnect(); set_txstatus("TXDisconnect"); send_frame(); reset_rxstatus; $ConnectStatus = "Listening"; $Retries = $Max_retries; } my $mystring = get_rxqueue(); printf $writer ("%s", $mystring); if ($mystring) { $Retries = 0; } reset_rxqueue(); $Maxidle = get_maxidle(); # send next frame inc_idle(); my $session_status = get_session(); if ($session_status eq "none" || $session_status eq "beacon") { last; # outta here... } if (get_idle() > $Maxidle) { # send poll frame set_txstatus("TXPoll"); send_frame(); $Retries++; $RxReady = 0; } if ($RxReady == 1 ) { $RxReady = 0; if ($txqlen) { $Retries = 0; } $outputstring = gettxinput(); set_txstatus("TXTraffic"); send_frame($outputstring); if ($outputstring) { $Retries = 0; } $outputstring = ""; } if ($Retries >= $Max_retries) { set_txstatus("TXDisconnect"); send_frame(); disconnect(); $ConnectStatus = "Listening"; reset_rxstatus; $ConnectStatus = "Listening"; $Retries = 0; } if ($ConnectStatus ne "Connected") { print "Disconnected\n"; open SESSIONDATA, ">PSKmailsession"; print SESSIONDATA $nosession; close SESSIONDATA; $ConnectStatus = "Listening"; last; } } ## connect ended } } } } ######################################################## sub get_serverstatus { ######################################################## return $ConnectStatus; } ######################################################## sub count_mail { ####################################### my $validconnect = 0; $stationname = get_session(); getuserdata($stationname); if ($Pop_host =~ /gmail/i) { $Use_ssl = 1; } if ($Use_ssl) { $gmailuser = $Pop_user . "@" . "gmail.com"; } else { $gmailuser = $Pop_user; } my $pop = new Mail::POP3Client (USER => $Pop_user, PASSWORD => $Pop_pass, HOST => $Pop_host, USESSL => $Use_ssl, ); $count = $pop->Count(); if ($count > -1) { $pop->Reset; } return $count; } ######################################################## sub list_mail { ####################################### my $validconnect = 0; my $hdr = ""; my $pop = ""; $stationname = get_session(); getuserdata($stationname); if ($debug_mail) {print "$Pop_host|\n";} if ($Pop_host =~ /gmail/i) { $Use_ssl = 1; } if ($Use_ssl) { $gmailuser = $Pop_user . "@" . "gmail.com"; } else { $gmailuser = $Pop_user; } print "USER=$gmailuser\n"; $pop = new Mail::POP3Client (USER => $gmailuser, PASSWORD => $Pop_pass, HOST => $Pop_host, USESSL => $Use_ssl, ); if ($pop->Count() > -1) { logprint ("Pop defined\n"); $validconnect = 1; } if ($debug_mail) {print "$Pop_user,$Pop_pass|\n";} if ($validconnect) {logprint ("Authenticated\n");} $Count = $pop->Count; print "Count=$Count\n"; if ($Count) { logprint ("Got message list\n"); `echo '' > $mailuser`; }; open (HFH, ">mailheaders"); open (MFH, ">>$mailuser"); print HFH "\n"; print MFH "\n"; for ($i =1; $i <= $Count; $i++) { my (@msg, $subject, $sender, $from); my $headerlength = 0; @msg = $pop->Head($i); $subject = $sender = ''; foreach $hdr (@msg) { $headerlength += length ($hdr); if ($hdr =~ /^Subject:\s+/i) { $subject = substr($hdr, 8); } if ($hdr =~ /^From:\s+/i) { $sender = substr($hdr, 6); ($from = $sender) =~ s{<.*>}{}; if ($from =~ m{\(.*\)}) {$from = $hdr; } $from ||= $sender; } } my $messagecontent = $pop->Head($i, 999); my $mesglength = length ($messagecontent) - ($headerlength + 100); my $headerline = sprintf ("%2.0d %-30.30s %-60.60s %d\n", $i, $from, $subject, $mesglength); print HFH $headerline; if ($monitor && $debug_mail) { print $headerline; } my $fromline = sprintf ("%-20.20s %2.0d %-55.55s ", $from, $i, $subject); print MFH "From $fromline $mesglength Bytes\n"; print MFH @$messagecontent; $mymailnumber = $i; } print HFH "\n"; print MFH "\n"; close (HFH); close (MFH); $pop->Close; # keep the mail for the moment } # end list_mail ######################################################## sub read_mail { ####################################### my @numbers = @_; my $fault = 0; my $gmailuser = ""; my $messagecontent; my $pop; getuserdata(get_session()); if ($Pop_host =~ /gmail/i) { $Use_ssl = 1; } if ($Use_ssl) { $gmailuser = $Pop_user . "@" . "gmail.com"; } else { $gmailuser = $Pop_user; } print "USER=$gmailuser\n"; $pop = new Mail::POP3Client (USER => $gmailuser, PASSWORD => $Pop_pass, HOST => $Pop_host, USESSL => $Use_ssl, ); `echo '' > $mailuser` ; open (MFH, ">>$mailuser"); foreach my $msgid (@numbers) { my (@msg, $subject, $sender, $from, $dte); if ($msgid !~ /\d+/) { next; } if ($gmailuser) { $messagecontent = $pop->Head($msgid, 999); } else { $messagecontent = $pop->HeadAndBody($msgid); } if ($messagecontent) { print MFH "\n\nFrom \n"; print MFH $messagecontent; } else { if ($monitor) { print "failed \n"; } `echo "Message not available\n"`; } $mymailnumber = $msgid; } close (MFH); $pop->Reset; # keep the mail for the moment } # end read_mail ##################################################### sub delete_mail { ##################################################### my @delmessages = @_; getuserdata(get_session()); if ($Pop_host =~ /gmail/i) { $Use_ssl = 1; } if ($Use_ssl) { $gmailuser = $Pop_user . "@" . "gmail.com"; } else { $gmailuser = $Pop_user; } my $pop = new Mail::POP3Client (USER => $Pop_user, PASSWORD => $Pop_pass, HOST => $Pop_host, USESSL => $Use_ssl,); foreach $msgid(@delmessages) { if ($msgid) { $pop->Delete($msgid) ; } } $pop->Close; } # end delete_mail ##################################################### sub getuserdata { ##################################################### tie (%db, "DB_File", $dbfile) or die "Cannot open user database\n"; tie (%visitors, "DB_File", ".visitors") or die "Cannot open visitors database\n"; $key = shift @_; if (exists $db{$key}) { $Value = $db{$key}; } else { my $record; eval { local $SIG{ALRM} = sub { die "timeout" }; alarm 10; eval { $record = `elinks -dump -dump-width 120 $dbaddress$ServerCall:$dbpass:$key 2>/dev/null` or die; }; }; alarm 0; if ($@ && $@ =~ /timeout/){ return "Unknown"; } if (length $record < 13 ) { print "Could not find record\n"; $Pop_host = ""; return ("Unknown"); } else { $record =~ m/(\w.*)END/; $record = $1; my @dbvalues= split ", ", $record; if ($dbvalues[2] =~ /(.*)\@/) { $dbvalues[2] = $1; } $Value = $dbvalues[1] . "," # host . $dbvalues[2] . "," # user . $dbvalues[3] . "," # pass . $relay . "," # smtp . $dbvalues[5] . "," # from . $mailuser . "," # mailuser file . $dbvalues[4]; $db{$key} = $Value; # set record in db $visitors{$key} = time; } } my @values = split (/,/ , $Value); $Pop_host = shift @values; $Pop_user = shift @values; if ($Pop_user =~ /(.*)\@/) { $Pop_user = $1; } $Pop_pass = shift @values; # $relay = shift @values; my $dump = shift @values; $address = shift @values; $mailuser = shift @values; $findupasswd = shift @values; foreach $key (keys %visitors) { if (time - $visitors{$key} > 130000) { delete $visitors{$key}; # give them 36 hours... delete $db{$key}; } } untie %db; untie %visitors; return @values; } ######################################################### sub getusercalls { ######################################################### tie (%db, "DB_File", $dbfile) or die "Cannot open user database\n"; $Usercalls = ""; foreach my $callkey (keys %db) { $Usercalls .= $callkey; $Usercalls .= " "; } untie %db; } #end ################################ sub filter { ################################ # in = $mailuser, out = mailfile ################################ my $inputfile = shift @_; my $html = shift @_; my @fromarray; my @subjectarray; my $datearray; my @headerarray; my $counter = -1; my $line; my @testarray = (); @msgarray = (); my @craps = (); init_crap_filter (); # fills craps array with text scraps open (INP, $inputfile); my @mailtest = <INP>; close (INP); my $quiet = 1; my $subjdone = 0; my $datedone = 0; my $fromdone = 0; my $mesgstart = 0; foreach $line (@mailtest) { $line =~ s/\015//g; $_ = $line; if (m/^From /) { $quiet = 1; $counter++; $subjdone = 0; $datedone = 0; $fromdone = 0; $mesgstart = 1; # $msgarray[$counter] .= $line; if ($monitor) { print $line; ##debug } } next unless $mesgstart; if ($line eq "\n" || $line eq "\r\n") { if ($counter >= 0) { $msgarray[$counter] .= $line; } $quiet = 0; if ($monitor) { print $line; ##debug } } if (m/^From: / && $fromdone == 0) { if ($counter >= 0) { $msgarray[$counter] .= $line; } $fromdone = 1; if ($monitor) { print $line; ##debug } } elsif (m/^Subject:/ && $subjdone == 0) { if ($counter >= 0) { $msgarray[$counter] .= $line; } if ($counter >= 0) { $subjectarray[$counter] .= $line; } $subjdone = 1; if ($monitor) { print $line; ##debug } } elsif (m/^Date:/ && $datedone == 0) { if ($counter >= 0) { $msgarray[$counter] .= $line; } $datedone = 1; if ($monitor) { print $line; ##debug } } else { if ($quiet == 0) { if ($counter >= 0) { $line =~ s/\n\n/\n/; $line =~ s/\r\n/\n/; $msgarray[$counter] .= $line; } if ($monitor) { print $line; ##debug } } } } open (OUTP, ">mailin"); print OUTP @msgarray; close (OUTP); open (MAILF, "mailin"); # html filter open (MAILOUT, ">mailfile"); while (<MAILF>) { if ($html == 0 && m#<HTML#i ... m#</HTML#i) { if ($monitor) { print $_; } } else { my $in = crapfilter ($_); print MAILOUT $in; } } close (MAILOUT); close (MAILF); `cp mailfile mailtest`; } #end filter ################################################ sub crapfilter { ################################################ my $line = shift @_; if ($craps[0]) { $line =~ s/=\?\?Q\?//; $line =~ s/\?Q\?//; $line =~ s/\?iso-8859-1\?q\?//; $line =~ s/=\?iso-8859-1\?Q\?//; $line =~ s/=09//; $line =~ s/=20//; $line =~ s/=22//; $line =~ tr/\r//; $line =~ s/^\s+\n/\n/; if ($line =~ /^>/ ) { return (""); } foreach $scrap (@craps) { chomp $scrap; if ($line =~ /$scrap/) { return (""); } } } return $line; } ################################################################# sub init_crap_filter { # fills array with text scraps ################################################################# if (-e "crapmail.txt") { open ($nfh, "crapmail.txt"); @craps = <$nfh>; close ($nfh); } else { print "Can not find file: crapmail.txt\n"; } } ################################################################# ############################################################ # Function for sending mail for systems without an MTA sub send_mail { ############################################################ my($to, $from, $subject, @body)= @_; my $mycall = get_session(); print "Mycall =$mycall\n"; getuserdata($mycall); logprint ("RELAY=$relay|\n"); my $smtp = Net::SMTP->new($relay, Debug => $debug_mail); die "Could not open connection: $!" if (! defined $smtp); $smtp->mail($from); $smtp->to($to); $smtp->data(); $smtp->datasend("To: $to\n"); $smtp->datasend("From: $address\n"); $smtp->datasend("Subject: $subject\n"); $smtp->datasend("\r\n"); foreach(@body) { $smtp->datasend("$_\n"); } $smtp->dataend(); $smtp->quit; } ########### end smtp ###################### ########################################### sub get_session { ########################################### open SESSIONDATA, "PSKmailsession"; my $session = <SESSIONDATA>; chomp $session; close SESSIONDATA; return $session; } ############################################## sub scanner { ############################################## $hour = (time / 3600) % 24; if ($hour != $oldhour) { if (-e "./qrg/freqs.txt") { open ($fh, $qrgfile) or die "Cannot open the scanner file!"; @freqhrs = <$fh>; close ($fh); $cat = $freqhrs[0]; print $cat; chomp $cat; @freqs = split (",", $cat); my $pskmodes = $freqhrs[1]; print $pskmodes, "\n"; @modes = split (",",$pskmodes); } $oldhour = $hour; } $mins = ((time / 60) + $freq_offset) % 5 ; if ($mins != $oldmins) { if (get_session() eq $nosession) { my $cmd = ''; my $outfreq = 0; if ($scanner eq 'C' ) { $cmd = 'H'; # set channel } elsif ($scanner eq 'M' ) { $cmd = 'E'; # set memory $outfreq = $freqs[$mins]; $modem = $modes[$mins]; } else { $cmd = 'F'; $outfreq = $freqs[$mins] + $freq_corrections[$mins]; $modem = $modes[$mins]; } eval { #print `rigctl -m $rigtype -r $rigdevice -s $rigrate $cmd $outfreq`; $error = `rigctl -m $rigtype -r $rigdevice -s $rigrate $cmd $outfreq` or die "cannot use hamlib? $@\n"; }; if ($@) { # print "Freq set error?\n"; # print "$error\n"; } #print "rigctl -m $rigtype -r $rigdevice -s $rigrate $cmd $outfreq"; setmode($modem); # set fldigi mode # set_autotune(1); # Remember that a fq change has taken place } } $oldmins = $mins; # } } ############################################## sub oldserverbeacon { ############################################## my $realmin = (time / 60 ) % 60; if ($realmin == $Beaconminute && $Beacon_sent == 0) { sleep 1; # settle the tx # send beacon print "Sending beacon\n"; set_txstatus("TXBeacon"); send_frame(); $Beacon_sent = 1; } elsif ($realmin == $Beaconminute+1){ $Beacon_sent = 0; } } ############################################## # Check the beacons array and send a beacon if the current minute is 0-4 (array size) # and that array segment is 1. Update the status array to reflect beacon sent status. # 2007-01-19, SM0RWO/Pär Crusefalk sub serverbeacons { ############################################## my $trigger = 0; # set to 1 if its time for a beacon my $n = 0; # Used to loop the arrays my $realmin = (time / 60 ) % 60; # What minute is this ? # Loop the array, this is potentially dangerous if the array is not # set according to spec (should check that). # while ($Beaconarray[$n]) foreach (@Beaconarray) { if ($realmin == $n) { if ($Beacons_sent[$n] == 0 && $_ == 1) { $trigger=1; # Time for a beacon $Beacons_sent[$n]=1; # Set the current minute as done } $Beacons_sent[$n-1]=0; # Set the minute before (or wrap around) as unsent #print "Minut: $realmin sent: @Beacons_sent Beaconarray: @Beaconarray..\n"; } $n++; } # Send the beacon if triggered and no session if ($trigger == 1 && get_session() eq $nosession) { sleep 1; # settle the tx # send beacon print "Sending beacon\n"; set_txstatus("TXBeacon"); send_frame(); } } ################################################ sub setmode { ################################################ #return # temporarily my $pskmode =shift @_; my $modemstring = "\<cmd\>\<mode\>" . $pskmode . "\</mode\>\</cmd\>\n"; #print $modemstring; open (CMDOUT, $output); print CMDOUT $modemstring; close (CMDOUT); open (CMDOUT, ">.modem"); print CMDOUT $modemstring; close (CMDOUT); } ################################################ sub getbeacons { ################################################ my $ClientCall = shift @_; `cat server.log | grep "$ClientCall" > .mylines`; my $now = time(); my $then = time(); $then -= 60 * 60 * 12; my %beaconhours = (); my $j = int ($then/(3600) % 24); my $k = int ($now/(3600) % 24); my $m = 0; if ($j > $k) { $k += 24; $m = 1; } for (my $i = $j; $i <= $k; $i += 1) { $beaconhours{$i} = 0; } open (LOG, ".mylines"); while (my $input = <LOG>) { if ($input =~ /((\d\d):(\d\d)\s\w*\s(\w\w\w)-(\d*)-(\d\d\d\d): <SOH>..u\S*:26 .\d\d\d\d\.\d\d\w)/) { my $month = monthnumber($4); my $hour = $2; my $mins = $3; my $epoch = timegm (0, $mins, $hour, $5, $month, $6); if ($epoch > $then) { my $beaconhour = int ($epoch/(3600) % 24); if ($m && $beaconhour < 13) { $beaconhour += 24;} $beaconhours{$beaconhour}++; } } } close (LOG); my $index; my $b_outstring = ""; foreach my $beacon(sort {$a <=> $b} keys %beaconhours) { if ($beacon > 23) { $index = $beacon - 24; } else { $index = $beacon; } $b_outstring .= $beaconhours{$beacon}; } $b_outstring .= "|"; $b_outstring .= $index; $b_outstring .= " UTC\n"; return $b_outstring; } # end ############################################### sub monthnumber { ############################################### my $mon = shift @_; my $count = 0; my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); foreach $month (@months) { if ($month =~ /$mon/i) { last; } $count++; } return $count; } # end ###############################################
############################################### Check the beacons array and send a beacon if the current minute is 0-4 (array size)# and that array segment is 1. Update the status array to reflect beacon sent status.# 2007-01-19, SM0RWO/Pär Crusefalksub serverbeacons {############################################## my $trigger = 0; # set to 1 if its time for a beacon my $n = 0; # Used to loop the arrays my $realmin = (time / 60 ) % 60; # What minute is this ? # Loop the array of beacon minutes foreach (@Beaconarray) { if ($realmin == $n) { if ($Beacons_sent[$n] == 0 && $_ == 1) { $trigger=1; # Time for a beacon $Beacons_sent[$n]=1; # Set the current minute as done } $Beacons_sent[$n-1]=0; # Set the minute before (or wrap around) as unsent } $n++; } # Send the beacon if triggered and no session if ($trigger == 1 && get_session() eq $nosession) { sleep 1; # settle the tx # send beacon print "Sending beacon\n"; set_txstatus("TXBeacon"); send_frame(); }}