#! /usr/bin/perl

use strict ;
use warnings ;

use JSON::XS ;
use CGI qw/:standard -utf8/ ;
use DBI ;
use Carp ;

my $DB_FILE = '/var/qdb/qdb.lite' ;
my $MAX_RES = 1000 ;
my $REQ_BAD = '400 Bad Request' ;
my $REQ_OK  = '200 OK' ;
my $LINK    = 'src/stable.tar.bz2' ;

my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
my $Usage = <<USAGE ;
Usage: $prog [-v] [-q] [-d] [-h] [-t [arg] ]
option v : be verbose
option q : be quiet
option d : show debug info
option h : show help
option t : test ; set \$ENV{PATH_INFO} = \$arg ;
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) ) ;
Usage "Arg count\n" unless ( $opt{t} ? @ARGV <= 1 : @ARGV == 0 ) ;

$opt{v} ||= $opt{d} ;

if ( $opt{t} )
  { $ENV { PATH_INFO } = shift if @ARGV ;
    printf "test : %s\n", $ENV { PATH_INFO } || 'no PATH_INFO' if $opt{v} ;
  }

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

sub STYLE
  { <<STYLE ;
A:link    { color: blue ; }
A:visited { color: blue ; }
STYLE
  }

sub HELP
  { my $name = $ENV { SCRIPT_NAME } || 'NO_SCRIPT_NAME' ;
    <<HELP ;
<h2>Intro</h2>
<blockquote>

This service provides access to CPAN's update history.
<ul>
<li>CPAN's update history is a list of <i>events</i>.</li>
<li>An <i>event</i> is a tuple :
<code>[</code> <i>id</i>, <i>type</i>, <i>path</i> <code>]</code> ;
where
  <ul>
  <li><i>id</i> is some meaningless, (auto-increment) unique number,</li>
  <li><i>type</i> is either <code>new</code> or <code>delete</code>,</li>
  <li><i>path</i> is a filesystem path in CPAN.</li>
  </ul>
</li>
<li>The history is updated by adding events.</li>
<li>In the history, <i>\$path</i> is <i>unique</i> ;
  there can only be one event per <i>\$path</i>.
  <br />
  When a <i>\$path</i>-event is added,
  it replaces a previous <i>\$path</i>-event.
</li>
</ul>

</blockquote>
<h2>Usage</h2>
<blockquote>

To use the service, you must issue a <i>web-request</i> ;
see the next section for an overview.
<p>
Each request returns a json-text :
</p>
<pre>
  { "cmd" : ...  # the request
  , "err" : ...  # any errors found
  , "res" : ...  # the result
  }
</pre>

If <i>\$err</i> is defined, then
<ul>
<li><i>\$res</i> is not defined, and</li>
<li>the <i>http status code</i> is <i>$REQ_BAD</i>.</li>
</ul>

</blockquote>
<h2>Requests</h2>
<blockquote>

<h3>database queries</h3>

<dl>
<dt><code>count</code></dt>
<dd>The result is the number of events in the history.
  <br />
  Example : <a href="$name/count"><code>count</code></a>
</dd>

<dt><code>first_id</code></dt>
<dd>The result is the <i>id</i> of the first event.
  <br />
  Example : <a href="$name/first_id"><code>first_id</code></a>
</dd>

<dt><code>last_id</code></dt>
<dd>The result is the <i>id</i> of the last (most recent) event.
  <br />
  Example : <a href="$name/last_id"><code>last_id</code></a>
</dd>

<dt><code>from/</code><i>\$n</i></dt>
<dd>The result is an <i>id</i>-ordered list of the oldest events
  with <i>id &ge; \$n</i> ;
  <br />
  at most $MAX_RES events are returned.
  <br />
  Example :
  <a href="$name/from/7000"><code>from/7000</code></a>
</dd>

<dt><code>from/</code><i>\$n</i><code>/limit/</code><i>\$x</i></dt>
<dd>same as <code>from/</code> but at most <i>min(\$x,$MAX_RES)</i>
  events are returned.
  <br />
  Example :
  <a href="$name/from/7000/limit/8"><code>from/7000/limit/8</code></a>
</dd>
<dt><code>last/</code><i>\$x</i></dt>
<dd>The result is an <i>id</i>-ordered list
of the last <i>min(\$x,$MAX_RES)</i> events.
  <br />
  Examples :
  <a href="$name/last/8"><code>last/8</code></a> ;
  <a href="$name/last/32"><code>last/32</code></a>
</dd>
<dt><code>path/</code><i>\$path</i></dt>
<dd>The result is a list of (0 or 1) events pertaining to \$path.
  <br />
  Example :
  <a href="$name/path/$LINK"><code>path/$LINK</code></a>
</dd>
</dl>

<h3>filesystem queries</h3>

<dl>
<dt><code>stat/</code><i>\$path</i></dt>
<dd>The result is <code>[stat "/path/to/cpan/\$path"]</code>
  <br />
  Example :
  <a href="$name/stat/$LINK"><code>stat/$LINK</code></a>
</dd>
<dt><code>lstat/</code><i>\$path</i></dt>
<dd>The result is <code>[lstat "/path/to/cpan/\$path"]</code>
  <br />
  Example :
  <a href="$name/lstat/$LINK"><code>lstat/$LINK</code></a>
</dd>
<dt><code>readlink/</code><i>\$path</i></dt>
<dd>The result is <code>readlink "/path/to/cpan/\$path"</code>
  <br />
  Example :
  <a href="$name/readlink/$LINK"><code>readlink/$LINK</code></a>
</dd>
<dt><code>type/</code><i>\$path</i></dt>
<dd>The result is
  <code>file</code>,
  <code>link</code>,
  <code>dir</code>,
  <code>other</code> or
  <code>undef</code>.
  <br />
  Example :
  <a href="$name/type/$LINK"><code>type/$LINK</code></a>
</dd>
</dl>

</blockquote>
<h2>Notes</h2>

<ul>
<li>Updates of the <i>RECENT</i> files are not represented in
  the event-stream.
  Updates of the <i>RECENT</i> files must be reflected in the
  the qdb-database, so qdb-based <i>rrr</i>-clients know when
  to re-sync them.
</li>
<li>a <i>downstream</i> server is always a <i>sleeping beauty</i>,
  although she normally only sleeps for a few minutes.
  Does a <i>downstream</i> server has to keep its own history?
  Or can queries be truthfully answered,
  given some valid local <code><i>last_id</i></code>?
</li>
</ul>

HELP
  }

my $header_sent = 0 ;
binmode ( STDOUT => ':utf8' ) ;

sub TAIL
  { my $date = scalar localtime ;
    <<TAIL ;
<hr noshade="noshade" size="1" />
webmaster\@cs.uu.nl - $date
<a href="http://jigsaw.w3.org/css-validator/check/referer">
<img style="border:0;width:88px;height:31px"
src="http://jigsaw.w3.org/css-validator/images/vcss-blue"
alt="Valid CSS" align="right" />
</a>
<a href="http://validator.w3.org/check?uri=referer;No200=1">
<img src="http://www.w3.org/Icons/valid-xhtml10-blue.png"
alt="valid-xhtml10" border="0" align="right" /></a>
<br clear="all" />
<hr noshade="noshade" size="1" />
TAIL
  }

sub page
  { my $body = shift ;
    my $type = shift || 'plain' ;
    my $status = shift || '200 OK' ;
    print header
      ( -charset => 'utf-8'
      , -type    => "text/$type"
      , -status   => $status
      ) unless $header_sent ++ ;
    print start_html
      ( -title => 'qdb help'
      , -encoding => 'utf-8'
      , -style    => { -code => STYLE }
      ) if $type eq 'html' ;
    print $body ;
    print TAIL, end_html if $type eq 'html' ;
  }

sub as_json
  { my $x = shift ;
    JSON::XS -> new -> canonical(1) -> pretty -> encode
      ( ref $x ? $x : { scalar => $x } ) ;
  }

sub db_conn
  { my $file = shift ;
    my $dbh = DBI -> connect
      ( "dbi:SQLite:dbname=$file", "", ""
      , { AutoCommit => 1
        , RaiseError => 0
        }
      ) ;
    $dbh ;
  }

sub db_select
  { my $dbh  = shift ;
    my %opts =
      ( select   => '*'
      , from     => 'events'
      , where    => undef
      , order_by => undef
      , limit    => undef
      , args     => []
      , @_
      ) ;
    my $qwe  = join ' ', grep { length $_ } map
      { my $kwd = $_ ; $kwd =~ s/_/ / ;
        my $opt = $opts { $_ } ;
        ( defined $opt ? "$kwd $opt" : '' ) ;
      } qw(select from where order_by limit) ;
    print "qwe [$qwe]\n" if $opt{d} ;
    my $sth = $dbh -> prepare ( $qwe )
      or return ( "bad qwe [$qwe]", undef ) ;
    $sth -> execute ( @{ $opts { args } } )
      or return ( "can't exec [$qwe]", undef ) ;
    my $res = [] ;
    while ( my @row = $sth -> fetchrow_array )
      { if ( @row )
          { push @$res, \@row ; }
        else
          { if ( my $err = $sth -> err )
              { return ( "fetch failed [$err]", undef ) ; }
          }
      }
    ( undef, $res ) ;
  }

sub type
  { my $path = shift ;
    return undef unless lstat $path ;
    return 'link' if -l _ ;
    return 'dir'  if -d _ ;
    return 'file' if -f _ ;
    return 'other' ;
  }

my $dbh = db_conn $DB_FILE or Error "can't connect [$DB_FILE]" ;
my $INFO = $ENV { PATH_INFO } || '' ;
$INFO =~ s!/+!/!g ;
$INFO =~ s!^/!! ;
my $RES ;
my $ERR ;
my $PATH ;

if ( $INFO eq '' or $INFO eq 'help' )
  { page HELP, 'html' ; exit ; }
elsif ( $INFO eq 'env' )
  { $RES = \%ENV ; }
elsif ( $INFO =~ /^(count|first_id|last_id|from|path|last)/ )
  { my $cols = 'id, type, path' ;
    if ( $INFO =~ /^count$/ )
      { ( $ERR, $RES ) = db_select ( $dbh, select => "count(1)" ) ;
        $RES = $RES -> [ 0 ] [ 0 ] unless $ERR ;
      }
    elsif ( $INFO =~ /^first_id$/ )
      { ( $ERR, $RES ) = db_select ( $dbh, select => "MIN(id)" ) ;
        $RES = $RES -> [ 0 ] [ 0 ] unless $ERR ;
      }
    elsif ( $INFO =~ /^last_id$/ )
      { ( $ERR, $RES ) = db_select ( $dbh, select => "MAX(id)" ) ;
        $RES = $RES -> [ 0 ] [ 0 ] unless $ERR ;
      }
    elsif ( $INFO =~ m!^from/(\d+)$! )
      { ( $ERR, $RES ) = db_select
          ( $dbh
          , select => $cols
          , where  => "id >= $1"
          , order_by => 'id'
          , limit  => $MAX_RES
          ) ;
      }
    elsif ( $INFO =~ m!^from/(\d+)/limit/(\d+)$! )
      { my $lim = $2 ; $lim = $MAX_RES if $lim > $MAX_RES ;
        ( $ERR, $RES ) = db_select
          ( $dbh
          , select => $cols
          , where  => "id >= $1"
          , order_by => 'id'
          , limit  => $lim
          ) ;
      }
    elsif ( $INFO =~ m!^last/(\d+)$! )
      { my $lim = $1 ; $lim = $MAX_RES if $lim > $MAX_RES ;
        ( $ERR, $RES ) = db_select
          ( $dbh
          , select => $cols
          , order_by => 'id desc'
          , limit  => $lim
          ) ;
        $RES = [ reverse @$RES ] unless $ERR ;
      }
    elsif ( $INFO =~ m!^path/! )
      { my $path = $' ;
        if ( grep $_ eq '..', split m!/!, $path )
          { $ERR = "bad path [$path]" ; }
        else
          { ( $ERR, $RES ) = db_select
              ( $dbh
              , select => $cols
              , where  => 'path = $1'
              , args   => [ $path ]
              ) ;
          }
      }
    else
      { $ERR = "bad query [$INFO]" ; }
  }
elsif ( $INFO =~ m!^(type|stat|lstat|readlink)/! )
  { my $cmd  = $1 ;
    my $path = $' ;
    my $PATH = '/var/ftp/mirror/CPAN/' . $path ;
    if ( grep $_ eq '..', split m!/!, $path )
      { $ERR = "bad path [$path]" ; }
    elsif ( $INFO =~ m!^type/! )
      { $RES = type $PATH ; }
    elsif ( $INFO =~ m!^stat/! )
      { $RES = [ stat $PATH ] ; }
    elsif ( $INFO =~ m!^lstat/! )
      { $RES = [ lstat $PATH ] ; }
    elsif ( $INFO =~ m!^readlink/! )
      { $RES = readlink $PATH ; }
    else
      { $ERR = "bad query" ; }
  }
else
  { $ERR = "bad command [$INFO]" ; }

my $text = as_json { cmd => $INFO, err => $ERR, res => $RES } ;
page $text, 'plain', ( $ERR ? $REQ_BAD : $REQ_OK ) ;