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
 156 ###--------------------------------------------------------------------------
 157 ### Sequence numbers and tagging.
 158
 159 sub next_seq ($$) {
 160   my ($db, $table) = @_;
 161   my ($seq) = $db->selectrow_array("SELECT seq FROM $table");
 162   die "no sequence number in $table" unless defined $seq;
 163   $db->do("UPDATE $table SET seq = ?", undef, $seq + 1);
 164   return $seq;
 165 }
 166
 167 my $ALPHABET =
 168   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
 169 my $NALPHA = length $ALPHABET;
 170
 171 sub encode_tag ($) {
 172   my ($seq) = @_;
 173   my $tag = "";
 174   while ($seq) {
 175     $tag .= substr($ALPHABET, $seq % $NALPHA, 1);
 176     $seq = int $seq/$NALPHA;
 177   }
 178   return $tag;
 179 }
 180
 181 ###--------------------------------------------------------------------------
 182 ### HTTP utilities.
 183
 184 our %COOKIE;
 185 sub fetch_cookies ($) {
 186   my ($r) = @_;
 187
 188   %COOKIE = ();
 189   my $cookies = $r->header_in("Cookie");
 190   if (defined $cookies) {
 191     for my $kv (split /;/, $cookies) {
 192       my ($k, $v) = split /=/, $kv, 2;
 193       $k =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
 194       $v =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
 195       $v =~ s/\+/ /g;
 196       $v =~ s/\%([0-9a-f][0-9a-f])/chr hex $1/eg;
 197       $COOKIE{$k} = $v;
 198     }
 199   }
 200 }
 201
 202 sub bake_cookie ($$%) {
 203   my ($r, $cookie, %attr) = @_;
 204   merge_hash %attr, %COOKIE_DEFAULTS;
 205   my @attr = map {
 206     my $v = $attr{$_}; tr/_-/-/d;
 207     defined $v ? "$_=$v" : $_
 208   } keys %attr;
 209   $r->headers_out->add("Set-Cookie", join "; ", $cookie, @attr);
 210 }
 211
 212 sub path_info ($) {
 213   my ($r) = @_;
 214   return $ENV{PATH_INFO} // $r->path_info;
 215 }
 216
 217 ###--------------------------------------------------------------------------
 218 ### HTML utilities.
 219
 220 sub escapify ($$;$) {
 221   my ($m, $s, $mode) = @_;
 222   return $m->interp->apply_escapes($s, $mode // "h");
 223 }
 224
 225 ###--------------------------------------------------------------------------
 226 ### Access control.
 227
 228 our ($WHO, $WHOSURE);
 229 our ($WHOMATCH, $WHOCMP, $WHOPAT);
 230
 231 sub cgi_who ($) {
 232   my ($r) = @_;
 233   my $raddr = $ENV{REMOTE_ADDR} // $r->connection->remote_ip;
 234   $WHO = ":NET-$raddr"; $WHOSURE = 0;
 235   $WHOMATCH = "LIKE"; $WHOCMP = ":NET-\%"; $WHOPAT = qr/^:NET-/;
 236 }
 237
 238 sub cmdline_who () {
 239   $WHO = $ENV{USERV_USER}
 240     // ($< == $> && $ENV{USER})
 241     // @{[getpwuid $<]}[0]
 242     // die "nameless user";
 243   $WHOMATCH = "="; $WHOCMP = $WHO; $WHOPAT = qr/^\Q$WHO\E$/;
 244   $WHOSURE = 1;
 245 }
 246
 247 sub new_editkey () {
 248   open my $fh, "/dev/urandom" or die "open urandom: $!";
 249   sysread $fh, my $rand, 16;
 250   (my $edit = encode_base64 $rand) =~ tr:+/=\n:.-:d;
 251   return $edit, sha256_hex $edit;
 252 }
 253
 254 ###--------------------------------------------------------------------------
 255 ### URL shortening.
 256
 257 sub get_shorturl ($) {
 258   my ($tag) = @_;
 259
 260   my $db = open_db;
 261   my ($url) = $db->selectrow_array
 262     ("SELECT url FROM odin_shorturl WHERE tag = ?", undef, $tag);
 263   fail "tag `$tag' not found", ".notfound", tag => $tag unless defined $url;
 264   return $url;
 265 }
 266
 267 sub valid_url_p ($) {
 268   my ($url) = @_;
 269   return
 270     length $url < $URLMAXLEN &&
 271     scalar grep { $url =~ /$_/ } @URLPAT;
 272 }
 273
 274 sub new_shorturl ($) {
 275   my ($url) = @_;
 276
 277   valid_url_p $url or fail "invalid url", ".badurl", u => $url;
 278
 279   my $db = open_db;
 280   my $tag;
 281   xact {
 282     ($tag) = $db->selectrow_array
 283       ("SELECT tag FROM odin_shorturl WHERE owner $WHOMATCH ? AND url = ?",
 284        undef, $WHOCMP, $url);
 285     unless (defined $tag) {
 286       $tag = encode_tag(next_seq($db, "odin_shorturl_seq"));
 287       $db->do("INSERT INTO odin_shorturl (tag, stamp, owner, url)
 288                VALUES (?, ?, ?, ?)", undef,
 289               $tag, $NOW, $WHO, $url);
 290     }
 291   } $db;
 292   return $tag;
 293 }
 294
 295 sub check_shorturl_owner ($$) {
 296   my ($db, $tag) = @_;
 297
 298   my ($owner) = $db->selectrow_array
 299     ("SELECT owner FROM odin_shorturl WHERE tag = ?", undef, $tag);
 300   fail "tag `$tag' not found", ".notfound", tag => $tag
 301     unless defined $owner;
 302   fail "not owner of `$tag'", ".notowner", tag => $tag
 303     unless $owner =~ /$WHOPAT/;
 304 }
 305
 306 sub update_shorturl ($$) {
 307   my ($tag, $url) = @_;
 308
 309   my $db = open_db;
 310   xact {
 311     check_shorturl_owner $db, $tag;
 312     $db->do("UPDATE odin_shorturl SET url = ? WHERE tag = ?",
 313             undef, $url, $tag);
 314   } $db;
 315 }
 316
 317 sub delete_shorturl (@) {
 318   my (@tags) = @_;
 319
 320   my $db = open_db;
 321   xact {
 322     for my $tag (@tags) {
 323       check_shorturl_owner $db, $tag;
 324       $db->do("DELETE FROM odin_shorturl WHERE tag = ?", undef, $tag);
 325     }
 326   } $db;
 327 }
 328
 329 ###--------------------------------------------------------------------------
 330 ### Paste bin.
 331
 332 our %PASTEBIN_DEFAULTS = (
 333   title => "(untitled)",
 334   lang => "txt",
 335   content => ""
 336 );
 337 our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
 338 our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
 339 our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;
 340
 341 sub new_pastebin (\%) {
 342   my ($new) = @_;
 343
 344   my $db = open_db;
 345   my ($editkey, $hash) = new_editkey;
 346   my $tag;
 347
 348   merge_hash %$new, %PASTEBIN_DEFAULTS;
 349   xact {
 350     $tag = encode_tag next_seq $db, "odin_pastebin_seq";
 351     $db->do("INSERT INTO odin_pastebin
 352                (tag, stamp, edithash, owner, $PASTEBIN_PROPCOLS)
 353              VALUES (?, ?, ?, ?, $PASTEBIN_PROPPLACES)", undef,
 354             $tag, $NOW, $hash, $WHO, @{$new}{@PASTEBIN_PROPS});
 355   } $db;
 356   return $tag, $editkey;
 357 }
 358
 359 sub get_pastebin ($$\%) {
 360   my ($db, $tag, $props) = @_;
 361
 362   (my $owner, my $hash, @{$props}{@PASTEBIN_PROPS}) =
 363     $db->selectrow_array("SELECT owner, edithash, $PASTEBIN_PROPCOLS
 364                           FROM odin_pastebin WHERE tag = ?",
 365                          undef, $tag);
 366   fail "tag `$tag' not found", ".notfound", tag => $tag
 367     unless defined $owner;
 368   return $owner, $hash;
 369 }
 370
 371 sub get_pastebin_check_owner ($$\%) {
 372   my ($db, $tag, $props) = @_;
 373
 374   my ($owner, $hash) = get_pastebin $db, $tag, %$props;
 375   fail "not owner of `$tag'", ".notowner", tag => $tag
 376     unless $WHOSURE && $WHO eq $owner;
 377 }
 378
 379 sub get_pastebin_check_editkey_or_owner ($$$\%) {
 380   my ($db, $tag, $editkey, $props) = @_;
 381
 382   if (!defined $editkey) { get_pastebin_check_owner $db, $tag, %$props; }
 383   else {
 384     my ($owner, $hash) = get_pastebin $db, $tag, %$props;
 385     fail "incorrect edit key for `$tag'", ".badhash", tag => $tag
 386       unless $hash eq sha256_hex $editkey;
 387   }
 388 }
 389
 390 sub rekey_pastebin ($) {
 391   my ($tag) = @_;
 392
 393   my $db = open_db;
 394   my $editkey;
 395   xact {
 396     get_pastebin_check_owner $db, $tag, my %hunoz;
 397     ($editkey, my $hash) = new_editkey;
 398     $db->do("UPDATE odin_pastebin SET edithash = ? WHERE tag = ?",
 399             undef, $hash, $tag);
 400   } $db;
 401   return $editkey;
 402 }
 403
 404 sub claim_pastebin ($$) {
 405   my ($tag, $editkey) = @_;
 406
 407   my $db = open_db;
 408   $WHOSURE or fail "you can't claim pastes", ".notsure";
 409   xact {
 410     get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
 411     $db->do("UPDATE odin_pastebin SET owner = ? WHERE tag = ?",
 412             undef, $WHO, $tag);
 413   } $db;
 414 }
 415
 416 sub update_pastebin ($$\%) {
 417   my ($tag, $editkey, $new) = @_;
 418
 419   my $db = open_db;
 420   my $editp = 0;
 421   xact {
 422     get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %old;
 423     for my $p (@PASTEBIN_PROPS) {
 424       if (!defined $new->{$p}) { $new->{$p} = $old{$p}; }
 425       else {
 426         $db->do("UPDATE odin_pastebin SET $p = ? WHERE tag = ?",
 427                 undef, $new->{$p}, $tag)
 428           unless $new->{$p} eq $old{$p};
 429         $editp = 1;
 430       }
 431     }
 432   } $db;
 433   return $editp;
 434 }
 435
 436 sub delete_pastebin (@) {
 437   my @a = @_;
 438   my $db = open_db;
 439   xact {
 440     while (@a) {
 441       (my $tag, my $editkey, @a) = @a;
 442       get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
 443       $db->do("DELETE FROM odin_pastebin WHERE tag = ?", undef, $tag);
 444     }
 445   } $db;
 446 }
 447
 448 sub tidy_pastebin_content ($) {
 449   my ($content) = @_;
 450   return undef unless defined $content;
 451   $content =~ tr/\r//d;
 452   $content =~ s/([^\n])\z/$1\n/;
 453   length $content <= $PASTEMAXLEN or
 454     fail "invalid paste content", ".badpaste";
 455   return $content;
 456 }
 457
 458 ###--------------------------------------------------------------------------
 459 ### Simple option parser.
 460
 461 package Odin::OptParse;
 462
 463 sub new {
 464   my ($cls, @args) = @_;
 465   return bless {
 466     cur => "",
 467     args => \@args,
 468     opt => undef,
 469     ok => 1
 470   }, $cls;
 471 }
 472
 473 sub get {
 474   my ($me) = @_;
 475   if (!length $me->{cur}) {
 476     my $args = $me->{args};
 477     if (!@$args) { return undef; }
 478     elsif ($args->[0] =~ /^[^-]|^-$/) { return undef; }
 479     elsif ($args->[0] eq "--") { shift @$args; return undef; }
 480     $me->{cur} = substr shift @$args, 1;
 481   }
 482   my $o = $me->{opt} = substr $me->{cur}, 0, 1;
 483   $me->{cur} = substr $me->{cur}, 1;
 484   return $o;
 485 }
 486
 487 sub arg {
 488   my ($me) = @_;
 489   my $a;
 490   if (length $me->{cur}) { $a = $me->{cur}; $me->{cur} = ""; }
 491   elsif (@{$me->{args}}) { $a = shift @{$me->{args}}; }
 492   else { $a = undef; $me->err("option `-$me->{opt}' requires an argument"); }
 493   return $a;
 494 }
 495
 496 sub rest { return @{$_[0]->{args}}; }
 497 sub ok { return $_[0]->{ok}; }
 498 sub bad { $_[0]->{ok} = 0; }
 499 sub err { $_[0]->bad; print STDERR "$PROG: $_[1]\n"; }
 500 sub unk { $_[0]->err("unknown option `-$_[0]->{opt}'"); }
 501
 502 ###----- That's all, folks --------------------------------------------------
 503
 504 1;