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


our ($SCHEME, $DOMAIN, $BASEPATH);
our ($SHORTURL, $PASTEBIN);

###--------------------------------------------------------------------------
### 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}'"); }

###--------------------------------------------------------------------------
### Final configuration.

package Odin;

require "config.pl";

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

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

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