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.
54 sub update_now
() { $NOW = time; }
57 (our $PROG = $0) =~ s
:^.*/::;
59 sub fail_cmdline
($$%) {
60 my ($msg, $label, %args) = @_;
61 print STDERR
"$PROG: $msg\n";
65 our $FAILPROC = \
&fail_cmdline
;
68 my ($msg, $label, %args) = @_;
69 $FAILPROC->($msg, $label, %args);
72 sub set_mason_failproc
($) {
75 my ($msg, $label, %args) = @_;
77 $m->comp($label, %args);
88 ###--------------------------------------------------------------------------
89 ### Database utilities.
93 my $db = DBI
->connect_cached($DSN, undef, undef, {
99 my $drv = $db->{Driver
}{Name
};
101 $db->{private_odin_retry_p
} = sub { $db->state =~ /^40[0P]01$/ };
102 } elsif ($drv eq "SQLite") {
103 $db->{private_odin_retry_p
} = sub { $db->err == 5 };
105 $db->{private_odin_retry_p
} = sub { 0 };
112 my ($body, $db) = @_;
116 my ($sleep, $maxsleep, $mult, $minvar, $maxvar) = @BACKOFF;
117 for (my $i = 0; $i < $RETRY; $i++) {
119 eval { @rv = $body->(); $db->commit; };
121 return @rv unless $exc;
122 my $retryp = $db->{private_odin_retry_p
}();
123 eval { $db->rollback; };
124 die $exc unless $retryp;
125 my $t = $sleep * ($minvar + rand($maxvar - $minvar));
126 $sleep *= $mult; $sleep = $max if $sleep > $max;
127 select undef, undef, undef, $t;
133 ###--------------------------------------------------------------------------
134 ### Sequence numbers and tagging.
137 my ($db, $table) = @_;
138 my ($seq) = $db->selectrow_array("SELECT seq FROM $table");
139 die "no sequence number in $table" unless defined $seq;
140 $db->do("UPDATE $table SET seq = ?", undef, $seq + 1);
145 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
146 my $NALPHA = length $ALPHABET;
152 $tag .= substr($ALPHABET, $seq % $NALPHA, 1);
153 $seq = int $seq/$NALPHA;
158 ###--------------------------------------------------------------------------
162 sub fetch_cookies
($) {
166 my $cookies = $r->header_in("Cookie");
167 if (defined $cookies) {
168 for my $kv (split /;/, $cookies) {
169 my ($k, $v) = split /=/, $kv, 2;
170 $k =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
171 $v =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
173 $v =~ s/\%([0-9a-f][0-9a-f])/chr hex $1/eg;
179 sub bake_cookie
($$%) {
180 my ($r, $cookie, %attr) = @_;
181 merge_hash
%attr, %COOKIE_DEFAULTS;
183 my $v = $attr{$_}; tr/_-/-/d;
184 defined $v ?
"$_=$v" : $_
186 $r->headers_out->add("Set-Cookie", join "; ", $cookie, @attr);
191 return $ENV{PATH_INFO
} // $r->path_info;
194 ###--------------------------------------------------------------------------
197 sub escapify
($$;$) {
198 my ($m, $s, $mode) = @_;
199 return $m->interp->apply_escapes($s, $mode // "h");
202 ###--------------------------------------------------------------------------
205 our ($WHO, $WHOSURE);
206 our ($WHOMATCH, $WHOCMP, $WHOPAT);
210 my $raddr = $ENV{REMOTE_ADDR
} // $r->connection->remote_ip;
211 $WHO = ":NET-$raddr"; $WHOSURE = 0;
212 $WHOMATCH = "LIKE"; $WHOCMP = ":NET-\%"; $WHOPAT = qr/^:NET-/;
216 $WHO = $ENV{USERV_USER
}
217 // ($< == $> && $ENV{USER
})
218 // @
{[getpwuid $<]}[0]
219 // die "nameless user";
220 $WHOMATCH = "="; $WHOCMP = $WHO; $WHOPAT = qr/^\Q$WHO\E$/;
225 open my $fh, "/dev/urandom" or die "open urandom: $!";
226 sysread $fh, my $rand, 16;
227 (my $edit = encode_base64
$rand) =~ tr
:+/=\n:.-:d
;
228 return $edit, sha256_hex
$edit;
231 ###--------------------------------------------------------------------------
234 sub get_shorturl
($) {
238 my ($url) = $db->selectrow_array
239 ("SELECT url FROM odin_shorturl WHERE tag = ?", undef, $tag);
240 fail
"tag `$tag' not found", ".notfound", tag
=> $tag unless defined $url;
244 sub valid_url_p
($) {
247 length $url < $URLMAXLEN &&
248 scalar grep { $url =~ /$_/ } @URLPAT;
251 sub new_shorturl
($) {
254 valid_url_p
$url or fail
"invalid url", ".badurl", u
=> $url;
259 ($tag) = $db->selectrow_array
260 ("SELECT tag FROM odin_shorturl WHERE owner $WHOMATCH ? AND url = ?",
261 undef, $WHOCMP, $url);
262 unless (defined $tag) {
263 $tag = encode_tag
(next_seq
($db, "odin_shorturl_seq"));
264 $db->do("INSERT INTO odin_shorturl (tag, stamp, owner, url)
265 VALUES (?, ?, ?, ?)", undef,
266 $tag, $NOW, $WHO, $url);
272 sub check_shorturl_owner
($$) {
275 my ($owner) = $db->selectrow_array
276 ("SELECT owner FROM odin_shorturl WHERE tag = ?", undef, $tag);
277 fail
"tag `$tag' not found", ".notfound", tag
=> $tag
278 unless defined $owner;
279 fail
"not owner of `$tag'", ".notowner", tag
=> $tag
280 unless $owner =~ /$WHOPAT/;
283 sub update_shorturl
($$) {
284 my ($tag, $url) = @_;
288 check_shorturl_owner
$db, $tag;
289 $db->do("UPDATE odin_shorturl SET url = ? WHERE tag = ?",
294 sub delete_shorturl
(@
) {
299 for my $tag (@tags) {
300 check_shorturl_owner
$db, $tag;
301 $db->do("DELETE FROM odin_shorturl WHERE tag = ?", undef, $tag);
306 ###--------------------------------------------------------------------------
309 our %PASTEBIN_DEFAULTS = (
310 title
=> "(untitled)",
314 our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
315 our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
316 our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;
318 sub new_pastebin
(\
%) {
322 my ($editkey, $hash) = new_editkey
;
325 merge_hash
%$new, %PASTEBIN_DEFAULTS;
327 $tag = encode_tag next_seq
$db, "odin_pastebin_seq";
328 $db->do("INSERT INTO odin_pastebin
329 (tag, stamp, edithash, owner, $PASTEBIN_PROPCOLS)
330 VALUES (?, ?, ?, ?, $PASTEBIN_PROPPLACES)", undef,
331 $tag, $NOW, $hash, $WHO, @
{$new}{@PASTEBIN_PROPS});
333 return $tag, $editkey;
336 sub get_pastebin
($$\
%) {
337 my ($db, $tag, $props) = @_;
339 (my $owner, my $hash, @
{$props}{@PASTEBIN_PROPS}) =
340 $db->selectrow_array("SELECT owner, edithash, $PASTEBIN_PROPCOLS
341 FROM odin_pastebin WHERE tag = ?",
343 fail
"tag `$tag' not found", ".notfound", tag
=> $tag
344 unless defined $owner;
345 return $owner, $hash;
348 sub get_pastebin_check_owner
($$\
%) {
349 my ($db, $tag, $props) = @_;
351 my ($owner, $hash) = get_pastebin
$db, $tag, %$props;
352 fail
"not owner of `$tag'", ".notowner", tag
=> $tag
353 unless $WHOSURE && $WHO eq $owner;
356 sub get_pastebin_check_editkey_or_owner
($$$\
%) {
357 my ($db, $tag, $editkey, $props) = @_;
359 if (!defined $editkey) { get_pastebin_check_owner
$db, $tag, %$props; }
361 my ($owner, $hash) = get_pastebin
$db, $tag, %$props;
362 fail
"incorrect edit key for `$tag'", ".badhash", tag
=> $tag
363 unless $hash eq sha256_hex
$editkey;
367 sub rekey_pastebin
($) {
373 get_pastebin_check_owner
$db, $tag, my %hunoz;
374 ($editkey, my $hash) = new_editkey
;
375 $db->do("UPDATE odin_pastebin SET edithash = ? WHERE tag = ?",
381 sub claim_pastebin
($$) {
382 my ($tag, $editkey) = @_;
385 $WHOSURE or fail
"you can't claim pastes", ".notsure";
387 get_pastebin_check_editkey_or_owner
$db, $tag, $editkey, my %hunoz;
388 $db->do("UPDATE odin_pastebin SET owner = ? WHERE tag = ?",
393 sub update_pastebin
($$\
%) {
394 my ($tag, $editkey, $new) = @_;
399 get_pastebin_check_editkey_or_owner
$db, $tag, $editkey, my %old;
400 for my $p (@PASTEBIN_PROPS) {
401 if (!defined $new->{$p}) { $new->{$p} = $old{$p}; }
403 $db->do("UPDATE odin_pastebin SET $p = ? WHERE tag = ?",
404 undef, $new->{$p}, $tag)
405 unless $new->{$p} eq $old{$p};
413 sub delete_pastebin
(@
) {
418 (my $tag, my $editkey, @a) = @a;
419 get_pastebin_check_editkey_or_owner
$db, $tag, $editkey, my %hunoz;
420 $db->do("DELETE FROM odin_pastebin WHERE tag = ?", undef, $tag);
425 sub tidy_pastebin_content
($) {
427 return undef unless defined $content;
428 $content =~ tr/\r//d;
429 $content =~ s/([^\n])\z/$1\n/;
433 ###--------------------------------------------------------------------------
434 ### Simple option parser.
436 package Odin
::OptParse
;
439 my ($cls, @args) = @_;
450 if (!length $me->{cur
}) {
451 my $args = $me->{args
};
452 if (!@
$args) { return undef; }
453 elsif ($args->[0] =~ /^[^-]|^-$/) { return undef; }
454 elsif ($args->[0] eq "--") { shift @
$args; return undef; }
455 $me->{cur
} = substr shift @
$args, 1;
457 my $o = $me->{opt
} = substr $me->{cur
}, 0, 1;
458 $me->{cur
} = substr $me->{cur
}, 1;
465 if (length $me->{cur
}) { $a = $me->{cur
}; $me->{cur
} = ""; }
466 elsif (@
{$me->{args
}}) { $a = shift @
{$me->{args
}}; }
467 else { $a = undef; $me->err("option `-$me->{opt}' requires an argument"); }
471 sub rest
{ return @
{$_[0]->{args
}}; }
472 sub ok
{ return $_[0]->{ok
}; }
473 sub bad
{ $_[0]->{ok
} = 0; }
474 sub err
{ $_[0]->bad; print STDERR
"$PROG: $_[1]\n"; }
475 sub unk
{ $_[0]->err("unknown option `-$_[0]->{opt}'"); }
477 ###----- That's all, folks --------------------------------------------------