[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 %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$/ };
    $db->{private_odin_unixstamp} = sub { "extract(epoch from $_[0])" };
  } elsif ($drv eq "SQLite") {
    $db->{private_odin_retry_p} = sub { $db->err == 5 };
    $db->{private_odin_unixstamp} = sub { "strftime('%s', $_[0])" };
  } else {
    fail "unsupported database driver `$drv' (patches welcome)", undef;
  }

  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 sql_timestamp ($$) {
  my ($db, $col) = @_;
  return $db->{private_odin_unixstamp}->($col);
}

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