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
  45
  46 our ($SCHEME, $DOMAIN, $BASEPATH);
  47 our ($SHORTURL, $PASTEBIN);
  48
  49 ###--------------------------------------------------------------------------
  50 ### Miscellaneous utilities.
  51
  52 our $NOW;
  53 sub update_now () { $NOW = time; }
  54 update_now;
  55
  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
  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
 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$/ };
 121   } elsif ($drv eq "SQLite") {
 122     $db->{private_odin_retry_p} = sub { $db->err == 5 };
 123   } else {
 124     $db->{private_odin_retry_p} = sub { 0 };
 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
 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 }
 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"));
 295       insert_record $db, "odin_shorturl",
 296         tag => $tag, stamp => $NOW, owner => $WHO, url => $url;
 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)",
 341   lang => "txt",
 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";
 358     insert_record $db, "odin_pastebin",
 359       tag => $tag, stamp => $NOW, edithash => $hash, owner => $WHO,
 360       %$new;
 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/;
 459   length $content <= $PASTEMAXLEN or
 460     fail "invalid paste content", ".badpaste";
 461   return $content;
 462 }
 463
 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
 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
 522 ###----- That's all, folks --------------------------------------------------
 523
 524 1;