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

sub insert_record ($$%) {
  my ($db, $table, %fields) = @_;
  my @var = ();
  my @val = ();

  for my $v (keys %fields) {
    push @var, $v;
    push @val, $fields{$v};
  }
  $db->do("INSERT INTO $table (" . join(", ", @var) . ")
	   VALUES (" . join(", ", map { "?" } @var) . ")", undef, @val);
}

###--------------------------------------------------------------------------
### 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"));
      insert_record $db, "odin_shorturl",
	tag => $tag, stamp => $NOW, owner => $WHO, url => $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";
    insert_record $db, "odin_pastebin",
      tag => $tag, stamp => $NOW, edithash => $hash, owner => $WHO,
      %$new;
  } $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
818d8028 MW	155	sub insert_record ($$%) {
	156	my ($db, $table, %fields) = @_;
	157	my @var = ();
	158	my @val = ();
	159
	160	for my $v (keys %fields) {
	161	push @var, $v;
	162	push @val, $fields{$v};
	163	}
	164	$db->do("INSERT INTO $table (" . join(", ", @var) . ")
	165	VALUES (" . join(", ", map { "?" } @var) . ")", undef, @val);
	166	}
be24e9af MW	167
	168	###--------------------------------------------------------------------------
	169	### Sequence numbers and tagging.
	170
	171	sub next_seq ($$) {
	172	my ($db, $table) = @_;
	173	my ($seq) = $db->selectrow_array("SELECT seq FROM $table");
	174	die "no sequence number in $table" unless defined $seq;
	175	$db->do("UPDATE $table SET seq = ?", undef, $seq + 1);
	176	return $seq;
	177	}
	178
	179	my $ALPHABET =
	180	"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
	181	my $NALPHA = length $ALPHABET;
	182
	183	sub encode_tag ($) {
	184	my ($seq) = @_;
	185	my $tag = "";
	186	while ($seq) {
	187	$tag .= substr($ALPHABET, $seq % $NALPHA, 1);
	188	$seq = int $seq/$NALPHA;
	189	}
	190	return $tag;
	191	}
	192
	193	###--------------------------------------------------------------------------
	194	### HTTP utilities.
	195
	196	our %COOKIE;
	197	sub fetch_cookies ($) {
	198	my ($r) = @_;
	199
	200	%COOKIE = ();
	201	my $cookies = $r->header_in("Cookie");
	202	if (defined $cookies) {
	203	for my $kv (split /;/, $cookies) {
	204	my ($k, $v) = split /=/, $kv, 2;
	205	$k =~ s/^\s(\|\S\|\S.\S)\s*$/$1/;
	206	$v =~ s/^\s(\|\S\|\S.\S)\s*$/$1/;
	207	$v =~ s/\+/ /g;
	208	$v =~ s/\%([0-9a-f][0-9a-f])/chr hex $1/eg;
	209	$COOKIE{$k} = $v;
	210	}
	211	}
	212	}
	213
	214	sub bake_cookie ($$%) {
	215	my ($r, $cookie, %attr) = @_;
	216	merge_hash %attr, %COOKIE_DEFAULTS;
	217	my @attr = map {
	218	my $v = $attr{$_}; tr/_-/-/d;
	219	defined $v ? "$_=$v" : $_
	220	} keys %attr;
	221	$r->headers_out->add("Set-Cookie", join "; ", $cookie, @attr);
	222	}
	223
	224	sub path_info ($) {
	225	my ($r) = @_;
	226	return $ENV{PATH_INFO} // $r->path_info;
	227	}
	228
	229	###--------------------------------------------------------------------------
	230	### HTML utilities.
231
232	sub escapify ($$;$) {
233	my ($m, $s, $mode) = @_;
234	return $m->interp->apply_escapes($s, $mode // "h");
235	}
236
237	###--------------------------------------------------------------------------
238	### Access control.
239
240	our ($WHO, $WHOSURE);
241	our ($WHOMATCH, $WHOCMP, $WHOPAT);
242
243	sub cgi_who ($) {
244	my ($r) = @_;
245	my $raddr = $ENV{REMOTE_ADDR} // $r->connection->remote_ip;
246	$WHO = ":NET-$raddr"; $WHOSURE = 0;
247	$WHOMATCH = "LIKE"; $WHOCMP = ":NET-\%"; $WHOPAT = qr/^:NET-/;
248	}
249
250	sub cmdline_who () {
251	$WHO = $ENV{USERV_USER}
252	// ($< == $> && $ENV{USER})
253	// @{[getpwuid $<]}[0]
254	// die "nameless user";
255	$WHOMATCH = "="; $WHOCMP = $WHO; $WHOPAT = qr/^\Q$WHO\E$/;
256	$WHOSURE = 1;
257	}
258
259	sub new_editkey () {
260	open my $fh, "/dev/urandom" or die "open urandom: $!";
261	sysread $fh, my $rand, 16;
262	(my $edit = encode_base64 $rand) =~ tr:+/=\n:.-:d;
263	return $edit, sha256_hex $edit;
264	}
265
266	###--------------------------------------------------------------------------
267	### URL shortening.
268
269	sub get_shorturl ($) {
270	my ($tag) = @_;
271
272	my $db = open_db;
273	my ($url) = $db->selectrow_array
274	("SELECT url FROM odin_shorturl WHERE tag = ?", undef, $tag);
275	fail "tag `$tag' not found", ".notfound", tag => $tag unless defined $url;
276	return $url;
277	}
278
279	sub valid_url_p ($) {
280	my ($url) = @_;
281	return
282	length $url < $URLMAXLEN &&
283	scalar grep { $url =~ /$_/ } @URLPAT;
284	}
285
286	sub new_shorturl ($) {
287	my ($url) = @_;
288
289	valid_url_p $url or fail "invalid url", ".badurl", u => $url;
290
291	my $db = open_db;
292	my $tag;
293	xact {
294	($tag) = $db->selectrow_array
295	("SELECT tag FROM odin_shorturl WHERE owner $WHOMATCH ? AND url = ?",
296	undef, $WHOCMP, $url);
297	unless (defined $tag) {
298	$tag = encode_tag(next_seq($db, "odin_shorturl_seq"));
818d8028 MW	299	insert_record $db, "odin_shorturl",
818d8028 MW	300	tag => $tag, stamp => $NOW, owner => $WHO, url => $url;
be24e9af MW	301	}
	302	} $db;
	303	return $tag;
	304	}
	305
	306	sub check_shorturl_owner ($$) {
	307	my ($db, $tag) = @_;
	308
	309	my ($owner) = $db->selectrow_array
	310	("SELECT owner FROM odin_shorturl WHERE tag = ?", undef, $tag);
	311	fail "tag `$tag' not found", ".notfound", tag => $tag
	312	unless defined $owner;
	313	fail "not owner of `$tag'", ".notowner", tag => $tag
	314	unless $owner =~ /$WHOPAT/;
	315	}
	316
	317	sub update_shorturl ($$) {
	318	my ($tag, $url) = @_;
	319
	320	my $db = open_db;
	321	xact {
	322	check_shorturl_owner $db, $tag;
	323	$db->do("UPDATE odin_shorturl SET url = ? WHERE tag = ?",
	324	undef, $url, $tag);
	325	} $db;
	326	}
	327
	328	sub delete_shorturl (@) {
	329	my (@tags) = @_;
	330
	331	my $db = open_db;
	332	xact {
	333	for my $tag (@tags) {
	334	check_shorturl_owner $db, $tag;
	335	$db->do("DELETE FROM odin_shorturl WHERE tag = ?", undef, $tag);
	336	}
	337	} $db;
	338	}
	339
	340	###--------------------------------------------------------------------------
	341	### Paste bin.
	342
	343	our %PASTEBIN_DEFAULTS = (
	344	title => "(untitled)",
97a33b9c	345	lang => "txt",
be24e9af MW	346	content => ""
	347	);
	348	our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
	349	our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
	350	our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;
	351
	352	sub new_pastebin (\%) {
	353	my ($new) = @_;
	354
	355	my $db = open_db;
	356	my ($editkey, $hash) = new_editkey;
	357	my $tag;
	358
	359	merge_hash %$new, %PASTEBIN_DEFAULTS;
	360	xact {
	361	$tag = encode_tag next_seq $db, "odin_pastebin_seq";
818d8028 MW	362	insert_record $db, "odin_pastebin",
	363	tag => $tag, stamp => $NOW, edithash => $hash, owner => $WHO,
	364	%$new;
be24e9af MW	365	} $db;
	366	return $tag, $editkey;
	367	}
	368
	369	sub get_pastebin ($$\%) {
	370	my ($db, $tag, $props) = @_;
	371
	372	(my $owner, my $hash, @{$props}{@PASTEBIN_PROPS}) =
	373	$db->selectrow_array("SELECT owner, edithash, $PASTEBIN_PROPCOLS
	374	FROM odin_pastebin WHERE tag = ?",
	375	undef, $tag);
	376	fail "tag `$tag' not found", ".notfound", tag => $tag
	377	unless defined $owner;
	378	return $owner, $hash;
	379	}
	380
	381	sub get_pastebin_check_owner ($$\%) {
	382	my ($db, $tag, $props) = @_;
	383
	384	my ($owner, $hash) = get_pastebin $db, $tag, %$props;
	385	fail "not owner of `$tag'", ".notowner", tag => $tag
	386	unless $WHOSURE && $WHO eq $owner;
	387	}
	388
	389	sub get_pastebin_check_editkey_or_owner ($$$\%) {
	390	my ($db, $tag, $editkey, $props) = @_;
	391
	392	if (!defined $editkey) { get_pastebin_check_owner $db, $tag, %$props; }
	393	else {
	394	my ($owner, $hash) = get_pastebin $db, $tag, %$props;
	395	fail "incorrect edit key for `$tag'", ".badhash", tag => $tag
	396	unless $hash eq sha256_hex $editkey;
	397	}
	398	}
	399
	400	sub rekey_pastebin ($) {
	401	my ($tag) = @_;
	402
	403	my $db = open_db;
	404	my $editkey;
	405	xact {
	406	get_pastebin_check_owner $db, $tag, my %hunoz;
	407	($editkey, my $hash) = new_editkey;
	408	$db->do("UPDATE odin_pastebin SET edithash = ? WHERE tag = ?",
	409	undef, $hash, $tag);
	410	} $db;
	411	return $editkey;
	412	}
	413
	414	sub claim_pastebin ($$) {
	415	my ($tag, $editkey) = @_;
	416
	417	my $db = open_db;
	418	$WHOSURE or fail "you can't claim pastes", ".notsure";
	419	xact {
	420	get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
	421	$db->do("UPDATE odin_pastebin SET owner = ? WHERE tag = ?",
	422	undef, $WHO, $tag);
	423	} $db;
	424	}
	425
	426	sub update_pastebin ($$\%) {
	427	my ($tag, $editkey, $new) = @_;
	428
429	my $db = open_db;
430	my $editp = 0;
431	xact {
432	get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %old;
433	for my $p (@PASTEBIN_PROPS) {
434	if (!defined $new->{$p}) { $new->{$p} = $old{$p}; }
435	else {
436	$db->do("UPDATE odin_pastebin SET $p = ? WHERE tag = ?",
437	undef, $new->{$p}, $tag)
438	unless $new->{$p} eq $old{$p};
439	$editp = 1;
440	}
441	}
442	} $db;
443	return $editp;
444	}
445
446	sub delete_pastebin (@) {
447	my @a = @_;
448	my $db = open_db;
449	xact {
450	while (@a) {
451	(my $tag, my $editkey, @a) = @a;
452	get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
453	$db->do("DELETE FROM odin_pastebin WHERE tag = ?", undef, $tag);
454	}
455	} $db;
456	}
457
458	sub tidy_pastebin_content ($) {
459	my ($content) = @_;
460	return undef unless defined $content;
461	$content =~ tr/\r//d;
462	$content =~ s/([^\n])\z/$1\n/;
fc8074b3 MW	463	length $content <= $PASTEMAXLEN or
fc8074b3 MW	464	fail "invalid paste content", ".badpaste";
be24e9af MW	465	return $content;
	466	}
	467
f0bcb39a MW	468	###--------------------------------------------------------------------------
	469	### Simple option parser.
	470
	471	package Odin::OptParse;
	472
	473	sub new {
	474	my ($cls, @args) = @_;
	475	return bless {
	476	cur => "",
	477	args => \@args,
	478	opt => undef,
	479	ok => 1
	480	}, $cls;
	481	}
	482
	483	sub get {
	484	my ($me) = @_;
	485	if (!length $me->{cur}) {
	486	my $args = $me->{args};
	487	if (!@$args) { return undef; }
	488	elsif ($args->[0] =~ /^[^-]\|^-$/) { return undef; }
	489	elsif ($args->[0] eq "--") { shift @$args; return undef; }
	490	$me->{cur} = substr shift @$args, 1;
	491	}
	492	my $o = $me->{opt} = substr $me->{cur}, 0, 1;
	493	$me->{cur} = substr $me->{cur}, 1;
	494	return $o;
	495	}
	496
	497	sub arg {
	498	my ($me) = @_;
	499	my $a;
	500	if (length $me->{cur}) { $a = $me->{cur}; $me->{cur} = ""; }
	501	elsif (@{$me->{args}}) { $a = shift @{$me->{args}}; }
	502	else { $a = undef; $me->err("option `-$me->{opt}' requires an argument"); }
	503	return $a;
	504	}
	505
	506	sub rest { return @{$_[0]->{args}}; }
	507	sub ok { return $_[0]->{ok}; }
	508	sub bad { $_[0]->{ok} = 0; }
	509	sub err { $_[0]->bad; print STDERR "$PROG: $_[1]\n"; }
	510	sub unk { $_[0]->err("unknown option `-$_[0]->{opt}'"); }
	511
be24e9af MW	512	###----- That's all, folks --------------------------------------------------
	513
	514	1;