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