chiark - git - mdw - odin-cgi/blob - lib/Odin.pm

   1 ### -*-perl-*-
   2
   3 package Odin;
   4
   5 use DBI;
   6 use Digest::SHA qw(sha256_hex);
   7 use MIME::Base64;
   8 use POSIX;
   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
  37 our $PASTEMAXLEN = 1024*1024;
  38
  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
  56 our $NOW;
  57 sub update_now () { $NOW = time; }
  58 update_now;
  59
  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
  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
 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$/ };
 125   } elsif ($drv eq "SQLite") {
 126     $db->{private_odin_retry_p} = sub { $db->err == 5 };
 127   } else {
 128     $db->{private_odin_retry_p} = sub { 0 };
 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
 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 }
 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"));
 299       insert_record $db, "odin_shorturl",
 300         tag => $tag, stamp => $NOW, owner => $WHO, url => $url;
 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)",
 345   lang => "txt",
 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";
 362     insert_record $db, "odin_pastebin",
 363       tag => $tag, stamp => $NOW, edithash => $hash, owner => $WHO,
 364       %$new;
 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/;
 463   length $content <= $PASTEMAXLEN or
 464     fail "invalid paste content", ".badpaste";
 465   return $content;
 466 }
 467
 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
 512 ###----- That's all, folks --------------------------------------------------
 513
 514 1;