#!/usr/bin/perl

$dbfile="/tmp/testdb"; # Set the right file name here!

=head1 NAME

sdb - Simple Database

=head1 SYNOPSIS

From the command line:

B<sdb> B<-k> I<name> I<key>

B<sdb> B<-d> I<name>

As a CGI script:

GET /cgi-bin/B<sdb>/I<name>/I<id>

POST /cgi-bin/B<sdb>/I<name>/I<id>

=head1 DESCRIPTION

B<sdb> manages a primitive database (backed by a B<DB> file) with a
CGI interface. Everyone can retrieve values via HTTP. To set a value
via HTTP a password is needed.

A value is stored under a key consisting of a I<client name> and
I<resource id>. Name, id and value may be arbitrary strings, but
common usage limits them to (probably non-blank) printable characters.

=head1 OPTIONS

To manage client names and keys (passwords), B<sdb> is called from the
command line with one of the following options:

=over 4

=item B<-k> I<name> I<key>

Set a new I<key> for the given I<name>.

=item B<-d> I<name>

Delete key and all data associated with I<name>.

=back

=head1 SEE ALSO

L<sdbset>, I<cipe.info>.

=head1 AUTHOR

Olaf Titz (olaf@bigred.inka.de). Public domain.

=cut

use CGI;
use MD5;
use Fcntl qw(:flock);
use DB_File;
use Getopt::Std;

$DB=tie %D, "DB_File", $dbfile || die "tie: $!";
$fd=$DB->fd;
open(DBF, "+<&=$fd") || die "dup: $!";

$opt_k=$opt_d=0;
getopts("kd");
if ($opt_k) {
    if ($ARGV[0] && $ARGV[1]) {
	flock(DBF, LOCK_EX);
	$D{"$ARGV[0]$;"}=$ARGV[1];
	flock(DBF, LOCK_UN);
	exit 0;
    } else {
	printf STDERR "+%s+%s+\n", $ARGV[0], $ARGV[1];
	die "usage: $0 -k <id> <key>";
    }
}
if ($opt_d) {
    if ($ARGV[0]) {
	flock(DBF, LOCK_EX);
	@x=();
	grep { /^$ARGV[0]$;/o && push(@x,$_) } keys %D;
	foreach (@x) {
	    delete $D{$_};
	}
	flock(DBF, LOCK_UN);
	exit 0;
    } else {
	printf STDERR "+%s+%s+\n", $ARGV[0], $ARGV[1];
	die "usage: $0 -d <key>";
    }
}

$Q=new CGI;
printf STDERR "<%s>\n", $Q->path_info();
($_, $id, $subid) = split(/\//, $Q->path_info());
if (!$subid) { &error("path"); }
if ($Q->request_method() eq "POST") {
    $t=$Q->param("t");
    if (abs($t-time)>60) { &error("time"); }
    $val=$Q->param("set");
    if (&csum("$id/$subid", $val, $t, $D{"$id$;"}) ne $Q->param("cs")) {
	&error("checksum");
    }
    flock(DBF, LOCK_EX);
    $D{"$id$;$subid"}=$val;
} else {
    flock(DBF, LOCK_SH);
}

print $Q->header("text/plain", "200 OK"), $D{"$id$;$subid"}, "\n";
flock(DBF, LOCK_UN);
exit 0;

# checksum over: id, val, time, key
sub csum
{
    local($i,$v,$t,$k)=@_;
    my $m=new MD5;
    $m->add("$i$v$t$k");
    return $m->hexdigest();
}

sub error
{
    local($x)=@_;
    print $Q->header("text/plain", "400 Request Error"), "Error: $x\n";
    exit 0;
}
