#! /usr/bin/perl

# tpaged -- back-end to tpage system.
#   by Tom Limoncelli, tal@warren.mentorg.com
#   Copyright (c) 1992, Tom Limoncelli
#   The sources can be freely copied for non-commercial use only
#   and only if they are unmodified.

# Version 2.0 -- See file HISTORY for details. 

####################################################################
#
# Parameters that the user can set:
#
####################################################################

$debug = 0;
$| = 1; open( STDOUT, ">/var/log/tpage.log" ) if $debug; $| = 1;
$QUEUE_DIR = '/usr/local/etc/tpage/pqueue/';		# same as in tpage.pl
#$IXOCICO = '/home/tal/work/beep2/ixocico';		# where is ixocico?
$IXOCICO  = '/usr/local/etc/tpage/ixocico';		# where is ixocico?
$MAIL = '/usr/mail';						# which mail to use?
     # Recommended mailers:  SunOS & BSD's:  /usr/ucb/mail, AT&T Unix's xmail
     # Not recommended mailers:  /bin/mail

# list of devices to rotate through.
@DEVICES = ( "/dev/tty05" );	# currently they are all spoken
# to at the same speed and same parameters.  Some day I'll set up
# a modemtab system, but I don't think more than one modem is
# really needed for this system.

# amount of time to sleep between scans of the queue
$SLEEP_TIME =  150;	# 2.5 minutes
$SLEEP_TIME =  10 if $debug;	# smaller when I'm debugging
# Small amount of time to wait between finding anything in the queue
# and doing a real scan of the queue.
$MULT_SLEEP_TIME =  10;

####################################################################
# QUEUE FILES FORMAT:
#
# Files in the queue have the name of the format in the
# first line.  Currently there is only one format and it
# is named "A".  The first line marks it as the "A" format.
# a subroutine called read_format_A reads this format.  Other
# formats can be written (see comments by read_format_A)
#
# The "A" format:
# line  contents
#    1: A\n
#    2: number to dial\n
#    3: pin\n
#    4: entire message\n
#    5: X\n

# read_format_*  -- modules that read various data formats.
#                   Currently implemented: The "A" format.
# do_proto_*     -- modules that do various beeper protocols.
#                   Currently implmented: the ixo protocol.
#                   Future protocols:     numeric-only pagers.

####################################################################
# Here's the actual program

# define some globals

local(%protocols);

while (1) {
	local ($first, @allfiles, @anyfiles);

	# We could scoop up all the files and process them, but chances
	# are if one file is found, more are on the way.  So, instead
	# we scoop, if any are found we sleep 5 seconds and re-scoop.

	# wait for any files to appear.
	while (1) {
		@anyfiles = &scan_queue;
		print "DEBUG: anyfiles= ", join(' ', @anyfiles), "\n" if $debug;

		if ($#anyfiles!=-1) {	# files?  take a rest and then process.
			sleep $MULT_SLEEP_TIME unless $debug;
			last;
		} else {			# no files?  hibernate.
			sleep $SLEEP_TIME;
			next;
		}
	}

	# re-get the files in the queue
	@allfiles = &scan_queue;
	print "DEBUG: allfiles= ", join(' ', @allfiles), "\n" if $debug;

	# get all the data out of the queue'd files.
	foreach $file (@allfiles) {
		print "DEBUG: Doing $file\n" if $debug;
		open(DATA, "<" . $QUEUE_DIR . $file) || print "Can't open $file: $!";
		chop( $first = <DATA> );
print "DEBUG: first=$first\n" if $debug;
		eval "do read_format_$first()";
	}

	# process all the extracted data (do_protocol_* should delete the files)
	foreach $proto (keys %protocols) {
		eval "do do_protocol_$proto()";
		delete $protocols{ $proto };
		sleep $SLEEP_TIME;
	}
}

# scan the queue for entries (avoid "blacklisted" files)
sub scan_queue {
	local(@files);
	# scan the directory for "P files (pager files)
	opendir(QDIR, $QUEUE_DIR) || die "$0: Can't open $QUEUE_DIR: $!";
	@files = grep( /^P/, readdir(QDIR) );
	closedir(QDIR);
	print "DEBUG: filescan= ", join(' ', @files), "\n" if $debug;
	# remove the blacklisted files
	@files = grep( ! defined $blacklist_data{ $_ }, @files);
	print "DEBUG: goodfiles= ", join(' ', @files), "\n" if $debug;
	# return the files
	@files;
}

# blacklist a file in the queue (couldn't delete it for some reason
# and we don't want to repeat it)
sub blacklist {
	local($file) = @_;
	$blacklist_data{ $file } = 1;
}

# Each read_format_ must:
#  read from <DATA> and then close(DATA).
#  %protocols{ protocol name } = 1 (for the protocol to use)
#  and stuff the right data into the right variables for that protocol
#  to use.

sub read_format_A
{
	local($dial,$pin,$error,$mess,$X);	# $file is by sideeffect
	print "DEBUG: reading format A\n" if $debug;
	chop( $dial = <DATA> );
	chop( $pin = <DATA> ); 
	chop( $error = <DATA> );
	chop( $mess = <DATA> );
	chop( $X = <DATA> );

	return if $X ne "X";  # file isn't in correct format or isn't done.
	return if $dial eq "";
	return if $pin eq "";
	return if $mess eq "";

	$protocols{ 'ixo' } = 1;
	&ixo_mesg_append( $dial, $pin, $error, $mess, $file );
}

# Each do_protocol_ must:
#  delete files out of the queue that are successful.
#  delete files out of the queue that are aged.
#  clean up so that the routine can be called again.

sub do_protocol_ixo {
	print "DEBUG: doing protocol IXO\n" if $debug;
	local($pin, $error, $mess, $file, $cmd, $status, $index);
	local($general_reject, $general_error_message);
	# build the temp file and the command line
	local($tmpfile) = "/tmp/tpaged.$$";
	foreach $dial ( &ixo_listphones ) {
		print "DEBUG: Number to dial is $dial\n" if $debug;

		# fill the data file
		open(IX, ">$tmpfile" ) || die "$0: Can't create $tmpfile: $!";
		foreach $index ( &ixo_listindexes( $dial ) ) {
			($pin, $error, $mess, $file) = &ixo_mesg_get( $dial, $index );
			# put it in the file for ixocico to use
			print IX "$pin\n$mess\n";
		}
		close IX;

		print "DEBUG: messages to send", &ixo_listindexes( $dial ), "\n" if $debug;

		$general_reject = 1;	# when done, 1=cancel remaining; 0=retry remaining
		$general_error_message = "SHOULD NOT HAPPEN";	# if all messages are cancelled

		$cmd = $IXOCICO . " <" . $tmpfile . " "
			. push(@DEVICES, shift @DEVICES) . " " . $dial;
		print "DEBUG: About to execute: $cmd\n" if $debug;
		open(IX, $cmd . "|") || die "$0: Can't execute ixocico: $!";

		while (<IX>) {
			print if $debug;
			next unless /^#/;

			print unless $debug;

			/^#WRONGARGS / &&
				die("$0: Major program bug: $!");
			/^#NOCONN / && do {
				printf("$0: Nobody answered the phone!\n") if $debug;
				$general_reject = 0;
				last;
			};
			/^#UNKNOWNPROTO / && do {
				print "$0: Uhhh, are you sure that's a pager service?\n" if $debug;
				$general_reject = 1;
				$general_error_message = "other end using different protocol";
				last;
			};
			/^\#MESOK (\d) / && do {
				$index = $1;
				print "DEBUG: message $index done.\n" if $debug;

				($pin, $error, $mess, $file) = &ixo_mesg_get( $dial, $index );
				print "DEBUG: ERROR=$error; FILE=$file\n" if $debug;

				print "DEBUG: unlinking " . $QUEUE_DIR . $file . "\n" if $debug;
				$status = unlink $QUEUE_DIR . $file;
				print "DEBUG: unlink status=$status; $!\n" if $debug;
				&blacklist( $file) unless $status;

				# remove from queue
				&ixo_mesg_delete( $dial, $index );
			};
			/^#MESREJECT (\d) / && do {		# very similar to #MESOK
				$index = $1;
				print "DEBUG: message $index rejected.\n" if $debug;

				($pin, $error, $mess, $file) = &ixo_mesg_get( $dial, $index );
				print "DEBUG: ERROR=$error; FILE=$file\n" if $debug;

				# notify anyone that wants to know about failures
				if ($error + 0) {
				     $cmd = "$MAIL <"
                     . $QUEUE_DIR . $file
                     . " -s 'TPAGE_MESSAGE: request rejected by service' "
                     . $error;
					print "DEBUG: About to execute $cmd\n" if $debug;
					system $cmd;
				}

				print "DEBUG: unlinking " . $QUEUE_DIR . $file . "\n" if $debug;
				$status = unlink $QUEUE_DIR . $file;
				print "DEBUG: unlink status=$status; $!\n" if $debug;
				&blacklist( $file) unless $status;

				# remove from queue
				&ixo_mesg_delete( $dial, $index );
			};
			/^#FORDIS / && do {
				print "Forced disconnect from server.\n" if $debug;
				$general_reject = 1;
				$general_error_message = "other end requesting disconnect";
				last;
			};
			/^#PROTERR / && do {
				print "Server not following protocol.\n" if $debug;
				$general_reject = 1;
				$general_error_message = "other end having a protocol error";
				last;
			};
			( /^#DONE / || /#BYE / ) && do {
				print "Done with sending batch.  Waiting BYE.\n" if $debug;
				$general_reject = 0;
				$general_error_message = "been told we're done but weren't".
				next;
			};
			/^#WRONGANY / && do {
				print "We've been notified that one of the batch may have been not xmited.\n(great protocol, eh?)\n" if $debug;
				next;
			};
			/^#BADQUEUE / && do {
				die "$0: Programmer error.  Data in queue is bad: $_\n";
			};
			/^#MODOPEN / && do {
				print "Modem can't be opened\n" if $debug;
				$general_reject = 0;
				last;
			};
			/^#PACKLEN / && do {
				die "$0: Protocol error.  Should never happen: $_\n";
			};
			/^#GOTMESSEQ / && do {
				print "MESSAGE: $_\n" if $debug;
			};
			/^#LONELY / && do {
				print "Hello?  Hello?  Either I'm getting the silent treatment or the server is dead." if $debug;
				$general_reject = 0;
				last;
			};
		}
		close IX;
		unlink $tmpfile;

		print "DEBUG: rejecting remaining messages\n" if $debug;
		# now reject remaining messages
		foreach $index ( &ixo_listindexes( $dial) ) {
			# if general_reject then we have work to do
			if ($general_reject) {
				print "DEBUG: removing $dial:$index\n" if $debug;
				($pin, $error, $mess, $file) = &ixo_mesg_get( $dial, $index );
				###### mail a warning
				if ($error + 0) {
				     $cmd = "$MAIL <"
                     . $QUEUE_DIR . $file
                     . " -s 'TPAGE_MESSAGE: unprocessed message deleted due to "
                     . $general_error_message . "' "
                     . $error;
					print "DEBUG: About to execute $cmd\n" if $debug;
					system $cmd;
				}
				###### make sure it gets deleted
				print "DEBUG: unlinking (leftover) " . $QUEUE_DIR . $file . "\n" if $debug;
				$status = unlink $QUEUE_DIR . $file;
				print "DEBUG: unlink status=$status; $!\n" if $debug;
				&blacklist( $file) unless $status;
			}
			print "DEBUG: deleting from memory $dial:$index\n" if $debug;
			# delete it from the ixo list
			&ixo_mesg_delete( $dial, $index );
		}
		# at this point %ixo_data should be empty
		&ixo_end_asserts;


	# now do the next phone number
	}
}

sub ixo_end_asserts {
	# test a couple assertions
	print "DEBUG: testing assertions\n" if $debug;

	# $ixo_count{ $dial } should be zero
	die "$0: bug1\n" if $ixo_count{ $dial };

	# %ixo_data should be empty at this point
	die "$0: bug2\n" if grep(1,keys %ixo_data);	# fast key counter
}

sub ixo_mesg_append {
	local($dial, $pin, $error, $mess, $file, $count) = @_;
	print "APPEND: dial=$dial pin=$pin error=$error file=$file mess=$mess\n" if $debug;
	$count = 0 + $ixo_count{ $dial }++;
	$ixo_data{ "$dial:$count" } = "$pin\n$error\n$mess\n$file";
	print "APPEND: data=", $ixo_data{ "$dial:$count" }, "\n" if $debug;
}

sub ixo_mesg_get {
	local($dial, $index) = @_;
	local($pin, $error, $mess, $file, @list);
	print "GET: dial=$dial index=$index\n" if $debug;
	@list = split( '\n', $ixo_data{ "$dial:$index" } );
	($pin, $error, $mess, $file) = @list;
	print "GET: pin=$pin error=$error file=$file mess=$mess\n" if $debug;
	@list;
}

sub ixo_mesg_delete {
	local($dial, $index) = @_;
	print "DELETE: dial=$dial, index=$index\n" if $debug;
	delete $ixo_data{ "$dial:$index" };
	$ixo_count{ $dial }--;
}

sub ixo_listindexes {
	local($dial) = @_;

	# gather and sort the second field
	sort grep( s/^$dial:(.+)/$1/, keys %ixo_data );
}

sub ixo_listphones {
	local(@list);
	local($l) = undef;

	# gather and sort the first field.
	@list = sort grep( s/^(.+):.+$/$1/, keys %ixo_data );
	# uniq them
	@list = grep (!($_ eq $l || ($l = $_, 0)), @list );
	# return them
	@list;
}