#! /usr/bin/perl

use strict ;
use warnings ;

use IO::Socket::INET ;
use Digest::MD5 qw(md5_hex) ;
use JSON ;

my $DEF_CONF_PATH = '/etc/qdb/conf' ;
my %DEF_CONF =
  ( server => 'localhost'
  , secret => ''
  , port   => 22722
  ) ;
my $DEF_TIMEOUT = 1 ;
my $DEF_SERV = $DEF_CONF { server } ;
my $DEF_PORT = $DEF_CONF { port } ;

my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
my $Usage = <<USAGE ;
Usage: $prog [-vqdh] -i [-c config] [server [port] ]
       $prog [-vqdh] [-t t ] [-c config] new|delete path
option v : be verbose
option q : be quiet
option d : show debug info
option h : show help message ; exit
option t : timeout after \$t seconds ; default [$DEF_TIMEOUT]
         : no timer is set if \$t == 0
option i : [interactive] ; talk with a qdb-server ; implies -t 0
           default server : $DEF_SERV
           default port   : $DEF_PORT
option c : use config-file \$config ; default [$DEF_CONF_PATH]
--------------------------------------------------------------------
Config-file must contain :
  server .... # eg archive.science.uu.nl
  secret .... # eg c9c8ef3441336cd798c587922a844142
Try with : perl $prog new authors/RECENT-1d.yaml
--------------------------------------------------------------------
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die "[error] $prog: $_[0]\n" ; }
sub Warn  { warn "[warn] $prog: $_[0]\n" ; }

# usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
# usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
# ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
# ID  = perl identifier
# SPC = i|f|s for integer, fixedpoint real or string argument

use Getopt::Long ;
Getopt::Long::config ( 'no_ignore_case' ) ;
my %opt = () ; Usage '' unless GetOptions
  ( \%opt, qw(v q d h t=i i c=s) ) ;
Usage "Arg count\n" unless $opt{h} or ( $opt{i} ? @ARGV <= 2 : @ARGV == 2 ) ;

if ( $opt{h} ) { print $Usage ; exit ; }

$opt{v} ||= $opt{d} ;
$opt{t} = 0 if $opt{i} ;

my $TYPE ;
my $PATH ;
my $SERV ;
my $PORT ;

if ( $opt{i} )
  { $DEF_CONF_PATH = '/dev/null' unless -f $DEF_CONF_PATH ;
    $SERV = shift ; $PORT = shift ;
  }
else
  { $TYPE = shift ; $PATH = shift ; }

Error "bad type ($TYPE)" unless $opt{i} or $TYPE =~ /^(new|delete)$/ ;

my $ALRM ; $SIG{ALRM} = sub { $ALRM = 1 ; } ;
my $TOUT = defined $opt{t} ? $opt{t} : $DEF_TIMEOUT ;
alarm $TOUT if $TOUT ;

sub get_conf
  { my $file = shift ;
    my $conf =  { %DEF_CONF } ;
    open CONF, '<', $file or Error "can't open conf $file ($!)" ;
    while ( <CONF> )
      { chomp ;
        my ( $key, $val ) = split ' ', $_, 2 ;
        $conf -> {$key} = $val ;
      }
    my @errs = () ;
    for my $key ( sort keys %$conf )
      { push @errs, "missing in config-entry : $key"
          unless defined $conf -> {$key} ;
      }
    if ( @errs )
      { printf "*** %s\n", $_ for @errs ;
        Error "errors in config file $file" ;
      }
    close CONF ;
    $conf ;
  }

sub sock_send
  { my $conf = shift ;
    my $type = shift ;
    my $path = shift ;
    my $time = shift ;
    my $serv = $conf -> {server} ;
    my $secr = $conf -> {secret} ;
    my $port = $conf -> {port} ;
    my $date = gmtime $time ;
    my $err ;
    my $res ;
    my @res ;
    my $SOCK = IO::Socket::INET -> new
      ( PeerAddr => "$serv:$port", Proto => 'tcp' ) ;
    if ( $SOCK )
      { # authenticate
        print $SOCK "AUTH1\n" ;
        my $chal = decode_json ( scalar <$SOCK> ) -> {res} ;
        print "challenge     [$chal]\n" if $opt{d} ;
        Error "no challenge" unless $chal ;
        my $resp = md5_hex ( "$chal $secr\n" ) ;
        print "response      [$resp]\n" if $opt{d} ;
        print $SOCK "AUTH2 $resp\n" ;
        my $auth = decode_json ( scalar <$SOCK> ) -> {res} ;
        print "authenticated [$auth]\n" if $opt{d} ;
        Error "can't authenticate" unless $auth ;

        # commit event
        print $SOCK "commit $type $path $time\n" ;
        my $comm = decode_json ( scalar <$SOCK> ) -> {res} ;
        print "committed     [$comm]\n" if $opt{d} ;
        Error "not committed" unless $comm ;

        # done
        print $SOCK "quit\n" ;
        $SOCK -> shutdown ( 1 ) ; # done writing
        @res = <$SOCK> ;
        $SOCK -> shutdown ( 2 ) ; # done using
        printf "$date UTC : sent $type $path $time\n" if $opt{v} ;
      }
    else
      { Error "can't open socket to $serv" ; }
  }

sub auth
  { my $conf = shift ;
    my $sock = shift ;
    my $secr = $conf -> {secret} ;
    unless ( $secr )
      { printf "no secret ; can't authenticate\n" ; }
    else
      { print $sock "AUTH1\n" ;
        my $chal = decode_json ( scalar <$sock> ) -> {res} ;
        my $resp = md5_hex ( "$chal $secr\n" ) ;
        print "secret    : $secr\n" ;
        print "challenge : $chal\n" ;
        print "response  : $resp\n" ;
        print $sock "AUTH2 $resp\n" ;
        my $repl = decode_json ( scalar <$sock> ) ;
        sprintf "%sauthorised\n", ( $repl -> {res} ? '' : 'not ' ) ; 
      }
  }

our %HELP = 
  ( '?'       => 'print help message'
  , '.help'   => 'print help message'
  , '.quit'   => 'quit'
  , '.auth'   => 'authorise'
  , '.pretty' => 'toggle pretty-printing'
  ) ;

sub help
  { my $pret = shift ;
    my %help = %HELP ;
    my @keys = sort keys %help ;
    my $W = 0 ; for ( @keys ) { my $l = length $_ ; $W = $l if $l > $W ; }
    $help { '.pretty' } .= sprintf " ; currently '%s'"
      , ( $pret ? 'on' : 'off' ) ;
    my @res =
      ( "Meta-commands may be abbreviated to a unique prefix ; eg '.h' :"
      , ( map { sprintf "-- %-${W}s : %s", $_, $help { $_ } ; } @keys )
      , "Other commands are sent to the server ; type 'help' for help."
      ) ;
    sprintf "%s\n", join "\n", @res ;
  }

sub dotcom
  { my $x  = shift ;
    my $lx = length $x ;
    my %c  = () ;
    for my $h ( keys %HELP )
      { my $lh = length $h ;
        $c { $h } ++ if $x eq $h ;
        $c { $h } ++ if $lh > $lx and $x eq substr $h, 0, $lx ;
      }
    my @c = keys %c ;
    my $err =
      ( @c == 0
      ? "command [$x] not found"
      : ( @c > 1 ? "command [$x] ambiguous [@c]" : undef )
      ) ;
    my $res = ( $err ? undef : $c [ 0 ] ) ;
    ( $err, $res ) ;
  }

sub talk
  { my $conf = shift ;
    my $serv = $conf -> { server } ;
    my $port = $conf -> {  port  } ;
    my $pret = 1 ;
    my $prmt = "$prog : " ;
    my $SOCK = IO::Socket::INET -> new
      ( PeerAddr => "$serv:$port", Proto => 'tcp' ) ;
    Error "can't connect to $serv:$port" unless $SOCK ;
    print "connected to host $serv port $port\n" ;
    print "type '?' for help\n$prmt" ;
    while ( <> )
      { chomp ;
        s/^\s*// ;
        s/\s*$// ;
        if ( $_ eq '?' or /^\./ )
          { my ( $err, $com ) = dotcom $_ ;
            if ( $err )
              { print "$err\n" ; }
            elsif ( $com eq '?' or $com eq '.help' )
              { print help $pret ; }
            elsif ( $com eq '.quit' )
              { exit ; }
            elsif ( $com eq '.auth' )
              { print auth $conf, $SOCK ; }
            elsif ( $com eq '.pretty' )
              { $pret = ! $pret ;
                printf "pretty-printing is %s\n", $pret ? 'on' : 'off' ;
              }
          }
        elsif ( /^pretty/i )
          { print "won't send 'pretty'\n" ; }
        elsif ( length $_ )
          { print $SOCK "$_\n" or Error "can't print on socket" ;
            my $line = <$SOCK> ;
            Error "connection lost" unless defined $line ;
            chomp $line ;
            printf "line [%s]\n", $line if $opt{v} ;
            my $repl = decode_json ( $line ) ;
            if ( my $err = $repl -> {err} )
              { printf "[error] %s\n", $err ; }
            else
              { my $res = $repl -> {res} ;
                my $txt ;
                unless ( $pret )
                  { $txt = $line ; }
                elsif ( ref $res )
                  { $txt = JSON -> new -> pretty -> encode ( $res ) ; }
                else
                  { $txt = $res ; }
                chomp $txt ;
                printf "$txt\n" ;
              }
            last if $_ =~ /^quit$/i ;
          }
        print $prmt ;
      }
  }

my $CONF = get_conf ( $opt{c} || $DEF_CONF_PATH ) ;

if ( $opt{i} )
  { $CONF -> { server } = $SERV if $SERV ;
    $CONF -> {  port  } = $PORT if $PORT ;
    talk $CONF ;
  }
else
  { sock_send $CONF, $TYPE, $PATH, time ; }

END { print "timeout sent $TYPE $PATH\n" if $ALRM ; }