#!__PERL__
# -*- perl -*-

# Copyright (c) 2002 by Jeff Weisberg
# Author: Jeff Weisberg <argus @ tcp4me.com>
# Date: 2002-Apr-02 23:12 (EST)
# Function: cgi frontend (will run as cgi-bin or as mod_perl)
#
# $Id: cgi,v 1.81 2005/04/09 01:22:47 jaw Exp jaw $

use lib('__LIBDIR__');

use CGI;

package Argus::Web;
use Argus::Ctl;
use Argus::Encode;
use Fcntl;
use Socket;
use POSIX;
use __DATABASE__;
require "conf.pl";
require "web_misc.pl";
require "web_acl.pl";
require "__AUTH_FILE__";
require "localization.pl";

unshift @INC, "$datadir/perl";
eval{ require "web_customizations.pl" };

$NAME = "Argus";
$COOKIENAME = 'argus';
$WEBCACHE = "$datadir/html";
$LOGFILE = "$datadir/log";
$AUTHDB  = "$datadir/auth";
$AUTH_EXPIRE = 3600 * 24 * 28;

my $connected  = 0;
my $cookie_verbose = 0;
my $lang_conf = undef;
my %auth;

my %fnc_dispatch =
         #    function,    need authcookie
(
 error       => [\&web_error,       0 ],
 default     => [\&web_home,	    0 ],
 home        => [\&web_home,        0 ],
 login       => [\&web_login,       0 ],
 logout      => [\&web_logout,      1 ],
 page        => [\&web_page,        1 ],
 graph       => [\&web_graph,       1 ],
 graphpage   => [\&web_graphpage,   1 ],
 flushcache  => [\&web_flushcache,  1 ],
 about       => [\&web_about,       1 ],
 dispconf    => [\&web_getconf,     1 ],
 annotate    => [\&web_annotate,    1 ],
 rmannotate  => [\&web_annotate,    1 ],
 override    => [\&web_override,    1 ],
 rmoverride  => [\&web_rmoverride,  1 ],
 logfile     => [\&web_logfile,     1 ],
 ntfylist    => [\&web_ntfylist,    1 ],
 ntfylsua    => [\&web_ntfylsua,    1 ],
 ntfydetail  => [\&web_ntfydetail,  1 ],
 ntfyack     => [\&web_ntfyack,     1 ],
 hushsiren   => [\&web_hushsiren,   1 ],
 );

# names of "interesting" fields
my @hl_fields = qw(ovstatus status srvc::lasttesttime
		 srvc::reason srvc::result test::currvalue);

my $TZ = $ENV{TZ};

if( $ENV{'MOD_PERL'} ){
    # running under mod_perl
    CGI->compile(':all');
    ma_init() if defined &ma_init;
    return 1;
}else{
    # running as cgi program
    init();
    handler(0);
    disconnect_from_server();
    exit;
}

sub init {
    # connect to server
    connect_to_server();
}

sub handler {
    my $r = shift;
    my( $x, $f, $fnc, $q );

    if( $ENV{'MOD_PERL'} && !$connected ){
	init();
    }
    
    if( $r ){
        Apache->request($r);
        $q = new CGI;
    }else{
        $q = new CGI;
    }
    
    $x = { r  => $r,				# Apache request
           q  => $q,				# CGI query
           ci => $q->cookie($COOKIENAME),	# input cookie
	 # co =>				# output cookie
	 # auth =>				# authentication data
	 # header =>				# have we sent an http header
       };
    bless $x, 'Argus::Web';
    
    $f = $q->param('func')   || 'default';
    $fnc = $fnc_dispatch{$f} || $fnc_dispatch{error};
    $^T = time();

    tie_auth();
    $x->validate_cookie();
    if( $x->{prefs}{TZ} ne $TZ ){
	$ENV{TZ} = $x->{prefs}{TZ};
	tzset();
    }
    # set desired language
    init_l10n($x, $x->{prefs}{LANG} || $lang_conf || $ENV{LC_ALL} || $ENV{LC_ARGUS} || $ENV{LANG} || 'default');
    
    # if func requires cookie, and we don't have one, force login
    if( $fnc->[1] && ! $x->{auth}{user} ){
        $fnc = $fnc_dispatch{home};
    }

    # print STDERR "[$$] func $f\n";
    
    eval {
	$fnc->[0]->( $x );
	$x->error('an unknown error occurred') unless $x->{header};
    };
    if( $@ ){
	print STDERR "ERROR: $@\n";
    }
    
    if( $ENV{'MOD_PERL'} && $x->{prefs}{TZ} ne $TZ ){
	# put it back, or things get confused under mod_perl
	$ENV{TZ} = $TZ;
	delete $ENV{TZ} unless $TZ;
	tzset();
    }
    untie_auth();
}

sub validate_cookie {
    my $me = shift;
    my( $c, $p );
    
    $me->{auth} = {};
    delete $me->{ci} if $me->{ci} eq 'invalid';

    if( ! $me->{ci} && !defined &auth_user ){
	# bypass login
	$me->create_auth( 'webanon', 'Top', 'root', 'staff', 'user' );
	$me->{ci} = $me->{co};
    }
    
    return unless $me->{ci};
    
    print STDERR "$$ got cookie: $me->{ci}\n"
	if $cookie_verbose;

    sync_db()  unless $auth{$me->{ci}};
    flush_db() unless $auth{$me->{ci}};
    
    my($user, $t, $hush, $home, $pref, @groups
       ) = split /\s+/, $auth{$me->{ci}};

    
    print STDERR "$$ cookie ok: $user, $t, $hush, $home, $pref, @groups\n"
	if $cookie_verbose;
    # invalid, forged, or expired cookie?
    if( !$user ){
	if( !defined &auth_user ){
	    $me->create_auth( 'webanon', 'Top', 'root', 'staff', 'user' );
	    ($user, $t, $hush, $home, $pref, @groups) =
		('webanon', $^T, 0, 'Top', '-', 'root', 'staff', 'user' );
	    $me->{ci} = $me->{co};
	}else{
	    $me->{ci} = '';
	    return;
	}
    }

    $me->{prefs} = {map {my($a,$b)=split /=/; ($a,$b)} split /,/, $pref}
    	if $pref && $pref ne '-';

    $me->{auth} = {
	time   => $t,
	user   => $user,
	addr   => $ENV{REMOTE_ADDR},
	home   => $home,
	grps   => [ @groups ],
	hush   => $hush,
	pref   => $pref,
	# ...
	};
}

sub create_auth {
    my $me   = shift;
    my $user = shift;
    my $home = shift;
    my @grps = @_;
    my( $pref );

    $me->{co} = new_cookie();
    $pref = shift @grps if $grps[0] =~ /=/;
    
    $me->{auth} = {
	user  => $user,
	home  => $home,
	pref  => $pref,
	hush  => 0,
	time  => $^T,
	grps  => [ @grps ],
    };
    $me->update_auth( $me->{co} );
}

sub update_auth {
    my $me   = shift;
    my $cook = shift || $me->{ci};

    my $p = join(',', map {"$_=$me->{prefs}{$_}"} keys %{$me->{prefs}});
    $p ||= $me->{auth}{pref} || '-';
    my $c = "$me->{auth}{user} $me->{auth}{time} $me->{auth}{hush} " .
	"$me->{auth}{home} $p @{$me->{auth}{grps}}";
    $auth{ $cook } = $c;
    print STDERR "$$ update cookie $cook -> $c\n" if $cookie_verbose;
    flush_db();
}

sub web_hushsiren {
    my $me = shift;

    $me->{auth}{hush} = $^T;
    $me->update_auth();
    return $me->light_redirect( $me->{q}->url() . "?object=" . $me->{q}->param('object') . ";func=page"
				. ($me->{q}->param('top')?';top=1':'') );
}

# default page
sub web_home {
    my $me = shift;

    if( $me->{auth} && $me->{auth}{user} ){
	my $home = $me->{auth}{home};
	return $me->light_redirect( $me->{q}->url() . "?object=$home;func=page;top=1" );
    }else{
	return $me->light_redirect( $me->{q}->url() . "?func=login" );
    }
}

sub web_logout {
    my $me = shift;

    if( $me->{ci} ){
	delete $auth{$me->{ci}};
	sync_db();
    }
    $me->{co} = 'invalid';
    $me->heavy_redirect( $me->{q}->url() );
}

sub web_login {
    my $me = shift;
    my $q  = $me->{q};
    my( $emsg, $user );

    if( !defined &auth_user ){
	$me->create_auth( 'webanon', 'Top', 'root', 'staff', 'user' );
	my $func = $q->param('nextf') || 'page';
	my $home = $q->param('home') || 'Top';
	my $top  = 1;
	return $me->heavy_redirect( $me->{q}->url() . "?object=$home;func=$func;top=$top" );
    }
    
    if( $q->param('name') ){
	# authenticate user
	my @a;
	$user = $q->param('name');

	expire_auth();
	@a = auth_user( $user, $q->param('passwd') );

	if( @a ){
	    $me->create_auth( $user, @a );
	    my( $func, $home, $top );
	    $func = $q->param('nextf') || 'page';
	    if( $q->param('home') ){
		$home = $q->param('home');
		$top  = $q->param('top');
	    }else{
		$home = $a[0];
		$top  = 1;
	    }
	    return $me->heavy_redirect( $me->{q}->url() . "?object=$home;func=$func;top=$top" );
	}else{
	    $emsg = l10n('Authentication Failed');
	}
    }
    $me->web_login_form($emsg);
}

sub web_login_form {
    my $me = shift;
    my $emsg = shift;
    my( $q, $r );

    $q = $me->{q};
    $r = $argusd->command( func => 'logindata' ) || {};
    # no error if we fail to connect
    
    $me->startpage( l10n('Login'), undef, decode($r->{bkgimg}), decode($r->{style_sheet}), decode($r->{icon}) );

    print "<H2><FONT COLOR=\"#FF0000\">", l10n('ERROR'), ": $emsg</FONT></H2>\n" if $emsg;
    print decode($r->{header}), "\n";
    print "<B><I>", l10n("Please log in"), "...</I></B><BR>\n";
    print "<TABLE WIDTH=\"95%\" BORDER=1>\n<TR><TD VALIGN=TOP>\n";

    print $q->startform(), "\n";
    print "<INPUT TYPE=HIDDEN NAME=func VALUE=login>\n";
    print "<TABLE>\n";
    print "<TR><TD>", l10n("Username"), ": </TD><TD>", $q->textfield('name', '', 32, 32), "</TD></TR>\n";
    print "<TR><TD>", l10n("Password"), ": </TD><TD>", $q->password_field('passwd', '', 32, 32), "</TD></TR>\n";
    print "<TR><TD COLSPAN=2>", $q->submit(-name=>l10n('Login')), "</TD></TR>\n";
    print "</TABLE><P>\n";
    print $q->endform(), "\n";
    print "</TD></TR></TABLE>\n";
    print decode($r->{footer}), "\n";
    $me->endpage();
}

sub web_page {
    my $me = shift;
    my( $obj, $topp, $r, $file, $url, $user, $home, $warning, $siren_icon );

    $obj  = decode( $me->{q}->param('object') );
    $topp = $me->{q}->param('top');
    $url  = $me->{q}->url( -path_info => 1 );
    $user = $me->{auth}{user};
    $home = $me->{auth}{home};

    $r = $argusd->command( func => 'webpage',
			   object => encode($obj),
			   top => ($topp?'yes':'no'),
			   );
    if( !$r ){
	# try again
	print STDERR "[$$] connect to argusd failed\n";
	reconnect();
	$r = $argusd->command( func => 'webpage',
			       object => encode($obj),
			       top => ($topp?'yes':'no'),
			       );
    }
    if( !$r ){
	# could not connect to server, try to serve cached data
	print STDERR "[$$] connect to argusd failed (again)\n";
	$file = "$WEBCACHE/" . encode($obj) . ($topp? '.top' : '.base');
	if( -f $file ){
	    my $d = (stat($file))[9];
	    open( F, $file ) || return $me->error( "could not open file: $!" );
	    if( $d + 120 < $^T ){
		# only warn if cache is more than several minutes old
		$warning = "<B>Unable to contact server - using cached data - please investigate</B>\n" .
		           "<BR>Cached: " . l10n_localtime($d) .
			   "<BR>\n";
	    }
	}else{
	    return $me->error( "unable to connect to server<BR><I>checking cache...</I>" .
			       "unable to locate cached data<BR><B>ABORTING</B>",
			       'aborting'
			       );
	}
    }else{
	# all is good
	$file = $r->{file};
	return $me->error( "Unable to access <I>$obj</I><BR>$r->{resultcode} $r->{resultmsg}" ) unless $file;
	open( F, $file ) || return $me->error( "could not open file: $!" );
    }

    $me->httpheader();
    while( <F> ){
	s/__BASEURL__/$url/g;
	s/__USER__/$user/g;
	s/__TOP__/$home\;top=1/g;
	s/<LOCALTIME\s+(\d+)\s*>/l10n_localtime($1)/ge;
	s/<L10N\s+([^<>]+)\s*>/l10n($1)/ge;
	
	if( /BODY/ && $warning ){
	    print;
	    $me->warning( $warning ) if $warning;
	    $warning = '';
	    next;
	}
	
	next if /END AUTHORIZATION/;
	
	if( /START AUTHORIZATION READ NEEDED (.*) --/ ){
	    next if $me->check_acl( $1 );
	    $me->web_acl_error( 'page' );
	    while( <F> ){
		last if /END AUTHORIZATION READ NEEDED/;
	    }
	    next;
	}

	if( /START AUTHORIZATION RW NEEDED (.*) --/ && ! $me->check_acl( $1 ) ){
	    while( <F> ){
		last if /END AUTHORIZATION RW NEEDED/;
	    }
	    next;
	}
	if( /START AUTHORIZATION DEBUG NEEDED (.*) --/ && ! $me->check_acl( $1 ) ){
	    while( <F> ){
		last if /END AUTHORIZATION DEBUG NEEDED/;
	    }
	    next;
	}
	if( /START AUTHORIZATION CONF NEEDED (.*) --/ && ! $me->check_acl( $1 ) ){
	    while( <F> ){
		last if /END AUTHORIZATION CONF NEEDED/;
	    }
	    next;
	}

	next if /START AUTHORIZATION/;

	if( /START SIRENBUTTON (\d+)/ ){
	    if( $1 < $me->{auth}{hush} ){
		while( <F> ){
		    last if /END SIRENBUTTON/;
		}
	    }
	    next;
	}
	next if /END SIRENBUTTON/;
	
	if( /START SIREN (\d+) (.*) / ){
	    # (sirentime, sirensong)
	    my $s = $2;
	    if( $1 < $me->{auth}{hush} ){
		$siren_icon = 1;
	    }else{
		# ickkk...
		# print STDERR "agent: $ENV{HTTP_USER_AGENT}\n";
		if( $ENV{HTTP_USER_AGENT} =~ /MSIE/ ){
		    print qq{<BGSOUND SRC="$s">\n};
		}else{
		    print qq{<OBJECT DATA="$s" TYPE="audio/x-wav" HEIGHT=0></OBJECT>\n};
		}
	    }
	    
	    #while( <F> ){
	    #	last if /END SIREN/;
	    #}
	    next;
	}
	if( /SIREN ICON/ && !$siren_icon ){
	    next;
	}

	print;
    }
    close F;
    
}

sub web_about {
    my $me = shift;
    my( $obj, $r, $k, $v );

    $obj  = decode( $me->{q}->param('object') );
    return unless $me->check_acl_func($obj, 'about', 1);
    
    $r = $argusd->command( func => 'about',
			   object => encode($obj),
			   );
    return $me->error( "unable to connect to server" ) unless $r;
    return $me->error( "Unable to access <I>$obj</I><BR>$r->{resultcode} $r->{resultmsg}" )
	unless $r->{resultcode} == 200;
    
    $me->startpage( "About: $obj" );
    print "<B>Debugging Dump of $obj</B><BR>\n",
    "&nbsp;&nbsp;&nbsp;&nbsp;<FONT SIZE=\"-1\"><I>documentation for some fields can be found ",
    "<A HREF=\"$ARGUS_URL/debug-details.html\">on the argus website</A> ",
    "or by running <TT>argusd -E</TT></I></FONT><P>\n";
    
    print "<TABLE>\n";
    foreach $k (sort keys %$r){
	my( $toolong, $color );
	next if $k eq 'resultcode' || $k eq 'resultmsg';
	$v = $r->{$k};
	$v =~ s/~x([234567].)/chr(hex($1))/ge;
	$v = l10n_localtime($v)
	    if( $v && $k =~ /time/ && $v > 1_000_000_000 );
	if( length($v) > 80 ){
	    $toolong = 1;
	    $v = substr($v,0,80);
	}
	if( $v eq "#<REF>" ){
	    $v = "<I>unprintable data structure</I>";
	}else{
	    $v =~ s/&/\&amp\;/g;
	    $v =~ s/</\&lt\;/g;
	    $v =~ s/>/\&gt\;/g;
	    $v =~ s/~x09/ <FONT COLOR=\"\#0000CC\">____ <\/FONT>/g;	# expand tabs
	}
	$v =~ s/(~x..)/<FONT COLOR=\"\#0000CC\">$1<\/FONT>/g;
	$v .= "<FONT COLOR=\"#FF0000\"><B>. . .</B></FONT>" if $toolong;
	$color = ' BGCOLOR="88FF88"' if grep {$_ eq $k} @hl_fields;
	$k = "<A HREF=\"$ARGUS_URL/debug-details.html#$k\"><FONT COLOR=black>$k</FONT></A>"
	    unless $k =~ /^_/;
	print "<TR$color><TD>$k</TD><TD>$v</TD></TR>\n";
    }
    print "</TABLE>\n";

    # QQQ - is this useful?
    print "<HR>\n<B>Dump of Current User</B><P><TABLE>\n";
    print "<TR><TD>user</TD><TD>$me->{auth}{user}</TD></TR>\n";
    print "<TR><TD>groups</TD><TD>@{$me->{auth}{grps}}</TD></TR>\n";
    print "<TR><TD>home</TD><TD>$me->{auth}{home}</TD></TR>\n";
    print "<TR><TD>pref</TD><TD>$me->{auth}{pref}</TD></TR>\n" if $me->{auth}{pref};
    # print "<TR><TD>location</TD><TD>$me->{auth}{addr}</TD></TR>\n";
    my $l = l10n_curr_lang();
    print "<TR><TD>locale</TD><TD>$l</TD></TR>\n" if $l;

    my $ht = $me->{auth}{hush} ? l10n_localtime($me->{auth}{hush}) : 'never';
    print "<TR><TD>hush time</TD><TD>$ht</TD></TR>\n";
    print "</TABLE>\n";
    
    $me->endpage();

}

sub web_getconf {
    my $me = shift;
    my( $obj, $r, $k, $v );

    $obj  = decode( $me->{q}->param('object') );
    return unless $me->check_acl_func($obj, 'getconf', 1);
    $r = $argusd->command_raw( func => 'getconf',
			       object => encode($obj),
			       );
    return $me->error( "unable to connect to server" ) unless $r;
    return $me->error( "Unable to access <I>$obj</I><BR>$r" ) unless $r =~ /200/;

    $me->startpage( "Config: $obj" );
    print "<PRE>\n";
    while( $_ = $argusd->nextline() ){
	chop;
	last if /^$/;
	s/^-//;
	s/</\&lt\;/g;
	s/>/\&gt\;/g;
	s,((?<!\\)\#.*),<FONT COLOR=red>$1</FONT>,;
	print "$_\n";
    }
    print "</PRE>\n";
    $me->endpage();
}

sub web_flushcache {
    my $me = shift;
    my( $obj, $r );

    $obj = decode( $me->{q}->param('object') );
    return unless $me->check_acl_func($obj, 'flush', 1);
    $r = $argusd->command( func => 'flushpage',
			   object => encode($obj),
			   );
    return $me->error( "unable to connect to server" ) unless $r;
    return $me->error( "Unable to access <I>$obj</I><BR>$r->{resultcode} $r->{resultmsg}" )
	unless $r->{resultcode} == 200;

    return $me->light_redirect( $me->{q}->url() . "?object=" . $me->{q}->param('object') . ";func=page" );
}

sub web_override {
    my $me = shift;
    my( $q, $st, $r, $obj );
    
    $obj = decode( $me->{q}->param('object') );
    return unless $me->check_acl_func($obj, 'override', 1);
    $q = $me->{q};
    
    if( $q->param('phase') ){
	my( $mode, $txt );

	$mode = $q->param('mode');
	
	# check params
	if( $mode !~ /^(manual|auto)$/ ){
	    return $me->error( "invalid mode" );
	}

	if( $me->can('override_policy') ){
	    return unless $me->override_policy();
	}
		
	$txt = $q->param('text');
	$txt =~ s/</&lt\;/g;
	$txt =~ s/>/&gt\;/g;
	
    	$r = $argusd->command( func => 'override',
			       object => encode($obj),
			       user => $me->{auth}{user},
			       text => encode($txt),
			       mode => $mode,
			       expires => $q->param('expires') ? ($^T + $q->param('expires')) : 0,
			       ticket => encode($q->param('ticket')),
			       );
	return $me->error( "unable to connect to server" ) unless $r;
	return $me->error( "Unable to access <I>$obj</I><BR>$r->{resultcode} $r->{resultmsg}" )
	    unless $r->{resultcode} == 200;

	return $me->light_redirect( $q->url() . "?object=" . $q->param('object') . ";func=page" );
    }
    
    $me->startpage( l10n("Override") . " $obj" );
    $st = get_status($obj);
    
    print $q->startform(-method=>'get'), "\n";
    print "<INPUT TYPE=HIDDEN NAME=func VALUE=override>\n";
    print "<INPUT TYPE=HIDDEN NAME=phase VALUE=1>\n";
    print "<INPUT TYPE=HIDDEN NAME=object VALUE=", encode($obj), ">\n";
    print l10n("Comment"), ": ", $q->textfield('text', '', 50), "<BR>\n";
    print l10n("Mode"),    ": ", $q->popup_menu('mode', [ 'auto', 'manual' ],
                                   ($st eq 'up' ? 'manual' : 'auto') );

    print l10n("Ticket No."), ": ", $q->textfield('ticket', '', 16)
	if $USE_TICKET;

    %exp = (
            0             => 'never',
            15 * 60       => '15 min',
            30 * 60       => '30 min',
            60 * 60       => '1 hour',
            2  * 60 * 60  => '2 hours',
            3  * 60 * 60  => '3 hours',
            4  * 60 * 60  => '4 hours',
            6  * 60 * 60  => '6 hours',
            8  * 60 * 60  => '8 hours',
            12 * 60 * 60  => '12 hours',
            18 * 60 * 60  => '18 hours',
            24 * 60 * 60  => '24 hours',
            36 * 60 * 60  => '36 hours',
            2 * 24 * 60 * 60   => '2 days',
            3 * 24 * 60 * 60   => '3 days',
            4 * 24 * 60 * 60   => '4 days',
            5 * 24 * 60 * 60   => '5 days',
            7 * 24 * 60 * 60   => '7 days',
            10 * 24 * 60 * 60  => '10 days',
            14 * 24 * 60 * 60  => '14 days',
            20 * 24 * 60 * 60  => '20 days',
            30 * 24 * 60 * 60  => '30 days',
            45 * 24 * 60 * 60  => '45 days',
            );
    
    print l10n("Expires"), ": ", $q->popup_menu('expires',
                                      [ sort {$a<=>$b} keys %exp ], 4 * 60 * 60, \%exp );
    print "<P>\n";
    print $q->submit(), "\n";
    print $q->endform(), "\n";
    print "<HR>\n<I>NB:";
    print l10n("auto mode - disengage override when status returns to up"), "<BR>\n";
    print l10n("manual mode - require override be disengaged manually"), "<BR>\n";


    $me->endpage();
}

sub web_rmoverride {
    my $me = shift;
    my( $r, $obj );
    
    $obj = decode( $me->{q}->param('object') );
    return unless $me->check_acl_func($obj, 'override', 1);

    if( $me->can('override_policy') ){
	return unless $me->override_policy();
    }

    $r = $argusd->command( func => 'override',
			   object => encode($obj),
			   remove => 'yes',
			   user => $me->{auth}{user},
			   );
    return $me->error( "unable to connect to server" ) unless $r;
    return $me->error( "Unable to access <I>$obj</I><BR>$r->{resultcode} $r->{resultmsg}" )
	unless $r->{resultcode} == 200;
    
    return $me->heavy_redirect( $me->{q}->url() . "?object=" . $me->{q}->param('object') . ";func=page" );
}

sub get_status {
    my $obj = shift;
    my( $r );

    $r = $argusd->command( func => 'getparam',
			   object => encode($obj),
			   param => 'ovstatus'
			   );
    return $r->{value} if $r && $r->{value};
    undef;
}
    
sub web_annotate {
    my $me = shift;
    my( $obj, $r, $q );

    $obj = decode( $me->{q}->param('object') );
    return unless $me->check_acl_func($obj, 'annotate', 1);
    if( $me->{q}->param('phase') ){
	my $txt = $me->{q}->param('text');
	$txt =~ s/</&lt\;/g;
	$txt =~ s/>/&gt\;/g;
	$r = $argusd->command( func => 'annotate',
			       object => encode($obj),
			       user => $me->{auth}{user},
			       text => encode($txt),
			       );
	return $me->error( "unable to connect to server" ) unless $r;
	return $me->error( "Unable to access <I>$obj</I><BR>$r->{resultcode} $r->{resultmsg}" )
	    unless $r->{resultcode} == 200;

	return $me->light_redirect( $me->{q}->url() . "?object=" . $me->{q}->param('object')
				    . ";func=page");
    }
    
    $me->startpage( l10n("Annotate") . " $obj" );
    $q = $me->{q}; 

    print $q->startform(-method=>'get'), "\n";
    print "<INPUT TYPE=HIDDEN NAME=func VALUE=annotate>\n";
    print "<INPUT TYPE=HIDDEN NAME=phase VALUE=1>\n";
    print "<INPUT TYPE=HIDDEN NAME=object VALUE=", encode($obj), ">\n";
    print l10n("Annotation"), ": ", $q->textfield('text', '', 32, 64), "<BR>\n";
    
    print $q->submit(), "\n";
    print $q->endform(), "\n";
    $me->endpage();
}

sub web_graph {
    my $me = shift;
    my( $obj, $file, $which, $size, $r, $buf, $i, @opt );

    return $me->error( "Graphing support not included" ) unless $HAVE_GD;
    $obj = decode( $me->{q}->param('object') );
    $which = $me->{q}->param('which');
    $size  = $me->{q}->param('size');
    
    return unless $me->check_acl_func($obj, 'page', 1);

    $file = "$datadir/gcache/" . encode($obj) . ".$which.$size.png";
    if( -f $file ){
	my $d = (stat($file))[9];
	my $te = ($size eq 'thumb') ? 1200 : ($which eq 'samples') ? 120 : 300;
	if( $d + $te > $^T ){
	    my( $b, $i );
	    # use cached graph image
	    # print STDERR "using cached image\n";
	    open( F, $file ) || return $me->error( "could not open '$file': $!" );
	    binmode(F);
	    print $me->{q}->header( -type=>'image/png', -expires=>'+5m');
	    while( ($i=read(F, $b, 8192)) > 0 ){
		print $b;
	    }
	    close F;
	    $me->{header} = 1;
	    return;
	}
    }
    
    $r = $argusd->command( func => 'graphdata',
			   object => encode($obj),
			   );
    return $me->error( "unable to connect to server" ) unless $r;
    return $me->error( "Unable to access <I>$obj</I><BR>$r->{resultcode} $r->{resultmsg}" )
	unless $r->{resultcode} == 200;

    my $prog = decode($r->{picasso}) || "$libdir/picasso";
    @opt = ('-s', $size, '-w', $which);
    push @opt, '-l' if $r->{logscale};
    push @opt, '-g' if $r->{drawgrid};
    push @opt, '-b' if $r->{gr_binary};
    push @opt, '-T' if $r->{transparent};
    push @opt, '-B' if $r->{drawborder};
    push @opt, '-G' if $r->{gridontop};
    push @opt, '-r', decode($r->{gr_range})  if $r->{gr_range};
    push @opt, '-R', decode($r->{gr_xrange}) if $r->{gr_xrange};
    push @opt, '-x', decode($r->{xlabel})    if $r->{xlabel};
    push @opt, '-y', decode($r->{ylabel})    if $r->{ylabel};
    push @opt, '-t', decode($r->{title})     if $r->{title};
    push @opt, '-c', decode($r->{gr_colors}) if $r->{gr_colors};
    push @opt, '-C', $r->{clabels},          if $r->{clabels};
    push @opt, '-S', $r->{barstyle},	     if $r->{barstyle};
    push @opt, '-D', $r->{taglist},    	     if $r->{taglist};
    push @opt, '-L', $r->{labelstyle},       if $r->{labelstyle};
    
    $| = 1;
    print $me->{q}->header( -type=>'image/png', -expires=>'+5m');

    # print STDERR "picasso: $prog @opt $r->{list}\n";
    # ask picasso to paint the image
    open( CACHE, "> $file.$$" );
    open(PNG, '-|') ||
	exec(
	     $prog, @opt,
	     split /\s+/, $r->{list}
	     );
    binmode(CACHE);
    binmode(PNG);
    while( read(PNG, $buf, 8192) > 0 ){
	# send image to user and to cache file
	print CACHE $buf;
	print $buf;
    }
    close CACHE;
    close PNG;
    if( $? ){
	# toss tmp file if picasso had an error
	unlink "$file.$$";
    }else{
	rename "$file.$$", $file;
    }
    $me->{header} = 1;

}

sub web_graphpage {
    my $me = shift;
    my( $obj, $which, $size, $r, $back, @opt );

    return $me->error( "Graphing support not included" ) unless $HAVE_GD;
    $obj = decode( $me->{q}->param('object') );
    return unless $me->check_acl_func($obj, 'page', 1);
    
    $r = $argusd->command( func => 'graphdata',
			   object => encode($obj),
			   );
    return $me->error( "unable to connect to server" ) unless $r;
    return $me->error( "Unable to access <I>$obj</I><BR>$r->{resultcode} $r->{resultmsg}" )
	unless $r->{resultcode} == 200;

    $which = $me->{q}->param('which');
    $back  = $me->{q}->url() . "?object=" . encode($obj) . ";func=page";
    $me->startpage( "Graph $obj", undef, decode($r->{bkgimg}), decode($r->{style_sheet}), decode($r->{icon}) );
    print decode($r->{header}), "\n";

    # <A HREF="$back"><FONT COLOR="#000000">$obj</FONT></A>

    print <<XYZ;
    <TABLE WIDTH="95%" BORDER=1>
<TR BGCOLOR="#AAAAFF"><TD COLSPAN=2>
  <TABLE BORDER=0 WIDTH="100%">
    <TR> <TD ALIGN=LEFT>$obj</TD></TR>
  </TABLE>
</TD></TR>      
<TR><TD VALIGN=TOP>
XYZ
    ;
    print "<BR><CENTER>\n";
    print "<IMG WIDTH=640 HEIGHT=192 SRC=\"", $me->{q}->url(), "?object=",
    encode($obj), ";func=graph;which=$which;size=full;ext=.png\"><BR>\n";
    # print "$which\n";
    print "</CENTER><BR>\n";

    print "</TD></TR></TABLE>\n";
    print decode($r->{footer}), "\n";
    $me->endpage();
}

sub web_logfile {
    my $me = shift;
    my( @l );
    
    return unless $ALWAYS_SHOW_LOG || $me->check_acl_func('Top', 'logfile', 1);
    $me->startpage("Lof Gile" );
    open( F, $LOGFILE );
    @l = <F>;
    chop @l;
    close F;

    print "<PRE>\n";
    foreach (reverse @l){
	s/(.*(?:ERROR|WARNING).*)/<FONT COLOR=\"\#FF0000\">$1<\/FONT>/;
	print "$_\n";
    }
    print "</PRE>\n";

    $me->endpage();
}

################################################################

sub web_ntfylist {
    my $me = shift;

    $me->notify_list( 'Notifications', 0 );
}

sub web_ntfylsua {
    my $me = shift;

    $me->notify_list( 'Unacked Notifications', 1 );
}

sub notify_list {
    my $me = shift;
    my $title = shift;
    my $ackp = shift;
    my( $q, $r, $n );

    return unless $me->check_acl_func('Top', 'ntfylist', 1);
    # QQQ - check ACL for every object listed???
    $q = $me->{q};
    $r = $argusd->command_raw( func => 'notify_list',
			     which => $ackp ? 'unacked' : ''
			     );
    return $me->error( "unable to connect to server" ) unless $r;
    return $me->error( "Unable to access <I>notify list</I><BR>$r" ) unless $r =~ /200/;

    $me->startpage( l10n($title), 60 );
    print "<H2>$title</H2>\n";
    print $q->startform(-method=>'get'), "\n" if $ackp;
    print "<TABLE WIDTH=\"95%\" BORDER=1 CELLSPACING=0 CELLPADDING=2>\n";
    
    while( $_ = $argusd->nextline() ){
	chop;
	last if /^$/;
	$n++;
	my( $id, $stat, $creat, $obj, $msg,
	    $prio, $seve ) = split;
	my $dt   = strftime "%d/%b %R", localtime($creat);
	$dt =~ s/\s+/&nbsp\;/g;
	$obj = decode($obj);
	$msg = decode($msg);
	my $durl = "<A HREF=\"" . $q->url() . "?func=ntfydetail;idno=$id\">$id</A>";
	my $aurl = "<A HREF=\"" . $q->url() . "?func=ntfyack;idno=$id\">Ack</A>";
	my $objl = "<A HREF=\"" . $q->url() . "?object=$obj;func=page\">Object</A>";
	# QQQ - or base color on whether it is acked or not?
	my $clr  = ($stat eq 'down') ? 'FF8888' : '88FF88';
	
	if( $ackp ){
	    print "<TR BGCOLOR=\"#$clr\"><TD>$aurl</TD><TD><INPUT TYPE=checkbox NAME=idno VALUE=$id></TD>",
	    "<TD>$durl</TD><TD>$objl</TD><TD>$dt</TD><TD>$msg</TD></TR>\n";
	}else{
	    print "<TR BGCOLOR=\"#$clr\"><TD>$durl</TD><TD>$objl</TD><TD>$dt</TD><TD>$msg</TD></TR>\n";
	}
    }

    print "</TABLE>\n";
    if( $ackp && $n ){
	print "<INPUT TYPE=HIDDEN NAME=func VALUE=ntfyack>\n";
	print $q->submit(l10n("Ack Checked")), "\n";
	print $q->submit(l10n("Ack All")), "\n";
	print $q->endform(), "\n";
    }

    unless( $n ){
	if( $ackp ){
	    print l10n("There are no un-acked notifications"), "\n";
	}else{
	    print l10n("There are no notifications"), "\n";
	}
    }
    
    $me->endpage();
}

sub web_ntfyack {
    my $me = shift;
    my( $q, @id, $r );

    $q = $me->{q};

    if( $q->param('Ack All') ){
	@id = ('all');
    }else{
	@id = $q->param('idno');
    }

    foreach my $id (@id){
	return $me->error( 'Invalid Notification ID' ) unless $id =~ /^(\d+|all)$/;

	return unless $me->check_acl_ack($id, 1);
	
	$r = $argusd->command( func  => 'notify_ack',
			     user  => $me->{auth}{user},
			     idno  => $id );
	return $me->error( "unable to connect to server" ) unless $r;
	return $me->error( "Unable to access <I>$id</I><BR>$r->{resultcode} $r->{resultmsg}" )
	    unless $r->{resultcode} == 200;
    }

    if( $q->request_method() eq 'POST'){
	$me->heavy_redirect( $q->url() . "?func=ntfylsua" );
    }else{
	$me->light_redirect( $q->url() . "?func=ntfylsua" );
    }
}

sub web_ntfydetail {
    my $me = shift;
    my( $q, $id, $r, $n, $esc );

    $q = $me->{q};
    $id = $q->param('idno');
    return $me->error( 'invalid notification' ) unless $id =~ /^\d+$/;
    $r = $argusd->command( func => 'notify_detail',
			 idno => $id );

    return $me->error( "unable to connect to server" ) unless $r;
    return $me->error( "Unable to access <I>$id</I><BR>$r->{resultcode} $r->{resultmsg}" )
	unless $r->{resultcode} == 200;

    # check ACL
    unless( $me->check_acl( decode($r->{acl_ntfydetail})) ){
	return $me->web_acl_error( 'ntfydetail' );
    }
    
    $me->startpage( "Details for $id", 60 );
    print "<H2>Details for $id</H2>\n";
    
    print "<TABLE>\n";
    print "<TR><TD><B>ID</B></TD><TD>$id",
        ($r->{state} eq 'active' ? "&nbsp;&nbsp;&nbsp;<A HREF=\"". $q->url().
	 "?func=ntfyack;idno=$id\"><B>[ Ack ]</B></A>" : ''),
	"</TD></TR>\n";
    print "<TR><TD><B>Object</B></TD><TD><A HREF=\"", $q->url(), "?object=$r->{object};func=page\">",
        decode($r->{object}), "</A></TD></TR>\n";
    print "<TR><TD><B>Message</B></TD><TD>", decode($r->{msg}), "</TD></TR>\n";
    print "<TR><TD><B>Reason</B></TD><TD>", decode($r->{reason}), "</TD></TR>\n" if $r->{reason};
    print "<TR><TD><B>Created</B></TD><TD>", l10n_localtime($r->{created}), "</TD></TR>\n";
    $esc = " / <B>Escalated</B>" if $r->{escalated};
    print "<TR><TD><B>Status</B></TD><TD>$r->{state}$esc</TD></TR>\n";
    print "<TR><TD><B>Severity</B></TD><TD>$r->{severity}</TD></TR>\n" if $r->{severity};
    print "<TR><TD><B>Priority</B></TD><TD>$r->{priority}</TD></TR>\n" if $r->{priority};
    print "<TR><TD><B>Audit Detail</B></TD><TD>$r->{detail}</TD></TR>\n" if $r->{detail};

    if( $r->{ackedby} ){
	print "<TR><TD><B>Acked By</B></TD><TD>$r->{ackedby}</TD></TR>\n";
	print "<TR><TD><B>Acked At</B></TD><TD>", l10n_localtime($r->{ackedat}), "</TD></TR>\n";
    }
    print "</TABLE>\n<HR>\n";

    print "<B>Per User Status</B><BR>\n";
    print "<TABLE BORDER=1>\n<TR>\n";
    foreach my $dst (split /\s+/, $r->{statuswho}){
	my $w = decode($dst);
	my $s = $r->{"status $dst"};
	print "<TD><B>$w</B><BR>$s</TD>\n";
    }
    print "</TR>\n</TABLE>\n<HR>\n";

    print "<B>Audit Trail</B><BR>\n";
    print "<TABLE>\n";
    $n = $r->{loglines} - 1;
    foreach my $i (0..$n){
	my($t, $w, $m) = split /\s+/, $r->{"log $i"};

	$w = ($w eq '_') ? '' : decode($w);
	$m = decode($m);
	print "<TR><TD>", l10n_localtime($t), "</TD><TD>$w</TD><TD>$m</TD></TR>\n";
    }
    print "</TABLE>\n";
    $me->endpage();
    
}



################################################################

sub tie_auth {
    tie( %auth, __DATABASE__, $AUTHDB, O_RDWR|O_CREAT, 0644 )
	|| die "cannot tie auth '$AUTHDB': $!\n";
}

sub untie_auth {
    untie %auth;
}

sub sync_db {
    my $x = tied %auth;

    if( $x->can('sync') ){
	$x->sync();
    }else{
	untie_auth();
	tie_auth();
    }
}

# sometimes sync doesn't
sub flush_db {
    untie_auth();
    tie_auth();
}

sub expire_auth {
    foreach my $a (keys %auth){
        my $t = (split /\s/, $auth{$a})[1];
        delete $auth{$a} if( $t + $AUTH_EXPIRE < $^T );
    }
}

sub connect_if_not_already {
    connect_to_server() unless $connected;
}

sub connect_to_server {
    $argusd = Argus::Ctl->new( "$datadir/control",
			     retry => 1,
			     who   => 'arguscgi' );
    $connected = 1;

    my $r = $argusd->command( func   => 'getparam',
			      object => 'Conf',
			      param  => 'lang',
			      );
    $lang_conf = $r->{value};
    1;
}
sub disconnect_from_server {
    $argusd->disconnect();
    $connected = 0;
}
sub reconnect {
    $argusd->reconnect();
    print STDERR "[$$] reconnect\n";
}

# mod_perl hook...
sub dispatch_table {
    return \%fnc_dispatch;
}

1;
