+### -*-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 $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 => "plain-text",
+ 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;
+}
+
+###----- That's all, folks --------------------------------------------------
+
+1;
~mdw / odin-cgi / commitdiff