[odin-cgi] / lib / Odin.pm

### -*-perl-*-

package Odin;

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

###--------------------------------------------------------------------------
### 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;
}

sub print_columns (@) {
  my @col = reverse @_;
  my @fmt = ();
  my @val = ();
  while (@col && $col[1] eq "") { splice @col, 0, 2; }
  my ($wd, $v) = splice @col, 0, 2;
  push @fmt, "%s"; push @val, $v;
  while (@col) {
    my ($wd, $v) = splice @col, 0, 2;
    push @fmt, "%-${wd}s";
    push @val, $v;
  }
  printf join("  ", reverse @fmt) . "\n", reverse @val;
}

sub fmt_time ($) {
  my ($t) = @_;
  return $t == -1 ? "--" : strftime "%Y-%m-%d %H:%M:%S %z", localtime $t;
}

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