6 use Digest::SHA qw(sha256_hex);
9 ###--------------------------------------------------------------------------
12 sub merge_hash (\%%) {
13 my ($hashref, %defaults) = @_;
14 for my $k (keys %defaults)
15 { $hashref->{$k} = $defaults{$k} unless exists $hashref->{$k}; }
18 ###--------------------------------------------------------------------------
21 our $DSN = "dbi:Pg(pg_enable_utf8=>1):host=db";
23 our @BACKOFF = (0.1, 10, 1.5, 0.5, 2.0);
25 our $BASEURL = "http://odin.gg/";
26 our $STATIC = "http://odin.gg/";
28 our $SHORTURL_PATH = "u";
29 our $PASTEBIN_PATH = "p";
31 our $URLMAXLEN = 1024;
36 our %COOKIE_DEFAULTS = (
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";
47 our $SHORTURL = "$BASEURL$SHORTURL_PATH";
48 our $PASTEBIN = "$BASEURL$PASTEBIN_PATH";
50 ###--------------------------------------------------------------------------
51 ### Miscellaneous utilities.
53 (our $PROG = $0) =~ s:^.*/::;
55 sub fail_cmdline ($$%) {
56 my ($msg, $label, %args) = @_;
57 print STDERR "$PROG: $msg\n";
61 our $FAILPROC = \&fail_cmdline;
64 my ($msg, $label, %args) = @_;
65 $FAILPROC->($msg, $label, %args);
68 sub set_mason_failproc ($) {
71 my ($msg, $label, %args) = @_;
73 $m->comp($label, %args);
84 ###--------------------------------------------------------------------------
85 ### Database utilities.
89 my $db = DBI->connect_cached($DSN, undef, undef, {
95 my $drv = $db->{Driver}{Name};
97 $db->{private_odin_retry_p} = sub { $db->state =~ /^40[0P]01$/ };
98 $db->{private_odin_unixstamp} = sub { "extract(epoch from $_[0])" };
99 } elsif ($drv eq "SQLite") {
100 $db->{private_odin_retry_p} = sub { $db->err == 5 };
101 $db->{private_odin_unixstamp} = sub { "strftime('%s', $_[0])" };
103 fail "unsupported database driver `$drv' (patches welcome)", undef;
110 my ($body, $db) = @_;
114 my ($sleep, $maxsleep, $mult, $minvar, $maxvar) = @BACKOFF;
115 for (my $i = 0; $i < $RETRY; $i++) {
117 eval { @rv = $body->(); $db->commit; };
119 return @rv unless $exc;
120 my $retryp = $db->{private_odin_retry_p}();
121 eval { $db->rollback; };
122 die $exc unless $retryp;
123 my $t = $sleep * ($minvar + rand($maxvar - $minvar));
124 $sleep *= $mult; $sleep = $max if $sleep > $max;
125 select undef, undef, undef, $t;
130 sub sql_timestamp ($$) {
132 return $db->{private_odin_unixstamp}->($col);
135 ###--------------------------------------------------------------------------
136 ### Sequence numbers and tagging.
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);
147 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
148 my $NALPHA = length $ALPHABET;
154 $tag .= substr($ALPHABET, $seq % $NALPHA, 1);
155 $seq = int $seq/$NALPHA;
160 ###--------------------------------------------------------------------------
164 sub fetch_cookies ($) {
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/;
175 $v =~ s/\%([0-9a-f][0-9a-f])/chr hex $1/eg;
181 sub bake_cookie ($$%) {
182 my ($r, $cookie, %attr) = @_;
183 merge_hash %attr, %COOKIE_DEFAULTS;
185 my $v = $attr{$_}; tr/_-/-/d;
186 defined $v ? "$_=$v" : $_
188 $r->headers_out->add("Set-Cookie", join "; ", $cookie, @attr);
193 return $ENV{PATH_INFO} // $r->path_info;
196 ###--------------------------------------------------------------------------
199 sub escapify ($$;$) {
200 my ($m, $s, $mode) = @_;
201 return $m->interp->apply_escapes($s, $mode // "h");
204 ###--------------------------------------------------------------------------
207 our ($WHO, $WHOSURE);
208 our ($WHOMATCH, $WHOCMP, $WHOPAT);
212 my $raddr = $ENV{REMOTE_ADDR} // $r->connection->remote_ip;
213 $WHO = ":NET-$raddr"; $WHOSURE = 0;
214 $WHOMATCH = "LIKE"; $WHOCMP = ":NET-\%"; $WHOPAT = qr/^:NET-/;
218 $WHO = $ENV{USERV_USER}
219 // ($< == $> && $ENV{USER})
220 // @{[getpwuid $<]}[0]
221 // die "nameless user";
222 $WHOMATCH = "="; $WHOCMP = $WHO; $WHOPAT = qr/^\Q$WHO\E$/;
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;
233 ###--------------------------------------------------------------------------
236 sub get_shorturl ($) {
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;
246 sub valid_url_p ($) {
249 length $url < $URLMAXLEN &&
250 scalar grep { $url =~ /$_/ } @URLPAT;
253 sub new_shorturl ($) {
256 valid_url_p $url or fail "invalid url", ".badurl", u => $url;
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, owner, url) VALUES (?, ?, ?)",
267 undef, $tag, $WHO, $url);
273 sub check_shorturl_owner ($$) {
276 my ($owner) = $db->selectrow_array
277 ("SELECT owner FROM odin_shorturl WHERE tag = ?", undef, $tag);
278 fail "tag `$tag' not found", ".notfound", tag => $tag
279 unless defined $owner;
280 fail "not owner of `$tag'", ".notowner", tag => $tag
281 unless $owner =~ /$WHOPAT/;
284 sub update_shorturl ($$) {
285 my ($tag, $url) = @_;
289 check_shorturl_owner $db, $tag;
290 $db->do("UPDATE odin_shorturl SET url = ? WHERE tag = ?",
295 sub delete_shorturl (@) {
300 for my $tag (@tags) {
301 check_shorturl_owner $db, $tag;
302 $db->do("DELETE FROM odin_shorturl WHERE tag = ?", undef, $tag);
307 ###--------------------------------------------------------------------------
310 our %PASTEBIN_DEFAULTS = (
311 title => "(untitled)",
315 our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
316 our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
317 our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;
319 sub new_pastebin (\%) {
323 my ($editkey, $hash) = new_editkey;
326 merge_hash %$new, %PASTEBIN_DEFAULTS;
328 $tag = encode_tag next_seq $db, "odin_pastebin_seq";
329 $db->do("INSERT INTO odin_pastebin
330 (tag, edithash, owner, $PASTEBIN_PROPCOLS)
331 VALUES (?, ?, ?, $PASTEBIN_PROPPLACES)", undef,
332 $tag, $hash, $WHO, @{$new}{@PASTEBIN_PROPS});
334 return $tag, $editkey;
337 sub get_pastebin ($$\%) {
338 my ($db, $tag, $props) = @_;
340 (my $owner, my $hash, @{$props}{@PASTEBIN_PROPS}) =
341 $db->selectrow_array("SELECT owner, edithash, $PASTEBIN_PROPCOLS
342 FROM odin_pastebin WHERE tag = ?",
344 fail "tag `$tag' not found", ".notfound", tag => $tag
345 unless defined $owner;
346 return $owner, $hash;
349 sub get_pastebin_check_owner ($$\%) {
350 my ($db, $tag, $props) = @_;
352 my ($owner, $hash) = get_pastebin $db, $tag, %$props;
353 fail "not owner of `$tag'", ".notowner", tag => $tag
354 unless $WHOSURE && $WHO eq $owner;
357 sub get_pastebin_check_editkey_or_owner ($$$\%) {
358 my ($db, $tag, $editkey, $props) = @_;
360 if (!defined $editkey) { get_pastebin_check_owner $db, $tag, %$props; }
362 my ($owner, $hash) = get_pastebin $db, $tag, %$props;
363 fail "incorrect edit key for `$tag'", ".badhash", tag => $tag
364 unless $hash eq sha256_hex $editkey;
368 sub rekey_pastebin ($) {
374 get_pastebin_check_owner $db, $tag, my %hunoz;
375 ($editkey, my $hash) = new_editkey;
376 $db->do("UPDATE odin_pastebin SET edithash = ? WHERE tag = ?",
382 sub claim_pastebin ($$) {
383 my ($tag, $editkey) = @_;
386 $WHOSURE or fail "you can't claim pastes", ".notsure";
388 get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
389 $db->do("UPDATE odin_pastebin SET owner = ? WHERE tag = ?",
394 sub update_pastebin ($$\%) {
395 my ($tag, $editkey, $new) = @_;
400 get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %old;
401 for my $p (@PASTEBIN_PROPS) {
402 if (!defined $new->{$p}) { $new->{$p} = $old{$p}; }
404 $db->do("UPDATE odin_pastebin SET $p = ? WHERE tag = ?",
405 undef, $new->{$p}, $tag)
406 unless $new->{$p} eq $old{$p};
414 sub delete_pastebin (@) {
419 (my $tag, my $editkey, @a) = @a;
420 get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
421 $db->do("DELETE FROM odin_pastebin WHERE tag = ?", undef, $tag);
426 sub tidy_pastebin_content ($) {
428 return undef unless defined $content;
429 $content =~ tr/\r//d;
430 $content =~ s/([^\n])\z/$1\n/;
434 ###----- That's all, folks --------------------------------------------------