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