Seems to work. Mostly.
--- /dev/null
+#! /usr/bin/perl
+
+use lib "lib";
+
+use Odin;
+use DBI;
+use Encode;
+use Encode::Locale;
+use Getopt::Std;
+use POSIX;
+
+my $BAD = 0;
+
+sub bad ($) {
+ my ($m) = @_;
+ $BAD = 1;
+ print STDERR "$Odin::PROG: $m\n";
+}
+
+Odin::cmdline_who;
+
+sub read_content () {
+ my $c = "";
+ while (read STDIN, my $buf, 8192) { $c .= $buf; }
+ return Odin::tidy_pastebin_content decode locale => $c;
+}
+
+my $op = shift(@ARGV) // "help";
+if ($op eq "help") {
+ print <<EOF;
+Commands available:
+
+ claim TAG EDITKEY
+ del TAG ...
+ get TAG
+ help
+ list
+ new [-l LANG] [-t TITLE]
+ rekey TAG
+ update [-c] [-l LANG] [-t TITLE] TAG
+EOF
+} elsif ($op eq "list") {
+ @ARGV == 0 or Odin::fail "usage: list";
+ my $db = Odin::open_db;
+ for my $r (@{$db->selectall_arrayref
+ ("SELECT " . Odin::sql_timestamp($db, "stamp") .
+ ", tag, lang, title
+ FROM odin_pastebin WHERE owner = ?
+ ORDER BY stamp", undef, $Odin::WHO)}) {
+ my ($stamp, $tag, $lang, $title) = @$r;
+ my $t = strftime "%Y-%m-%d %H:%M:%S %z", localtime $stamp;
+ printf "%-25s %-12s %-16s %s\n",
+ $t, $tag, $lang, encode locale => $title;
+ }
+} elsif ($op eq "new") {
+ my %o;
+ getopts "l:t:", \%o and @ARGV == 0
+ or Odin::fail "usage: new [-l LANG] [-t TITLE]";
+ my %p = (title => decode(locale => $o{t}), lang => $o{l} // "plain-text",
+ content => read_content);
+ my $db = Odin::open_db;
+ my $c = "";
+ while (read STDIN, my $buf, 8192) { $c .= $buf; }
+ $p{content} = read_content;
+ @{$db->selectall_arrayref
+ ("SELECT lang FROM odin_pastebin_lang WHERE lang = ?", undef, $p{lang})}
+ or Odin::fail "unknown language `$p{lang}'";
+ my ($tag, $edit) = Odin::new_pastebin %p;
+ print "$Odin::PASTEBIN/$url $edit\n";
+} elsif ($op eq "get") {
+ @ARGV == 1 or Odin::fail "usage: get TAG";
+ my ($tag) = @ARGV;
+ Odin::get_pastebin Odin::open_db, $tag, my %p;
+ print encode locale => $p{content};
+} elsif ($op eq "claim") {
+ @ARGV == 2 or Odin::fail "usage: claim TAG EDITKEY";
+ my ($tag, $key) = @ARGV;
+ Odin::claim_pastebin $tag, $key;
+} elsif ($op eq "rekey") {
+ @ARGV == 1 or Odin::fail "usage: rekey TAG";
+ my ($tag) = @ARGV;
+ my $key = Odin::rekey_pastebin $tag;
+ print $key, "\n";
+} elsif ($op eq "del") {
+ @ARGV or Odin::fail "usage: del TAG ...";
+ Odin::delete_pastebin map { $_, undef } @ARGV;
+} elsif ($op eq "update") {
+ my %o;
+ getopts "cl:t:", \%o and @ARGV == 1
+ or Odin::fail "usage: update [-c] [-l LANG] [-t TITLE] TAG";
+ my ($tag) = @ARGV;
+ my %p = (title => decode(locale => $o{t}), lang => $o{l});
+ if ($o{c}) { $p{content} = read_content; }
+ Odin::update_pastebin $tag, undef, %p or Odin::fail "nothing changed";
+} else {
+ Odin::fail "unknown operation `$op'";
+}
--- /dev/null
+#! /usr/bin/perl
+
+use lib "lib";
+use Odin;
+
+my $db = Odin::open_db;
+my %newlang, %oldlang;
+
+open my $fh, "-|", "highlight", "-p" or die "highlight: $!";
+while (<$fh>) {
+ my ($descr, $lang) = /^(.*\S)\s*:\s*(\S+)(?:\s.*|)$/;
+ next unless defined $lang;
+ $newlang{$lang} = $descr;
+}
+close $fh or die "close highlight: $! $?";
+$newlang{"txt"} //= "Plain text";
+
+Odin::xact {
+ my $h = $db->selectall_hashref
+ ("SELECT lang, descr FROM odin_pastebin_lang", "lang");
+ for my $k (keys %$h) { $oldlang{$k} = $h->{$k}{descr}; }
+ for my $lang (keys %oldlang) {
+ if (!exists $newlang{$lang}) {
+ print ";; delete stale language `$lang' (`$oldlang{$lang}')\n";
+ $db->do("DELETE FROM odin_pastebin_lang WHERE lang = ?", undef, $lang);
+ }
+ }
+ for my $lang (keys %newlang) {
+ if (!exists $oldlang{$lang}) {
+ print ";; insert new language `$lang' (`$newlang{$lang}')\n";
+ $db->do("INSERT INTO odin_pastebin_lang (lang) VALUES (?)",
+ undef, $lang);
+ } elsif ($oldlang{$lang} ne $newlang{$lang}) {
+ print ";; change description for `$lang' ",
+ "(`$oldlang{$lang}' -> `$newlang{$lang}')\n";
+ $db->do("UPDATE odin_pastebin_lang SET descr = ? WHERE lang = ?",
+ undef, $newlang{$lang}, $lang);
+ }
+ }
+} $db;
--- /dev/null
+#! /usr/bin/perl
+
+use lib "lib";
+
+use Odin;
+use DBI;
+use POSIX;
+
+Odin::cmdline_who;
+
+my $op = shift(@ARGV) // "help";
+if ($op eq "help") {
+ print <<EOF;
+Commands available:
+
+ del TAG ...
+ get TAG ...
+ help
+ list
+ new URL
+EOF
+} elsif ($op eq "list") {
+ @ARGV == 0 or Odin::fail "usage: list";
+ my $db = Odin::open_db;
+ for my $r (@{$db->selectall_arrayref
+ ("SELECT " . Odin::sql_timestamp($db, "stamp") . ", tag, url
+ FROM odin_shorturl WHERE owner = ?
+ ORDER BY stamp", undef, $Odin::WHO)}) {
+ my ($stamp, $tag, $url) = @$r;
+ my $t = strftime "%Y-%m-%d %H:%M:%S %z", localtime $stamp;
+ printf "%-25s %-12s %s\n", $t, $tag, $url;
+ }
+} elsif ($op eq "new") {
+ @ARGV == 1 or Odin::fail "usage: new URL";
+ my ($url) = @ARGV;
+ my $tag = Odin::new_shorturl $url;
+ print "$Odin::SHORTURL/$tag\n";
+} elsif ($op eq "get") {
+ @ARGV >= 0 or Odin::fail "usage: get TAG ...";
+ if (@ARGV == 1) { print Odin::get_shorturl $ARGV[0], "\n"; }
+ else {
+ for my $tag (@ARGV)
+ { printf "%-12s %s\n", $tag, Odin::get_shorturl $tag; }
+ }
+} elsif ($op eq "del") {
+ @ARGV >= 0 or Odin::fail "usage: del TAG ...";
+ Odin::delete_shorturl @ARGV;
+} else {
+ Odin::fail "unknown operation `$op'";
+}
--- /dev/null
+### -*-perl-*-
+
+package Odin;
+
+use DBI;
+use Digest::SHA qw(sha256_hex);
+use MIME::Base64;
+
+###--------------------------------------------------------------------------
+### Early utilities.
+
+sub merge_hash (\%%) {
+ my ($hashref, %defaults) = @_;
+ for my $k (keys %defaults)
+ { $hashref->{$k} = $defaults{$k} unless exists $hashref->{$k}; }
+}
+
+###--------------------------------------------------------------------------
+### Configuration.
+
+our $DSN = "dbi:Pg(pg_enable_utf8=>1):host=db";
+our $RETRY = 10;
+our @BACKOFF = (0.1, 10, 1.5, 0.5, 2.0);
+
+our $BASEURL = "http://odin.gg/";
+our $STATIC = "http://odin.gg/";
+
+our $SHORTURL_PATH = "u";
+our $PASTEBIN_PATH = "p";
+
+our $URLMAXLEN = 1024;
+our @URLPAT = (
+ qr{^https?://}
+);
+
+our %COOKIE_DEFAULTS = (
+ -httponly => undef,
+ -max_age => 3600
+);
+
+require "config.pl";
+
+our ($SCHEME, $DOMAIN, $BASEPATH) = $BASEURL =~ m!^([^:]+)://([^/]+)(/.*)$!;
+merge_hash %COOKIE_DEFAULTS, -domain => $DOMAIN, -path => $BASEPATH;
+merge_hash %COOKIE_DEFAULTS, -secure => undef if $SCHEME eq "https";
+
+our $SHORTURL = "$BASEURL$SHORTURL_PATH";
+our $PASTEBIN = "$BASEURL$PASTEBIN_PATH";
+
+###--------------------------------------------------------------------------
+### Miscellaneous utilities.
+
+(our $PROG = $0) =~ s:^.*/::;
+
+sub fail_cmdline ($$%) {
+ my ($msg, $label, %args) = @_;
+ print STDERR "$PROG: $msg\n";
+ exit 1;
+}
+
+our $FAILPROC = \&fail_cmdline;
+
+sub fail ($;$%) {
+ my ($msg, $label, %args) = @_;
+ $FAILPROC->($msg, $label, %args);
+}
+
+sub set_mason_failproc ($) {
+ my ($m) = @_;
+ $FAILPROC = sub {
+ my ($msg, $label, %args) = @_;
+ $m->clear_buffer;
+ $m->comp($label, %args);
+ $m->abort;
+ };
+}
+
+sub nice_name ($) {
+ my ($s) = @_;
+ $s =~ s/\W+//g;
+ return lc $s;
+}
+
+###--------------------------------------------------------------------------
+### Database utilities.
+
+sub open_db (@) {
+ my @attr = @_;
+ my $db = DBI->connect_cached($DSN, undef, undef, {
+ PrintError => 0,
+ RaiseError => 1,
+ @attr
+ });
+
+ my $drv = $db->{Driver}{Name};
+ if ($drv eq "Pg") {
+ $db->{private_odin_retry_p} = sub { $db->state =~ /^40[0P]01$/ };
+ $db->{private_odin_unixstamp} = sub { "extract(epoch from $_[0])" };
+ } elsif ($drv eq "SQLite") {
+ $db->{private_odin_retry_p} = sub { $db->err == 5 };
+ $db->{private_odin_unixstamp} = sub { "strftime('%s', $_[0])" };
+ } else {
+ fail "unsupported database driver `$drv' (patches welcome)", undef;
+ }
+
+ return $db;
+}
+
+sub xact (&$) {
+ my ($body, $db) = @_;
+ my @rv;
+ my $exc;
+
+ my ($sleep, $maxsleep, $mult, $minvar, $maxvar) = @BACKOFF;
+ for (my $i = 0; $i < $RETRY; $i++) {
+ $db->begin_work;
+ eval { @rv = $body->(); $db->commit; };
+ $exc = $@;
+ return @rv unless $exc;
+ my $retryp = $db->{private_odin_retry_p}();
+ eval { $db->rollback; };
+ die $exc unless $retryp;
+ my $t = $sleep * ($minvar + rand($maxvar - $minvar));
+ $sleep *= $mult; $sleep = $max if $sleep > $max;
+ select undef, undef, undef, $t;
+ }
+ die $exc;
+}
+
+sub sql_timestamp ($$) {
+ my ($db, $col) = @_;
+ return $db->{private_odin_unixstamp}->($col);
+}
+
+###--------------------------------------------------------------------------
+### Sequence numbers and tagging.
+
+sub next_seq ($$) {
+ my ($db, $table) = @_;
+ my ($seq) = $db->selectrow_array("SELECT seq FROM $table");
+ die "no sequence number in $table" unless defined $seq;
+ $db->do("UPDATE $table SET seq = ?", undef, $seq + 1);
+ return $seq;
+}
+
+my $ALPHABET =
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
+my $NALPHA = length $ALPHABET;
+
+sub encode_tag ($) {
+ my ($seq) = @_;
+ my $tag = "";
+ while ($seq) {
+ $tag .= substr($ALPHABET, $seq % $NALPHA, 1);
+ $seq = int $seq/$NALPHA;
+ }
+ return $tag;
+}
+
+###--------------------------------------------------------------------------
+### HTTP utilities.
+
+our %COOKIE;
+sub fetch_cookies ($) {
+ my ($r) = @_;
+
+ %COOKIE = ();
+ my $cookies = $r->header_in("Cookie");
+ if (defined $cookies) {
+ for my $kv (split /;/, $cookies) {
+ my ($k, $v) = split /=/, $kv, 2;
+ $k =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
+ $v =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
+ $v =~ s/\+/ /g;
+ $v =~ s/\%([0-9a-f][0-9a-f])/chr hex $1/eg;
+ $COOKIE{$k} = $v;
+ }
+ }
+}
+
+sub bake_cookie ($$%) {
+ my ($r, $cookie, %attr) = @_;
+ merge_hash %attr, %COOKIE_DEFAULTS;
+ my @attr = map {
+ my $v = $attr{$_}; tr/_-/-/d;
+ defined $v ? "$_=$v" : $_
+ } keys %attr;
+ $r->headers_out->add("Set-Cookie", join "; ", $cookie, @attr);
+}
+
+sub path_info ($) {
+ my ($r) = @_;
+ return $ENV{PATH_INFO} // $r->path_info;
+}
+
+###--------------------------------------------------------------------------
+### HTML utilities.
+
+sub escapify ($$;$) {
+ my ($m, $s, $mode) = @_;
+ return $m->interp->apply_escapes($s, $mode // "h");
+}
+
+###--------------------------------------------------------------------------
+### Access control.
+
+our ($WHO, $WHOSURE);
+our ($WHOMATCH, $WHOCMP, $WHOPAT);
+
+sub cgi_who ($) {
+ my ($r) = @_;
+ my $raddr = $ENV{REMOTE_ADDR} // $r->connection->remote_ip;
+ $WHO = ":NET-$raddr"; $WHOSURE = 0;
+ $WHOMATCH = "LIKE"; $WHOCMP = ":NET-\%"; $WHOPAT = qr/^:NET-/;
+}
+
+sub cmdline_who () {
+ $WHO = $ENV{USERV_USER}
+ // ($< == $> && $ENV{USER})
+ // @{[getpwuid $<]}[0]
+ // die "nameless user";
+ $WHOMATCH = "="; $WHOCMP = $WHO; $WHOPAT = qr/^\Q$WHO\E$/;
+ $WHOSURE = 1;
+}
+
+sub new_editkey () {
+ open my $fh, "/dev/urandom" or die "open urandom: $!";
+ sysread $fh, my $rand, 16;
+ (my $edit = encode_base64 $rand) =~ tr:+/=\n:.-:d;
+ return $edit, sha256_hex $edit;
+}
+
+###--------------------------------------------------------------------------
+### URL shortening.
+
+sub get_shorturl ($) {
+ my ($tag) = @_;
+
+ my $db = open_db;
+ my ($url) = $db->selectrow_array
+ ("SELECT url FROM odin_shorturl WHERE tag = ?", undef, $tag);
+ fail "tag `$tag' not found", ".notfound", tag => $tag unless defined $url;
+ return $url;
+}
+
+sub valid_url_p ($) {
+ my ($url) = @_;
+ return
+ length $url < $URLMAXLEN &&
+ scalar grep { $url =~ /$_/ } @URLPAT;
+}
+
+sub new_shorturl ($) {
+ my ($url) = @_;
+
+ valid_url_p $url or fail "invalid url", ".badurl", u => $url;
+
+ my $db = open_db;
+ my $tag;
+ xact {
+ ($tag) = $db->selectrow_array
+ ("SELECT tag FROM odin_shorturl WHERE owner $WHOMATCH ? AND url = ?",
+ undef, $WHOCMP, $url);
+ unless (defined $tag) {
+ $tag = encode_tag(next_seq($db, "odin_shorturl_seq"));
+ $db->do("INSERT INTO odin_shorturl (tag, owner, url) VALUES (?, ?, ?)",
+ undef, $tag, $WHO, $url);
+ }
+ } $db;
+ return $tag;
+}
+
+sub check_shorturl_owner ($$) {
+ my ($db, $tag) = @_;
+
+ my ($owner) = $db->selectrow_array
+ ("SELECT owner FROM odin_shorturl WHERE tag = ?", undef, $tag);
+ fail "tag `$tag' not found", ".notfound", tag => $tag
+ unless defined $owner;
+ fail "not owner of `$tag'", ".notowner", tag => $tag
+ unless $owner =~ /$WHOPAT/;
+}
+
+sub update_shorturl ($$) {
+ my ($tag, $url) = @_;
+
+ my $db = open_db;
+ xact {
+ check_shorturl_owner $db, $tag;
+ $db->do("UPDATE odin_shorturl SET url = ? WHERE tag = ?",
+ undef, $url, $tag);
+ } $db;
+}
+
+sub delete_shorturl (@) {
+ my (@tags) = @_;
+
+ my $db = open_db;
+ xact {
+ for my $tag (@tags) {
+ check_shorturl_owner $db, $tag;
+ $db->do("DELETE FROM odin_shorturl WHERE tag = ?", undef, $tag);
+ }
+ } $db;
+}
+
+###--------------------------------------------------------------------------
+### Paste bin.
+
+our %PASTEBIN_DEFAULTS = (
+ title => "(untitled)",
+ lang => "plain-text",
+ content => ""
+);
+our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
+our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
+our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;
+
+sub new_pastebin (\%) {
+ my ($new) = @_;
+
+ my $db = open_db;
+ my ($editkey, $hash) = new_editkey;
+ my $tag;
+
+ merge_hash %$new, %PASTEBIN_DEFAULTS;
+ xact {
+ $tag = encode_tag next_seq $db, "odin_pastebin_seq";
+ $db->do("INSERT INTO odin_pastebin
+ (tag, edithash, owner, $PASTEBIN_PROPCOLS)
+ VALUES (?, ?, ?, $PASTEBIN_PROPPLACES)", undef,
+ $tag, $hash, $WHO, @{$new}{@PASTEBIN_PROPS});
+ } $db;
+ return $tag, $editkey;
+}
+
+sub get_pastebin ($$\%) {
+ my ($db, $tag, $props) = @_;
+
+ (my $owner, my $hash, @{$props}{@PASTEBIN_PROPS}) =
+ $db->selectrow_array("SELECT owner, edithash, $PASTEBIN_PROPCOLS
+ FROM odin_pastebin WHERE tag = ?",
+ undef, $tag);
+ fail "tag `$tag' not found", ".notfound", tag => $tag
+ unless defined $owner;
+ return $owner, $hash;
+}
+
+sub get_pastebin_check_owner ($$\%) {
+ my ($db, $tag, $props) = @_;
+
+ my ($owner, $hash) = get_pastebin $db, $tag, %$props;
+ fail "not owner of `$tag'", ".notowner", tag => $tag
+ unless $WHOSURE && $WHO eq $owner;
+}
+
+sub get_pastebin_check_editkey_or_owner ($$$\%) {
+ my ($db, $tag, $editkey, $props) = @_;
+
+ if (!defined $editkey) { get_pastebin_check_owner $db, $tag, %$props; }
+ else {
+ my ($owner, $hash) = get_pastebin $db, $tag, %$props;
+ fail "incorrect edit key for `$tag'", ".badhash", tag => $tag
+ unless $hash eq sha256_hex $editkey;
+ }
+}
+
+sub rekey_pastebin ($) {
+ my ($tag) = @_;
+
+ my $db = open_db;
+ my $editkey;
+ xact {
+ get_pastebin_check_owner $db, $tag, my %hunoz;
+ ($editkey, my $hash) = new_editkey;
+ $db->do("UPDATE odin_pastebin SET edithash = ? WHERE tag = ?",
+ undef, $hash, $tag);
+ } $db;
+ return $editkey;
+}
+
+sub claim_pastebin ($$) {
+ my ($tag, $editkey) = @_;
+
+ my $db = open_db;
+ $WHOSURE or fail "you can't claim pastes", ".notsure";
+ xact {
+ get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
+ $db->do("UPDATE odin_pastebin SET owner = ? WHERE tag = ?",
+ undef, $WHO, $tag);
+ } $db;
+}
+
+sub update_pastebin ($$\%) {
+ my ($tag, $editkey, $new) = @_;
+
+ my $db = open_db;
+ my $editp = 0;
+ xact {
+ get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %old;
+ for my $p (@PASTEBIN_PROPS) {
+ if (!defined $new->{$p}) { $new->{$p} = $old{$p}; }
+ else {
+ $db->do("UPDATE odin_pastebin SET $p = ? WHERE tag = ?",
+ undef, $new->{$p}, $tag)
+ unless $new->{$p} eq $old{$p};
+ $editp = 1;
+ }
+ }
+ } $db;
+ return $editp;
+}
+
+sub delete_pastebin (@) {
+ my @a = @_;
+ my $db = open_db;
+ xact {
+ while (@a) {
+ (my $tag, my $editkey, @a) = @a;
+ get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
+ $db->do("DELETE FROM odin_pastebin WHERE tag = ?", undef, $tag);
+ }
+ } $db;
+}
+
+sub tidy_pastebin_content ($) {
+ my ($content) = @_;
+ return undef unless defined $content;
+ $content =~ tr/\r//d;
+ $content =~ s/([^\n])\z/$1\n/;
+ return $content;
+}
+
+###----- That's all, folks --------------------------------------------------
+
+1;
--- /dev/null
+<%perl>
+ Odin::set_mason_failproc $m;
+ Odin::cgi_who $r;
+ Odin::fetch_cookies $r;
+ $r->content_type("text/html; charset=utf8");
+ $m->call_next;
+</%perl>
+%#
+<%method wrapper>\
+% $r->header_out(Status => $status) if defined $status;
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"
+ "http://www.w3c.org/TR/html4/strict.dtd">
+
+<html>
+<head>
+<link rel="stylesheet" type="text/css" href="<% $Odin::STATIC %>odin.css">
+<meta name="viewport" content="width=device-width" initial-scale=1.0>
+<& SELF:header &>
+<title>\
+% defined $title ? $m->print($title) : $m->comp("SELF:title");
+</title>
+</head>
+<body>
+
+<% $m->content %>
+<div class="footer">
+Written by Mark Wooding<br>
+</div>
+</body>
+</html>
+<%args>
+ $status => undef
+ $title => undef
+</%args>
+</%method>
+%#
+<%method title>(Untitled page)</%method>
+<%method header></%method>
+%#
+<%method error>\
+<&| SELF:wrapper, status => $status, title => $title // $m->content &>\
+<h1>\
+% if (defined $title) {
+Error: <% $title %>\
+% } else {
+Error\
+% }
+</h1>
+<p><% $m->content %>
+</&>
+<%args>
+ $status => 500
+ $title => undef
+</%args>
+</%method>
+%#
+<%once>
+ use utf8;
+ use Odin;
+</%once>
--- /dev/null
+<&| SELF:wrapper, title => "odin.gg Paste Bin" &>
+<h1><tt>odin.gg</tt> Paste Bin</h1>
+%#
+% my $sep = "<div class=menu>\n";
+% my $end = "";
+% if (length $tag) {
+% $m->print($sep);
+ <span class="item"><a href="<% "$Odin::PASTEBIN/$tag" %>">View</a></span>
+ <span class="item"><a href="<% "$Odin::PASTEBIN/$tag?edit=$edit;op=del" %>">Delete</a></span>
+% $sep = ""; $end = "</div>\n";
+% }
+% $m->print($end);
+%#
+<form method="POST" action="<% "$Odin::PASTEBIN/$tag" %>"
+ accept-charset="UTF-8" enctype="multipart/form-data">
+ <div class="pastebin">
+% if (defined $edit) {
+ <input type="hidden" name="edit" value="<% $edit |h %>">
+% }
+%#
+ <label class="invis" for="content" accesskey="c"><u>C</u>ontent</label>
+ <textarea id="content" name="content" rows=48 cols=80><%
+ $content |h %></textarea>
+%#
+ <div class="paste-widgets">
+%#
+ <label class="invis" for="lang" accesskey="l"><u>L</u>abel</label>
+ <select id="lang" name="lang" default="plain-text">
+% my $lh = $db->selectall_hashref
+% ("SELECT lang, descr FROM odin_pastebin_lang", "descr");
+% for my $d (sort { Odin::nice_name $a cmp Odin::nice_name $b }
+% keys %$lh) {
+% my $l = $lh->{$d}{lang};
+ <option value="<% $l %>"<%
+ $l eq $lang ? " selected" : "" %>><%
+ $d |h %></option>
+% }
+ </select>
+%#
+ <label class="invis" for="title" accesskey="t"><u>T</u>itle</label>
+ <input id="title" name="title" value="<% $title |h %>">
+%#
+ <button type="submit">Go</button>
+%#
+ </div>
+ </div>
+</form>
+</&>
+%#
+<%args>
+ $content => ""
+ $tag => ""
+ $edit => undef
+ $lang => "txt"
+ $title => "(untitled)"
+</%args>
+%#
+<%init>
+ my $db = Odin::open_db;
+</%init>
+%#
+<%once>
+ use utf8;
+</%once>
--- /dev/null
+<&| SELF:wrapper,
+ title => Odin::escapify($m, $title) . " (odin.gg Paste Bin)" &>
+<h1><tt>odin.gg</tt> Paste Bin: <% $title %></h1>
+<div class="menu">
+ <span class="item"><a href="<% "$Odin::PASTEBIN/$tag?op=raw" %>">Raw</a></span>
+% if (defined $edit) {
+ <span class="item"><a href="<% "$Odin::PASTEBIN/$tag?edit=$edit" %>">Edit</a></span>
+% }
+</div>
+<pre class="paste">
+% if ($lang eq 'txt') {
+<% $content |h %>\
+% } else {
+<%perl>
+ my $kid = open my $fh, "-|" // die "fork: $!";
+ if ($kid == 0) {
+ open my $hl, "|-", "highlight", "-Ohtml", "-f", "-t8", "-S$lang"
+ or die "open highlight: $!";
+ syswrite $hl, $content // die "highlight write: $!";
+ close $hl or die "highlight kid: $!, $?";
+ exit 0;
+ } else {
+ while (sysread $fh, my $buf, 8192) { $m->print($buf); }
+ close $fh and waitpid $kid, 0
+ or die "highlight parent: $!, $?";
+ }
+</%perl>
+% }
+</pre>
+</&>
+%#
+<%args>
+ $content
+ $title
+ $lang
+ $tag
+ $edit => undef
+</%args>
+%#
+<%init>
+ my $db = Odin::open_db;
+</%init>
+%#
+<%once>
+ use utf8;
+</%once>
--- /dev/null
+../../lib
\ No newline at end of file
--- /dev/null
+../common/autohandler
\ No newline at end of file
--- /dev/null
+<%perl>
+ my $tag = $m->dhandler_arg;
+
+ sub set_handoff_cookie ($$%) {
+ my ($tag, $edit, %attr) = @_;
+ Odin::bake_cookie $r, "odin-handoff.$tag=$edit",
+ -path => "$Odin::PASTEBIN_PATH/", %attr;
+ }
+
+ my %props = (
+ lang => $lang, title => $title,
+ content => Odin::tidy_pastebin_content $content
+ );
+
+ if (length $tag) {
+
+ if (!defined $edit) {
+ my $db = Odin::open_db;
+ Odin::get_pastebin $db, $tag, my %old;
+ if ($op eq "raw") {
+ $r->content_type("text/plain; charset=utf8");
+ $m->print($old{content});
+ } else {
+ $m->comp("%show", tag => $tag, %old,
+ edit => $Odin::COOKIE{"odin-handoff.$tag"});
+ }
+ } else {
+ if ($op eq "del") {
+ Odin::delete_pastebin $tag, $edit;
+ set_handoff_cookie $tag, "nil", -max_age => 5;
+ $m->redirect("$Odin::PASTEBIN/");
+ } else {
+ my $editp = Odin::update_pastebin $tag, $edit, %props;
+ set_handoff_cookie $tag, $edit;
+ if ($editp) { $m->redirect("$Odin::PASTEBIN/$tag"); }
+ else { $m->comp("%edit", tag => $tag, edit => $edit, %props); }
+ }
+ }
+ } elsif (defined $content) {
+ ($tag, $edit) = Odin::new_pastebin %props;
+ set_handoff_cookie $tag, $edit;
+ $m->redirect("$Odin::PASTEBIN/$tag");
+ } else {
+ Odin::path_info($r) =~ m:/$:
+ or $m->redirect("$Odin::PASTEBIN/", 301);
+ $m->comp("%edit");
+ }
+</%perl>
+%#
+<%args>
+ $content => undef
+ $edit => undef
+ $lang => undef
+ $title => undef
+ $op => "edit"
+</%args>
+%#
+<%def .notfound>
+<&| SELF:error, title => "not found", status => 404 &>\
+tag ‘<% $tag %>’ not found
+</&>
+<%args>
+ $tag
+</%args>
+</%def>
+%#
+<%def .badhash>
+<&| SELF:error, status => 404 &>\
+incorrect edit key
+</&>
+<%args>
+ $tag
+</%args>
+</%def>
+%#
+<%once>
+ use utf8;
+ use Digest::SHA qw(sha256_hex);
+ use Odin;
+</%once>
--- /dev/null
+../../lib
\ No newline at end of file
--- /dev/null
+../common/autohandler
\ No newline at end of file
--- /dev/null
+<&| SELF:wrapper, title => "odin.gg URL Shortener" &>
+<h1><tt>odin.gg</tt> URL Shortener</h1>
+<form method="POST" accept-charset="UTF-8" enctype="multipart/form-data">
+ <label for="url" accesskey="u"><u>U</u>RL to shorten:</label>
+ <input id="url" name="u" value="<% $u // "" |h %>">
+ <button type="submit">Go</button>
+</form>
+% if (defined $tag) {
+<p>Shortened to: <a href="<% "$Odin::SHORTURL/$tag" %>"><%
+ "$Odin::SHORTURL/$tag" %></a>
+% }
+</&>
+%#
+<%init>
+ my $tag = $m->dhandler_arg;
+ if (length $tag) {
+ my $url = Odin::get_shorturl $tag;
+ if ($q) { $m->comp(".query", url => $url); }
+ else { $m->redirect($url, 301); }
+ return;
+ } elsif (defined $u) {
+ $tag = Odin::new_shorturl $u;
+ } else {
+ Odin::path_info($r) =~ m:/$:
+ or $m->redirect("$Odin::SHORTURL/", 301);
+ $tag = undef;
+ }
+</%init>
+%#
+<%args>
+ $q => undef
+ $u => undef
+</%args>
+%#
+<%def .query>\
+% $r->content_type("text/plain; charset=utf8");
+<% $url %>
+<%args>
+ $url
+</%args>
+</%def>
+%#
+<%def .notfound>\
+<&| SELF:error, title => "not found", status => 404 &>\
+tag ‘<% $tag |h %>’ not found
+</&>
+<%args>
+ $tag
+</%args>
+</%def>
+%#
+<%def .badurl>\
+<&| SELF:error, title => "invalid url", status => 404 &>\
+‘<tt><% $u |h %></tt>’ is not a valid URL
+</&>
+<%args>
+ $u
+</%args>
+</%def>
+%#
+<%once>
+ use utf8;
+ use Odin;
+</%once>
--- /dev/null
+/* -*-sql-*-
+ *
+ * Plain old SQL for setting up the tables for Odin web services.
+ */
+
+/* The various tools assume that the database is appropriate configured with
+ * the SERIALIZABLE isolation level.
+ */
+
+begin;
+
+drop table if exists odin_pastebin;
+drop table if exists odin_pastebin_lang;
+drop table if exists odin_pastebin_seq;
+
+create table odin_pastebin_lang
+ (lang varchar(32) primary key
+ descr varchar(64) not null);
+insert into odin_pastebin_lang (lang, descr) values ('txt', 'Plain text');
+
+create table odin_pastebin_seq (seq int);
+insert into odin_pastebin_seq (seq) values (10000);
+
+create table odin_pastebin
+ (tag varchar(16) primary key,
+ stamp timestamp not null default current_timestamp,
+ edithash varchar(128) not null,
+ owner varchar(64) not null,
+ title varchar(128) not null,
+ lang varchar(32) not null
+ default 'plain-text'
+ references odin_pastebin_lang (lang)
+ on update cascade
+ on delete set default
+ deferrable initially deferred,
+ content text not null);
+create index odin_pastebin_by_lang on odin_pastebin (lang);
+create index odin_pastebin_by_owner on odin_pastebin (owner);
+
+commit;
--- /dev/null
+/* -*-sql-*-
+ *
+ * Plain old SQL for setting up the tables for Odin web services.
+ */
+
+/* The various tools assume that the database is appropriate configured with
+ * the SERIALIZABLE isolation level.
+ */
+
+begin;
+
+drop table odin_shorturl;
+drop table odin_shorturl_seq;
+
+create table odin_shorturl_seq (seq int);
+insert into odin_shorturl_seq (seq) values (10000);
+
+create table odin_shorturl
+ (tag varchar(16) primary key,
+ stamp timestamp not null default current_timestamp,
+ owner varchar(64) not null,
+ url text not null);
+create index odin_shorturl_by_owner on odin_shorturl (owner);
+
+commit;
--- /dev/null
+div.footer {
+ margin-top: 2ex;
+ border-top: solid thin black;
+ padding-top: 1ex;
+ clear: both;
+ text-align: right;
+ font-style: italic;
+}
+
+div.menu {
+ border-bottom: solid thin black;
+ padding-bottom: 1ex;
+ margin-bottom: 2ex;
+}
+
+div.menu > .item:first-child:before {
+ content: ""
+}
+
+div.menu > .item:before {
+ content: " | "
+}
+
+.invis {
+ display: none;
+}
+
+.num { color: #a5a50b; }
+.esc, .str, .dstr, .pps { color: #188fb6; }
+.com, .slc { color: #2e8b57; font-style: italic; }
+.dir, .kwa, .kwb, .kwc, .ppc { color: #000000; font-weight: bold; }
+.kwd { color: #000000; }
+.sym, .opt { color: #c7831d; }
+.line { color: #555555; }
+
+input#url { min-width: 48em; }
+input#title { min-width: 24em; }
+
+div.pastebin { float: left; }
+div.paste-widgets { text-align: center; margin: 1ex; }
~mdw / odin-cgi / commitdiff