[odin-cgi] / lib / Odin.pm

### -*-perl-*-

package Odin;

use DBI;
use Digest::SHA qw(sha256_hex);
use MIME::Base64;

###--------------------------------------------------------------------------
### Early utilities.

sub merge_hash (\%%) {
  my ($hashref, %defaults) = @_;
  for my $k (keys %defaults)
    { $hashref->{$k} = $defaults{$k} unless exists $hashref->{$k}; }
}

###--------------------------------------------------------------------------
### Configuration.

our $DSN = "dbi:Pg(pg_enable_utf8=>1):host=db";
our $RETRY = 10;
our @BACKOFF = (0.1, 10, 1.5, 0.5, 2.0);

our $BASEURL = "http://odin.gg/";
our $STATIC = "http://odin.gg/";

our $SHORTURL_PATH = "u";
our $PASTEBIN_PATH = "p";

our $URLMAXLEN = 1024;
our @URLPAT = (
  qr{^https?://}
);

our $PASTEMAXLEN = 1024*1024;

our %COOKIE_DEFAULTS = (
  -httponly => undef,
  -max_age => 3600
);

require "config.pl";

our ($SCHEME, $DOMAIN, $BASEPATH) = $BASEURL =~ m!^([^:]+)://([^/]+)(/.*)$!;
merge_hash %COOKIE_DEFAULTS, -domain => $DOMAIN, -path => $BASEPATH;
merge_hash %COOKIE_DEFAULTS, -secure => undef if $SCHEME eq "https";

our $SHORTURL = "$BASEURL$SHORTURL_PATH";
our $PASTEBIN = "$BASEURL$PASTEBIN_PATH";

###--------------------------------------------------------------------------
### Miscellaneous utilities.

our $NOW;
sub update_now () { $NOW = time; }
update_now;

(our $PROG = $0) =~ s:^.*/::;

sub fail_cmdline ($$%) {
  my ($msg, $label, %args) = @_;
  print STDERR "$PROG: $msg\n";
  exit 1;
}

our $FAILPROC = \&fail_cmdline;

sub fail ($;$%) {
  my ($msg, $label, %args) = @_;
  $FAILPROC->($msg, $label, %args);
}

sub set_mason_failproc ($) {
  my ($m) = @_;
  $FAILPROC = sub {
    my ($msg, $label, %args) = @_;
    $m->clear_buffer;
    $m->comp($label, %args);
    $m->abort;
  };
}

sub nice_name ($) {
  my ($s) = @_;
  $s =~ s/\W+//g;
  return lc $s;
}

###--------------------------------------------------------------------------
### Database utilities.

sub open_db (@) {
  my @attr = @_;
  my $db = DBI->connect_cached($DSN, undef, undef, {
    PrintError => 0,
    RaiseError => 1,
    @attr
  });

  my $drv = $db->{Driver}{Name};
  if ($drv eq "Pg") {
    $db->{private_odin_retry_p} = sub { $db->state =~ /^40[0P]01$/ };
  } elsif ($drv eq "SQLite") {
    $db->{private_odin_retry_p} = sub { $db->err == 5 };
  } else {
    $db->{private_odin_retry_p} = sub { 0 };
  }

  return $db;
}

sub xact (&$) {
  my ($body, $db) = @_;
  my @rv;
  my $exc;

  my ($sleep, $maxsleep, $mult, $minvar, $maxvar) = @BACKOFF;
  for (my $i = 0; $i < $RETRY; $i++) {
    $db->begin_work;
    eval { @rv = $body->(); $db->commit; };
    $exc = $@;
    return @rv unless $exc;
    my $retryp = $db->{private_odin_retry_p}();
    eval { $db->rollback; };
    die $exc unless $retryp;
    my $t = $sleep * ($minvar + rand($maxvar - $minvar));
    $sleep *= $mult; $sleep = $max if $sleep > $max;
    select undef, undef, undef, $t;
  }
  die $exc;
}


###--------------------------------------------------------------------------
### Sequence numbers and tagging.

sub next_seq ($$) {
  my ($db, $table) = @_;
  my ($seq) = $db->selectrow_array("SELECT seq FROM $table");
  die "no sequence number in $table" unless defined $seq;
  $db->do("UPDATE $table SET seq = ?", undef, $seq + 1);
  return $seq;
}

my $ALPHABET =
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
my $NALPHA = length $ALPHABET;

sub encode_tag ($) {
  my ($seq) = @_;
  my $tag = "";
  while ($seq) {
    $tag .= substr($ALPHABET, $seq % $NALPHA, 1);
    $seq = int $seq/$NALPHA;
  }
  return $tag;
}

###--------------------------------------------------------------------------
### HTTP utilities.

our %COOKIE;
sub fetch_cookies ($) {
  my ($r) = @_;

  %COOKIE = ();
  my $cookies = $r->header_in("Cookie");
  if (defined $cookies) {
    for my $kv (split /;/, $cookies) {
      my ($k, $v) = split /=/, $kv, 2;
      $k =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
      $v =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
      $v =~ s/\+/ /g;
      $v =~ s/\%([0-9a-f][0-9a-f])/chr hex $1/eg;
      $COOKIE{$k} = $v;
    }
  }
}

sub bake_cookie ($$%) {
  my ($r, $cookie, %attr) = @_;
  merge_hash %attr, %COOKIE_DEFAULTS;
  my @attr = map {
    my $v = $attr{$_}; tr/_-/-/d;
    defined $v ? "$_=$v" : $_
  } keys %attr;
  $r->headers_out->add("Set-Cookie", join "; ", $cookie, @attr);
}

sub path_info ($) {
  my ($r) = @_;
  return $ENV{PATH_INFO} // $r->path_info;
}

###--------------------------------------------------------------------------
### HTML utilities.

sub escapify ($$;$) {
  my ($m, $s, $mode) = @_;
  return $m->interp->apply_escapes($s, $mode // "h");
}

###--------------------------------------------------------------------------
### Access control.

our ($WHO, $WHOSURE);
our ($WHOMATCH, $WHOCMP, $WHOPAT);

sub cgi_who ($) {
  my ($r) = @_;
  my $raddr = $ENV{REMOTE_ADDR} // $r->connection->remote_ip;
  $WHO = ":NET-$raddr"; $WHOSURE = 0;
  $WHOMATCH = "LIKE"; $WHOCMP = ":NET-\%"; $WHOPAT = qr/^:NET-/;
}

sub cmdline_who () {
  $WHO = $ENV{USERV_USER}
    // ($< == $> && $ENV{USER})
    // @{[getpwuid $<]}[0]
    // die "nameless user";
  $WHOMATCH = "="; $WHOCMP = $WHO; $WHOPAT = qr/^\Q$WHO\E$/;
  $WHOSURE = 1;
}

sub new_editkey () {
  open my $fh, "/dev/urandom" or die "open urandom: $!";
  sysread $fh, my $rand, 16;
  (my $edit = encode_base64 $rand) =~ tr:+/=\n:.-:d;
  return $edit, sha256_hex $edit;
}

###--------------------------------------------------------------------------
### URL shortening.

sub get_shorturl ($) {
  my ($tag) = @_;

  my $db = open_db;
  my ($url) = $db->selectrow_array
    ("SELECT url FROM odin_shorturl WHERE tag = ?", undef, $tag);
  fail "tag `$tag' not found", ".notfound", tag => $tag unless defined $url;
  return $url;
}

sub valid_url_p ($) {
  my ($url) = @_;
  return
    length $url < $URLMAXLEN &&
    scalar grep { $url =~ /$_/ } @URLPAT;
}

sub new_shorturl ($) {
  my ($url) = @_;

  valid_url_p $url or fail "invalid url", ".badurl", u => $url;

  my $db = open_db;
  my $tag;
  xact {
    ($tag) = $db->selectrow_array
      ("SELECT tag FROM odin_shorturl WHERE owner $WHOMATCH ? AND url = ?",
       undef, $WHOCMP, $url);
    unless (defined $tag) {
      $tag = encode_tag(next_seq($db, "odin_shorturl_seq"));
      $db->do("INSERT INTO odin_shorturl (tag, stamp, owner, url)
	       VALUES (?, ?, ?, ?)", undef,
	      $tag, $NOW, $WHO, $url);
    }
  } $db;
  return $tag;
}

sub check_shorturl_owner ($$) {
  my ($db, $tag) = @_;

  my ($owner) = $db->selectrow_array
    ("SELECT owner FROM odin_shorturl WHERE tag = ?", undef, $tag);
  fail "tag `$tag' not found", ".notfound", tag => $tag
    unless defined $owner;
  fail "not owner of `$tag'", ".notowner", tag => $tag
    unless $owner =~ /$WHOPAT/;
}

sub update_shorturl ($$) {
  my ($tag, $url) = @_;

  my $db = open_db;
  xact {
    check_shorturl_owner $db, $tag;
    $db->do("UPDATE odin_shorturl SET url = ? WHERE tag = ?",
	    undef, $url, $tag);
  } $db;
}

sub delete_shorturl (@) {
  my (@tags) = @_;

  my $db = open_db;
  xact {
    for my $tag (@tags) {
      check_shorturl_owner $db, $tag;
      $db->do("DELETE FROM odin_shorturl WHERE tag = ?", undef, $tag);
    }
  } $db;
}

###--------------------------------------------------------------------------
### Paste bin.

our %PASTEBIN_DEFAULTS = (
  title => "(untitled)",
  lang => "txt",
  content => ""
);
our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;

sub new_pastebin (\%) {
  my ($new) = @_;

  my $db = open_db;
  my ($editkey, $hash) = new_editkey;
  my $tag;

  merge_hash %$new, %PASTEBIN_DEFAULTS;
  xact {
    $tag = encode_tag next_seq $db, "odin_pastebin_seq";
    $db->do("INSERT INTO odin_pastebin
	       (tag, stamp, edithash, owner, $PASTEBIN_PROPCOLS)
	     VALUES (?, ?, ?, ?, $PASTEBIN_PROPPLACES)", undef,
	    $tag, $NOW, $hash, $WHO, @{$new}{@PASTEBIN_PROPS});
  } $db;
  return $tag, $editkey;
}

sub get_pastebin ($$\%) {
  my ($db, $tag, $props) = @_;

  (my $owner, my $hash, @{$props}{@PASTEBIN_PROPS}) =
    $db->selectrow_array("SELECT owner, edithash, $PASTEBIN_PROPCOLS
			  FROM odin_pastebin WHERE tag = ?",
			 undef, $tag);
  fail "tag `$tag' not found", ".notfound", tag => $tag
    unless defined $owner;
  return $owner, $hash;
}

sub get_pastebin_check_owner ($$\%) {
  my ($db, $tag, $props) = @_;

  my ($owner, $hash) = get_pastebin $db, $tag, %$props;
  fail "not owner of `$tag'", ".notowner", tag => $tag
    unless $WHOSURE && $WHO eq $owner;
}

sub get_pastebin_check_editkey_or_owner ($$$\%) {
  my ($db, $tag, $editkey, $props) = @_;

  if (!defined $editkey) { get_pastebin_check_owner $db, $tag, %$props; }
  else {
    my ($owner, $hash) = get_pastebin $db, $tag, %$props;
    fail "incorrect edit key for `$tag'", ".badhash", tag => $tag
      unless $hash eq sha256_hex $editkey;
  }
}

sub rekey_pastebin ($) {
  my ($tag) = @_;

  my $db = open_db;
  my $editkey;
  xact {
    get_pastebin_check_owner $db, $tag, my %hunoz;
    ($editkey, my $hash) = new_editkey;
    $db->do("UPDATE odin_pastebin SET edithash = ? WHERE tag = ?",
	    undef, $hash, $tag);
  } $db;
  return $editkey;
}

sub claim_pastebin ($$) {
  my ($tag, $editkey) = @_;

  my $db = open_db;
  $WHOSURE or fail "you can't claim pastes", ".notsure";
  xact {
    get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
    $db->do("UPDATE odin_pastebin SET owner = ? WHERE tag = ?",
	    undef, $WHO, $tag);
  } $db;
}

sub update_pastebin ($$\%) {
  my ($tag, $editkey, $new) = @_;

  my $db = open_db;
  my $editp = 0;
  xact {
    get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %old;
    for my $p (@PASTEBIN_PROPS) {
      if (!defined $new->{$p}) { $new->{$p} = $old{$p}; }
      else {
	$db->do("UPDATE odin_pastebin SET $p = ? WHERE tag = ?",
		undef, $new->{$p}, $tag)
	  unless $new->{$p} eq $old{$p};
	$editp = 1;
      }
    }
  } $db;
  return $editp;
}

sub delete_pastebin (@) {
  my @a = @_;
  my $db = open_db;
  xact {
    while (@a) {
      (my $tag, my $editkey, @a) = @a;
      get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
      $db->do("DELETE FROM odin_pastebin WHERE tag = ?", undef, $tag);
    }
  } $db;
}

sub tidy_pastebin_content ($) {
  my ($content) = @_;
  return undef unless defined $content;
  $content =~ tr/\r//d;
  $content =~ s/([^\n])\z/$1\n/;
  length $content <= $PASTEMAXLEN or
    fail "invalid paste content", ".badpaste";
  return $content;
}

###--------------------------------------------------------------------------
### Simple option parser.

package Odin::OptParse;

sub new {
  my ($cls, @args) = @_;
  return bless {
    cur => "",
    args => \@args,
    opt => undef,
    ok => 1
  }, $cls;
}

sub get {
  my ($me) = @_;
  if (!length $me->{cur}) {
    my $args = $me->{args};
    if (!@$args) { return undef; }
    elsif ($args->[0] =~ /^[^-]|^-$/) { return undef; }
    elsif ($args->[0] eq "--") { shift @$args; return undef; }
    $me->{cur} = substr shift @$args, 1;
  }
  my $o = $me->{opt} = substr $me->{cur}, 0, 1;
  $me->{cur} = substr $me->{cur}, 1;
  return $o;
}

sub arg {
  my ($me) = @_;
  my $a;
  if (length $me->{cur}) { $a = $me->{cur}; $me->{cur} = ""; }
  elsif (@{$me->{args}}) { $a = shift @{$me->{args}}; }
  else { $a = undef; $me->err("option `-$me->{opt}' requires an argument"); }
  return $a;
}

sub rest { return @{$_[0]->{args}}; }
sub ok { return $_[0]->{ok}; }
sub bad { $_[0]->{ok} = 0; }
sub err { $_[0]->bad; print STDERR "$PROG: $_[1]\n"; }
sub unk { $_[0]->err("unknown option `-$_[0]->{opt}'"); }

###----- That's all, folks --------------------------------------------------

1;
Commit	Line	Data
be24e9af MW	1	### --perl--
	2
	3	package Odin;
	4
	5	use DBI;
	6	use Digest::SHA qw(sha256_hex);
	7	use MIME::Base64;
	8
	9	###--------------------------------------------------------------------------
	10	### Early utilities.
	11
	12	sub merge_hash (\%%) {
	13	my ($hashref, %defaults) = @_;
	14	for my $k (keys %defaults)
	15	{ $hashref->{$k} = $defaults{$k} unless exists $hashref->{$k}; }
	16	}
	17
	18	###--------------------------------------------------------------------------
	19	### Configuration.
	20
	21	our $DSN = "dbi:Pg(pg_enable_utf8=>1):host=db";
	22	our $RETRY = 10;
	23	our @BACKOFF = (0.1, 10, 1.5, 0.5, 2.0);
	24
	25	our $BASEURL = "http://odin.gg/";
	26	our $STATIC = "http://odin.gg/";
	27
	28	our $SHORTURL_PATH = "u";
	29	our $PASTEBIN_PATH = "p";
	30
	31	our $URLMAXLEN = 1024;
	32	our @URLPAT = (
	33	qr{^https?://}
	34	);
	35
fc8074b3 MW	36	our $PASTEMAXLEN = 1024*1024;
fc8074b3 MW	37
be24e9af MW	38	our %COOKIE_DEFAULTS = (
	39	-httponly => undef,
	40	-max_age => 3600
	41	);
	42
	43	require "config.pl";
	44
	45	our ($SCHEME, $DOMAIN, $BASEPATH) = $BASEURL =~ m!^([^:]+)://([^/]+)(/.*)$!;
	46	merge_hash %COOKIE_DEFAULTS, -domain => $DOMAIN, -path => $BASEPATH;
	47	merge_hash %COOKIE_DEFAULTS, -secure => undef if $SCHEME eq "https";
	48
	49	our $SHORTURL = "$BASEURL$SHORTURL_PATH";
	50	our $PASTEBIN = "$BASEURL$PASTEBIN_PATH";
	51
	52	###--------------------------------------------------------------------------
	53	### Miscellaneous utilities.
	54
503f7910 MW	55	our $NOW;
	56	sub update_now () { $NOW = time; }
	57	update_now;
	58
be24e9af MW	59	(our $PROG = $0) =~ s:^.*/::;
	60
	61	sub fail_cmdline ($$%) {
	62	my ($msg, $label, %args) = @_;
	63	print STDERR "$PROG: $msg\n";
	64	exit 1;
	65	}
	66
	67	our $FAILPROC = \&fail_cmdline;
	68
	69	sub fail ($;$%) {
	70	my ($msg, $label, %args) = @_;
	71	$FAILPROC->($msg, $label, %args);
	72	}
	73
	74	sub set_mason_failproc ($) {
	75	my ($m) = @_;
	76	$FAILPROC = sub {
	77	my ($msg, $label, %args) = @_;
	78	$m->clear_buffer;
	79	$m->comp($label, %args);
	80	$m->abort;
	81	};
	82	}
	83
	84	sub nice_name ($) {
	85	my ($s) = @_;
	86	$s =~ s/\W+//g;
	87	return lc $s;
	88	}
	89
	90	###--------------------------------------------------------------------------
	91	### Database utilities.
	92
	93	sub open_db (@) {
	94	my @attr = @_;
	95	my $db = DBI->connect_cached($DSN, undef, undef, {
	96	PrintError => 0,
	97	RaiseError => 1,
	98	@attr
	99	});
	100
	101	my $drv = $db->{Driver}{Name};
	102	if ($drv eq "Pg") {
	103	$db->{private_odin_retry_p} = sub { $db->state =~ /^40[0P]01$/ };
be24e9af MW	104	} elsif ($drv eq "SQLite") {
be24e9af MW	105	$db->{private_odin_retry_p} = sub { $db->err == 5 };
be24e9af	106	} else {
3300e9a2	107	$db->{private_odin_retry_p} = sub { 0 };
be24e9af MW	108	}
	109
	110	return $db;
	111	}
	112
	113	sub xact (&$) {
	114	my ($body, $db) = @_;
	115	my @rv;
	116	my $exc;
	117
	118	my ($sleep, $maxsleep, $mult, $minvar, $maxvar) = @BACKOFF;
	119	for (my $i = 0; $i < $RETRY; $i++) {
	120	$db->begin_work;
	121	eval { @rv = $body->(); $db->commit; };
	122	$exc = $@;
	123	return @rv unless $exc;
	124	my $retryp = $db->{private_odin_retry_p}();
	125	eval { $db->rollback; };
	126	die $exc unless $retryp;
	127	my $t = $sleep * ($minvar + rand($maxvar - $minvar));
	128	$sleep *= $mult; $sleep = $max if $sleep > $max;
	129	select undef, undef, undef, $t;
	130	}
	131	die $exc;
	132	}
	133
be24e9af MW	134
	135	###--------------------------------------------------------------------------
	136	### Sequence numbers and tagging.
	137
	138	sub next_seq ($$) {
	139	my ($db, $table) = @_;
	140	my ($seq) = $db->selectrow_array("SELECT seq FROM $table");
	141	die "no sequence number in $table" unless defined $seq;
	142	$db->do("UPDATE $table SET seq = ?", undef, $seq + 1);
	143	return $seq;
	144	}
	145
	146	my $ALPHABET =
	147	"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
	148	my $NALPHA = length $ALPHABET;
	149
	150	sub encode_tag ($) {
	151	my ($seq) = @_;
	152	my $tag = "";
	153	while ($seq) {
	154	$tag .= substr($ALPHABET, $seq % $NALPHA, 1);
	155	$seq = int $seq/$NALPHA;
	156	}
	157	return $tag;
	158	}
	159
	160	###--------------------------------------------------------------------------
	161	### HTTP utilities.
	162
	163	our %COOKIE;
	164	sub fetch_cookies ($) {
	165	my ($r) = @_;
	166
	167	%COOKIE = ();
	168	my $cookies = $r->header_in("Cookie");
	169	if (defined $cookies) {
	170	for my $kv (split /;/, $cookies) {
	171	my ($k, $v) = split /=/, $kv, 2;
	172	$k =~ s/^\s(\|\S\|\S.\S)\s*$/$1/;
	173	$v =~ s/^\s(\|\S\|\S.\S)\s*$/$1/;
	174	$v =~ s/\+/ /g;
	175	$v =~ s/\%([0-9a-f][0-9a-f])/chr hex $1/eg;
	176	$COOKIE{$k} = $v;
	177	}
	178	}
	179	}
	180
	181	sub bake_cookie ($$%) {
	182	my ($r, $cookie, %attr) = @_;
	183	merge_hash %attr, %COOKIE_DEFAULTS;
	184	my @attr = map {
	185	my $v = $attr{$_}; tr/_-/-/d;
	186	defined $v ? "$_=$v" : $_
	187	} keys %attr;
	188	$r->headers_out->add("Set-Cookie", join "; ", $cookie, @attr);
	189	}
	190
	191	sub path_info ($) {
	192	my ($r) = @_;
	193	return $ENV{PATH_INFO} // $r->path_info;
	194	}
	195
	196	###--------------------------------------------------------------------------
	197	### HTML utilities.
198
199	sub escapify ($$;$) {
200	my ($m, $s, $mode) = @_;
201	return $m->interp->apply_escapes($s, $mode // "h");
202	}
203
204	###--------------------------------------------------------------------------
205	### Access control.
206
207	our ($WHO, $WHOSURE);
208	our ($WHOMATCH, $WHOCMP, $WHOPAT);
209
210	sub cgi_who ($) {
211	my ($r) = @_;
212	my $raddr = $ENV{REMOTE_ADDR} // $r->connection->remote_ip;
213	$WHO = ":NET-$raddr"; $WHOSURE = 0;
214	$WHOMATCH = "LIKE"; $WHOCMP = ":NET-\%"; $WHOPAT = qr/^:NET-/;
215	}
216
217	sub cmdline_who () {
218	$WHO = $ENV{USERV_USER}
219	// ($< == $> && $ENV{USER})
220	// @{[getpwuid $<]}[0]
221	// die "nameless user";
222	$WHOMATCH = "="; $WHOCMP = $WHO; $WHOPAT = qr/^\Q$WHO\E$/;
223	$WHOSURE = 1;
224	}
225
226	sub new_editkey () {
227	open my $fh, "/dev/urandom" or die "open urandom: $!";
228	sysread $fh, my $rand, 16;
229	(my $edit = encode_base64 $rand) =~ tr:+/=\n:.-:d;
230	return $edit, sha256_hex $edit;
231	}
232
233	###--------------------------------------------------------------------------
234	### URL shortening.
235
236	sub get_shorturl ($) {
237	my ($tag) = @_;
238
239	my $db = open_db;
240	my ($url) = $db->selectrow_array
241	("SELECT url FROM odin_shorturl WHERE tag = ?", undef, $tag);
242	fail "tag `$tag' not found", ".notfound", tag => $tag unless defined $url;
243	return $url;
244	}
245
246	sub valid_url_p ($) {
247	my ($url) = @_;
248	return
249	length $url < $URLMAXLEN &&
250	scalar grep { $url =~ /$_/ } @URLPAT;
251	}
252
253	sub new_shorturl ($) {
254	my ($url) = @_;
255
256	valid_url_p $url or fail "invalid url", ".badurl", u => $url;
257
258	my $db = open_db;
259	my $tag;
260	xact {
261	($tag) = $db->selectrow_array
262	("SELECT tag FROM odin_shorturl WHERE owner $WHOMATCH ? AND url = ?",
263	undef, $WHOCMP, $url);
264	unless (defined $tag) {
265	$tag = encode_tag(next_seq($db, "odin_shorturl_seq"));
3300e9a2 MW	266	$db->do("INSERT INTO odin_shorturl (tag, stamp, owner, url)
	267	VALUES (?, ?, ?, ?)", undef,
	268	$tag, $NOW, $WHO, $url);
be24e9af MW	269	}
	270	} $db;
	271	return $tag;
	272	}
	273
	274	sub check_shorturl_owner ($$) {
	275	my ($db, $tag) = @_;
	276
	277	my ($owner) = $db->selectrow_array
	278	("SELECT owner FROM odin_shorturl WHERE tag = ?", undef, $tag);
	279	fail "tag `$tag' not found", ".notfound", tag => $tag
	280	unless defined $owner;
	281	fail "not owner of `$tag'", ".notowner", tag => $tag
	282	unless $owner =~ /$WHOPAT/;
	283	}
	284
	285	sub update_shorturl ($$) {
	286	my ($tag, $url) = @_;
	287
	288	my $db = open_db;
	289	xact {
	290	check_shorturl_owner $db, $tag;
	291	$db->do("UPDATE odin_shorturl SET url = ? WHERE tag = ?",
	292	undef, $url, $tag);
	293	} $db;
	294	}
	295
	296	sub delete_shorturl (@) {
	297	my (@tags) = @_;
	298
	299	my $db = open_db;
	300	xact {
	301	for my $tag (@tags) {
	302	check_shorturl_owner $db, $tag;
	303	$db->do("DELETE FROM odin_shorturl WHERE tag = ?", undef, $tag);
	304	}
	305	} $db;
	306	}
	307
	308	###--------------------------------------------------------------------------
	309	### Paste bin.
	310
	311	our %PASTEBIN_DEFAULTS = (
	312	title => "(untitled)",
97a33b9c	313	lang => "txt",
be24e9af MW	314	content => ""
	315	);
	316	our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
	317	our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
	318	our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;
	319
	320	sub new_pastebin (\%) {
	321	my ($new) = @_;
	322
	323	my $db = open_db;
	324	my ($editkey, $hash) = new_editkey;
	325	my $tag;
	326
	327	merge_hash %$new, %PASTEBIN_DEFAULTS;
	328	xact {
	329	$tag = encode_tag next_seq $db, "odin_pastebin_seq";
	330	$db->do("INSERT INTO odin_pastebin
3300e9a2 MW	331	(tag, stamp, edithash, owner, $PASTEBIN_PROPCOLS)
	332	VALUES (?, ?, ?, ?, $PASTEBIN_PROPPLACES)", undef,
	333	$tag, $NOW, $hash, $WHO, @{$new}{@PASTEBIN_PROPS});
be24e9af MW	334	} $db;
	335	return $tag, $editkey;
	336	}
	337
	338	sub get_pastebin ($$\%) {
	339	my ($db, $tag, $props) = @_;
	340
	341	(my $owner, my $hash, @{$props}{@PASTEBIN_PROPS}) =
	342	$db->selectrow_array("SELECT owner, edithash, $PASTEBIN_PROPCOLS
	343	FROM odin_pastebin WHERE tag = ?",
	344	undef, $tag);
	345	fail "tag `$tag' not found", ".notfound", tag => $tag
	346	unless defined $owner;
	347	return $owner, $hash;
	348	}
	349
	350	sub get_pastebin_check_owner ($$\%) {
	351	my ($db, $tag, $props) = @_;
	352
	353	my ($owner, $hash) = get_pastebin $db, $tag, %$props;
	354	fail "not owner of `$tag'", ".notowner", tag => $tag
	355	unless $WHOSURE && $WHO eq $owner;
	356	}
	357
	358	sub get_pastebin_check_editkey_or_owner ($$$\%) {
	359	my ($db, $tag, $editkey, $props) = @_;
	360
	361	if (!defined $editkey) { get_pastebin_check_owner $db, $tag, %$props; }
	362	else {
	363	my ($owner, $hash) = get_pastebin $db, $tag, %$props;
	364	fail "incorrect edit key for `$tag'", ".badhash", tag => $tag
	365	unless $hash eq sha256_hex $editkey;
	366	}
	367	}
	368
	369	sub rekey_pastebin ($) {
	370	my ($tag) = @_;
	371
	372	my $db = open_db;
	373	my $editkey;
	374	xact {
	375	get_pastebin_check_owner $db, $tag, my %hunoz;
	376	($editkey, my $hash) = new_editkey;
	377	$db->do("UPDATE odin_pastebin SET edithash = ? WHERE tag = ?",
	378	undef, $hash, $tag);
	379	} $db;
	380	return $editkey;
	381	}
	382
	383	sub claim_pastebin ($$) {
	384	my ($tag, $editkey) = @_;
	385
	386	my $db = open_db;
	387	$WHOSURE or fail "you can't claim pastes", ".notsure";
	388	xact {
	389	get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
	390	$db->do("UPDATE odin_pastebin SET owner = ? WHERE tag = ?",
	391	undef, $WHO, $tag);
	392	} $db;
	393	}
	394
	395	sub update_pastebin ($$\%) {
	396	my ($tag, $editkey, $new) = @_;
	397
398	my $db = open_db;
399	my $editp = 0;
400	xact {
401	get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %old;
402	for my $p (@PASTEBIN_PROPS) {
403	if (!defined $new->{$p}) { $new->{$p} = $old{$p}; }
404	else {
405	$db->do("UPDATE odin_pastebin SET $p = ? WHERE tag = ?",
406	undef, $new->{$p}, $tag)
407	unless $new->{$p} eq $old{$p};
408	$editp = 1;
409	}
410	}
411	} $db;
412	return $editp;
413	}
414
415	sub delete_pastebin (@) {
416	my @a = @_;
417	my $db = open_db;
418	xact {
419	while (@a) {
420	(my $tag, my $editkey, @a) = @a;
421	get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
422	$db->do("DELETE FROM odin_pastebin WHERE tag = ?", undef, $tag);
423	}
424	} $db;
425	}
426
427	sub tidy_pastebin_content ($) {
428	my ($content) = @_;
429	return undef unless defined $content;
430	$content =~ tr/\r//d;
431	$content =~ s/([^\n])\z/$1\n/;
fc8074b3 MW	432	length $content <= $PASTEMAXLEN or
fc8074b3 MW	433	fail "invalid paste content", ".badpaste";
be24e9af MW	434	return $content;
	435	}
	436
f0bcb39a MW	437	###--------------------------------------------------------------------------
	438	### Simple option parser.
	439
	440	package Odin::OptParse;
	441
	442	sub new {
	443	my ($cls, @args) = @_;
	444	return bless {
	445	cur => "",
	446	args => \@args,
	447	opt => undef,
	448	ok => 1
	449	}, $cls;
	450	}
	451
	452	sub get {
	453	my ($me) = @_;
	454	if (!length $me->{cur}) {
	455	my $args = $me->{args};
	456	if (!@$args) { return undef; }
	457	elsif ($args->[0] =~ /^[^-]\|^-$/) { return undef; }
	458	elsif ($args->[0] eq "--") { shift @$args; return undef; }
	459	$me->{cur} = substr shift @$args, 1;
	460	}
	461	my $o = $me->{opt} = substr $me->{cur}, 0, 1;
	462	$me->{cur} = substr $me->{cur}, 1;
	463	return $o;
	464	}
	465
	466	sub arg {
	467	my ($me) = @_;
	468	my $a;
	469	if (length $me->{cur}) { $a = $me->{cur}; $me->{cur} = ""; }
	470	elsif (@{$me->{args}}) { $a = shift @{$me->{args}}; }
	471	else { $a = undef; $me->err("option `-$me->{opt}' requires an argument"); }
	472	return $a;
	473	}
	474
	475	sub rest { return @{$_[0]->{args}}; }
	476	sub ok { return $_[0]->{ok}; }
	477	sub bad { $_[0]->{ok} = 0; }
	478	sub err { $_[0]->bad; print STDERR "$PROG: $_[1]\n"; }
	479	sub unk { $_[0]->err("unknown option `-$_[0]->{opt}'"); }
	480
be24e9af MW	481	###----- That's all, folks --------------------------------------------------
	482
	483	1;