[odin-cgi] / lib / Odin.pm

### -*-perl-*-

package Odin;

use DBI;
use Date::Parse;
use Digest::SHA qw(sha256_hex);
use MIME::Base64;
use POSIX;

###--------------------------------------------------------------------------
### 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 $PASTEMAXLEN = 1024*1024;

our %COOKIE_DEFAULTS = (
  -httponly => undef,
  -max_age => 3600
);

our $ALPHA = "abcdefghijklmnopqrstuvwxyz";
our $NUM = "0123456789";
our $SAFECH = qr/^[-\w_.+]*$/;

our %GENPARAM = ();
our %GENMAP = ();
our %MAILDOM_POLICY = ();
our $MAIL_QUALDOM;

our @MAIL_DEFGEN = "chars";
our $MAIL_MAXGENTRY = 32;

our $MAIL_DEFDOMAIN = "odin.gg";
our $MAIL_ADDRMAX_LIVE = 16384;
our $MAIL_ADDRMAX_RESV = 32;
our $MAIL_AGEMAX_RESV = 3600;

our ($SCHEME, $DOMAIN, $BASEPATH);
our ($SHORTURL, $PASTEBIN);

###--------------------------------------------------------------------------
### Miscellaneous utilities.

our $NOW;
sub update_now () { $NOW = time; }
update_now;

(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;
}

my %TIMEUNIT = (
  "" => 1,
  "s" => 1, "m" => 60, "h" => 3600,
  "d" => 86400, "w" => 604800
);
sub parse_time ($) {
  my ($date) = @_;
  return undef unless defined $date;
  if ($date =~ /^\+\s*(\d+)\s*([smhdw]?)\s*$/)
    { return $NOW + $1 * $TIMEUNIT{$2}; }
  my $t = str2time($date);
  defined $t or Odin::fail "invalid time `$date'";
  return $t;
}

sub print_columns (@) {
  my @col = reverse @_;
  my @fmt = ();
  my @val = ();
  while (@col && $col[1] eq "") { splice @col, 0, 2; }
  my ($wd, $v) = splice @col, 0, 2;
  push @fmt, "%s"; push @val, $v;
  while (@col) {
    my ($wd, $v) = splice @col, 0, 2;
    push @fmt, "%-${wd}s";
    push @val, $v;
  }
  printf join("  ", reverse @fmt) . "\n", reverse @val;
}

sub fmt_time ($) {
  my ($t) = @_;
  return $t == -1 ? "--" : strftime "%Y-%m-%d %H:%M:%S %z", localtime $t;
}

###--------------------------------------------------------------------------
### 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$/ };
  } elsif ($drv eq "SQLite") {
    $db->{private_odin_retry_p} = sub { $db->err == 5 };
  } else {
    $db->{private_odin_retry_p} = sub { 0 };
  }

  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 insert_record ($$%) {
  my ($db, $table, %fields) = @_;
  my @var = ();
  my @val = ();

  for my $v (keys %fields) {
    push @var, $v;
    push @val, $fields{$v};
  }
  $db->do("INSERT INTO $table (" . join(", ", @var) . ")
	   VALUES (" . join(", ", map { "?" } @var) . ")", undef, @val);
}

###--------------------------------------------------------------------------
### 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"));
      insert_record $db, "odin_shorturl",
	tag => $tag, stamp => $NOW, owner => $WHO, url => $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 => "txt",
  content => ""
);
our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;

sub check_lang ($) {
  my ($lang) = @_;

  return unless defined $lang;
  my $db = open_db;
  @{$db->selectall_arrayref
    ("SELECT lang FROM odin_pastebin_lang WHERE lang = ?", undef, $lang)}
    or fail "unknown language `$lang'";
}

sub new_pastebin (\%) {
  my ($new) = @_;

  my $db = open_db;
  my ($editkey, $hash) = new_editkey;
  my $tag;

  merge_hash %$new, %PASTEBIN_DEFAULTS;
  check_lang $new->{lang};
  xact {
    $tag = encode_tag next_seq $db, "odin_pastebin_seq";
    insert_record $db, "odin_pastebin",
      tag => $tag, stamp => $NOW, edithash => $hash, owner => $WHO,
      %$new;
  } $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;
  check_lang $new->{lang};
  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/;
  length $content <= $PASTEMAXLEN or
    fail "invalid paste content", ".badpaste";
  return $content;
}

###--------------------------------------------------------------------------
### Mail redirection utilities.

sub redir_query ($$$;$@) {
  my ($db, $dom, $owner, $cond, @args) = @_;
  return @{$db->selectall_arrayref
	     ("SELECT lpart, expire, recip, comment
	       FROM odin_mailredir WHERE dom = ? AND owner = ?" .
	       (defined $cond ? " AND $cond" : "") . " " .
	      "ORDER BY expire, lpart", undef, $dom, $owner, @args)};
}

sub clear_redir_reservations ($) {
  my ($db) = @_;
  $db->do("DELETE FROM odin_mailredir WHERE
	   st = 'reserved' AND expire < ?", undef,
	  $NOW);
  $db->do("UPDATE odin_mailredir SET st = 'dormant', expire = -1
	   WHERE st = 'live' AND expire <> -1 AND expire < ?", undef, $NOW);
}

sub check_redir_limits ($) {
  my ($db) = @_;
  my %h = map { $_->[0] => $_->[1] }
    @{ $db->selectall_arrayref("SELECT st, COUNT(*) FROM odin_mailredir
				WHERE owner = ? GROUP BY st", undef,
			       $Odin::WHO) };
  for my $st (qw(live dormant reserved)) { $h{$st} //= 0; }
  $h{live} + $h{dormant} + $h{reserved} <= $MAIL_ADDRMAX_LIVE or
    Odin::fail "too many addresses claimed (see your sysadmin)";
  $h{reserved} <= $MAIL_ADDRMAX_RESV or
    Odin::fail "too many addresses reserved (time to release some)";
}

sub gencls ($) {
  my ($g) = @_;
  return $GENMAP{$g} // die "configuration error: no generator class `$g'";
}

sub default_generator_class ($) {
  my ($dom) = @_;

  my $g = $MAILDOM_POLICY{$dom}{gen}[0] // $MAIL_DEFGEN[0];
  return gencls $g;
}

sub get_generator_class ($$) {
  my ($dom, $g) = @_;

  grep { $_ eq $g } @{$MAILDOM_POLICY{$dom}{gen} // \@MAIL_DEFGEN}
    or fail "domain `$dom' doesn't allow generator `$g'";
  return gencls $g;
}

sub gen_redir_name ($$) {
  my ($db, $gen) = @_;

  for (my $try = 0; $try < $MAIL_MAXGENTRY; $try++) {
    my $l = lc $gen->gen;
    return $l
      unless $db->selectrow_arrayref
	("SELECT 1 FROM odin_mailredir WHERE lpart = ? AND dom = ?",
	 undef, $l, $DOMAIN);
  }
  Odin::fail "failed to find unique local part";
}

sub qualify_recip ($) {
  my ($r) = @_;

  return $r =~ /\@/ || !defined $MAIL_QUALDOM ? $r : "$r\@$MAIL_QUALDOM";
}

sub check_fixup_redir ($) {
  my ($r) = @_;

  if (exists $r->{recip}) {
    $r->{recip} =~ /^[!-~]+$/ or fail "invalid recipient name `$r->{recip}'";
    $r->{recip} = qualify_recip $r->{recip};
  }
}

sub new_redir ($$\%;$) {
  my ($dom, $gen, $r, $n) = @_;
  my $db = open_db;
  my @l;

  $n //= 1;
  check_fixup_redir $r;
  Odin::xact {
    clear_redir_reservations $db;
    while (@l < $n) {
      my $l = Odin::gen_redir_name $db, $gen;
      insert_record $db, "odin_mailredir",
	lpart => $l, dom => $dom, st => 'live',
	owner => $WHO, creator => $WHO,
	recip => $r->{recip} // qualify_recip $Odin::WHO,
	expire => $r->{expire} // -1,
	comment => $r->{comment} // "";
      push @l, $l;
    }
    check_redir_limits $db;
  } $db;
  return @l;
}

sub reserve_redir ($$$) {
  my ($dom, $gen, $n) = @_;
  my $db = open_db;
  my @l;

  Odin::xact {
    clear_redir_reservations $db;
    @l = ();
    for (my $i = 0; $i < $n; $i++) { push @l, gen_redir_name $db, $gen; }
    for my $l (@l) {
      insert_record $db, "odin_mailredir",
	lpart => $l, dom => $dom, owner => $WHO,
	st => 'reserved', expire => $NOW + $MAIL_AGEMAX_RESV;
    }
    check_redir_limits $db;
  } $db;
  return @l;
}

sub release_all_redir ($) {
  my ($dom) = @_;
  my $db = open_db;

  my $st = $db->prepare("DELETE FROM odin_mailredir
			 WHERE dom = ? AND owner = ? AND st = 'reserved'");
  Odin::xact {
    $st->execute($dom, $WHO);
    $st->rows or Odin::fail "no reserved addresses";
  } $db;
}

sub release_redir ($@) {
  my ($dom, @l) = @_;
  my $db = open_db;

  my $st = $db->prepare("DELETE FROM odin_mailredir
			 WHERE lpart = ? AND dom = ? AND
			       owner = ? AND st = 'reserved'");
  Odin::xact {
    clear_redir_reservations $db;
    for my $l (@l) {
      $st->execute($l, $dom, $WHO);
      Odin::fail "local part `$l' not reserved" unless $st->rows;
    }
  } $db;
}

sub disable_redir ($$) {
  my ($dom, @l) = @_;
  my $db = open_db;

  my $st = $db->prepare("UPDATE odin_mailredir
			 SET st = 'dormant', expire = -1
			 WHERE lpart = ? AND dom = ? AND
			       owner = ? AND st = 'live'");
  Odin::xact {
    clear_redir_reservations $db;
    for my $l (@ARGV) {
      $st->execute($l, $dom, $WHO);
      Odin::fail "local part `$l' not live" unless $st->rows;
    }
  } $db;
}

sub modify_redir ($\%@) {
  my ($dom, $r, @l) = @_;
  my $db = open_db;

  check_fixup_redir $r;
  Odin::xact {
    clear_redir_reservations $db;
    for my $l (@l) {
      my %r = %$r;
      my ($recip, $st) = $db->selectrow_array
	("SELECT recip, st FROM odin_mailredir
	  WHERE lpart = ? AND dom = ? AND owner = ?", undef,
	 $l, $dom, $WHO);
      if (!defined $recip) { Odin::fail "unknown local part `$l'"; }
      elsif ($recip eq "") { $r{recip} //= qualify_recip $WHO; }
      if ($st ne "live") { $r{st} = "live"; $r{expire} //= -1; }
      my @var = ();
      my @val = ();
      for my $v (keys %r) {
	push @var, $v;
	push @val, $r{$v};
      }
      @var or fail "nothing to change";
      $db->do("UPDATE odin_mailredir SET " .
	      join(", ", map { "$_ = ?" } @var) . " " .
	      "WHERE lpart = ? AND dom = ?", undef,
	      @val, $l, $dom);
    }
  } $db;
}

###--------------------------------------------------------------------------
### Simple option parser.

package Odin::OptParse;

sub new {
  my ($cls, @args) = @_;
  return bless {
    cur => "",
    args => \@args,
    opt => undef,
    ok => 1
  }, $cls;
}

sub get {
  my ($me) = @_;
  if (!length $me->{cur}) {
    my $args = $me->{args};
    if (!@$args) { return undef; }
    elsif ($args->[0] =~ /^[^-]|^-$/) { return undef; }
    elsif ($args->[0] eq "--") { shift @$args; return undef; }
    $me->{cur} = substr shift @$args, 1;
  }
  my $o = $me->{opt} = substr $me->{cur}, 0, 1;
  $me->{cur} = substr $me->{cur}, 1;
  return $o;
}

sub arg {
  my ($me) = @_;
  my $a;
  if (length $me->{cur}) { $a = $me->{cur}; $me->{cur} = ""; }
  elsif (@{$me->{args}}) { $a = shift @{$me->{args}}; }
  else { $a = undef; $me->err("option `-$me->{opt}' requires an argument"); }
  return $a;
}

sub intarg {
  my ($me, $what, $min, $max) = @_;
  $what //= "option `-$me->{opt}'";
  defined (my $a = $me->arg) or return undef;
  if ($a !~ /^[-+]?\d+$/ ||
      (defined $min && $a < $min) ||
      (defined $max && $a > $max)) {
    $me->err("invalid value `$a' for $what");
    $a = undef;
  }
  return $a;
}

sub rest { return @{$_[0]->{args}}; }
sub ok { return $_[0]->{ok}; }
sub bad { $_[0]->{ok} = 0; }
sub err { $_[0]->bad; print STDERR "$PROG: $_[1]\n"; }
sub unk { $_[0]->err("unknown option `-$_[0]->{opt}'"); }

###--------------------------------------------------------------------------
### Parameter objects.

package Odin::Param;
sub dflt { return $_[0]->{dflt}; }

package Odin::Param::Int;
@ISA = qw(Odin::Param);

sub new {
  my ($cls, $dflt, $min, $max) = @_;
  return bless { dflt => $dflt, min => $min, max => $max }, $cls;
}

sub check {
  my ($me, $v) = @_;
  return undef unless
    $v =~ /^[-+]?\d+$/ &&
    (!defined $me->{min} || $v >= $me->{min}) &&
    (!defined $me->{max} || $v <= $me->{max});
  return $v + 0;
}

package Odin::Param::Str;
@ISA = qw(Odin::Param);

sub new {
  my ($cls, $dflt, $rx, $minlen, $maxlen) = @_;
  return bless {
    dflt => $dflt,
    rx => defined $rx ? qr/$rx/ : qr//,
    minlen => $minlen,
    maxlen => $maxlen
  }, $cls;
}

sub check {
  my ($me, $v) = @_;
  return undef unless
    $v =~ /$me->{rx}/ &&
    (!defined $me->{minlen} || length $v >= $me->{minlen}) &&
    (!defined $me->{maxlen} || length $v <= $me->{maxlen});
  return $v . "";
}

###--------------------------------------------------------------------------
### Name generators.

package Odin::Gen;

use Scalar::Util qw(blessed);

sub random {
  my ($me, $lim) = @_;

  defined $me->{rand}
    or open $me->{rand}, "/dev/urandom"
    or die "open random: $!";

  my $nb = 1; my $max = 255;
  while ($lim > $max) { $nb++; $max = ($max << 8) | 255; }
  my $thresh = $max - ($max%$lim);

  for (;;) {
    sysread $me->{rand}, my $b, $nb
      or die "read random: $!";
    my $r = 0;
    for (my $i = 0; $i < $nb; $i++)
      { $r = ($r << 255) | ord substr $b, $i, 1; }
    return $r%$lim if $r < $thresh;
  }
}

sub new {
  my ($cls, $dom, $param) = @_;
  my $pkg = \%::;
  for my $p (split /::/, $cls) { $pkg = \%{$pkg->{"${p}::"}}; }

  my $label = ${$pkg->{LABEL}};
  my $plist = \@{$pkg->{PARAM}};
  my $gtmpl = $GENPARAM{$label};
  my $dtmpl = $MAILDOM_POLICY{$dom}{$label};
  my %pp = ();

  for my $p (@$plist) {
    $pp->{$p} = 1;
    my $t = $dtmpl->{$p} // $gtmpl->{$p};
    if (blessed $t && $t->isa("Odin::Param")) {
      if (!exists $param->{$p}) { $param->{$p} = $t->dflt; }
      else {
	my $v = $t->check($param->{$p});
	Odin::fail "bad value `$param->{$p}' for $label parameter `$p'"
	  unless defined $v;
	$param->{$p} = $v;
      }
    } else {
      if (exists $param->{$p})
	{ Odin::fail "not allowed to set $label parameter `$p'"; }
      else
	{ $param->{$p} = $t; }
    }
  }
  for my $p (keys %$param) {
    if (!$pp->{$p}) { Odin::fail "unknown $label parameter `$p'"; }
  }

  my $me = bless { %$param }, $cls;
  $me->{rand} = undef;
  return $me;
}

package Odin::Gen::Chars;
@ISA = qw(Odin::Gen);

$LABEL = 'chars';
@PARAM = qw(ichars mchars echars len);

$GENMAP{chars} = "Odin::Gen::Chars";
$GENPARAM{chars} = {
  ichars => Odin::Param::Str->new($ALPHA, $SAFECH, 1, 255),
  mchars => Odin::Param::Str->new($ALPHA . $NUM, $SAFECH, 2, 255),
  echars => Odin::Param::Str->new($ALPHA . $NUM, $SAFECH, 2, 255),
  len => Odin::Param::Int->new(6, 2, 16)
};

sub _pick {
  my ($me, $chars) = @_;
  return substr $chars, $me->random(length $chars), 1;
}

sub gen {
  my ($me) = @_;

  my $n = $me->{len};

  my $s = "";
  if ($n) { $s .= $me->_pick($me->{ichars}); $n--; }
  while ($n > 1) { $s .= $me->_pick($me->{mchars}); $n--; }
  if ($n) { $s .= $me->_pick($me->{echars}); $n--; }
  if ($n) { die "INTERNAL can't count"; }
  return $s;
}

package Odin::Gen::Words;
@ISA = qw(Odin::Gen);

$LABEL = 'words';
@PARAM = qw(wordlist delim nwords);

$GENMAP{words} = "Odin::Gen::Words";
$GENPARAM{words} = {
  wordlist => "etc/words",
  delim => Odin::Param::Str->new(".", qr/^[-_.+]*$/, 1, 1),
  nwords => Odin::Param::Int->new(3, 2, 16)
};

sub gen {
  my ($me) = @_;
  my @w = ();

  if (!exists $me->{words}) {
    open my $f, $me->{wordlist} or die "open wordlist: $!";
    $me->{words} = [grep chomp, <$f>];
    close $f or die "close/read wordlist: $!";
  }

  for (my $i = 0; $i < $me->{nwords}; $i++)
    { push @w, $me->{words}[$me->random(scalar @{$me->{words}})]; }
  return join $me->{delim}, @w;
}

###--------------------------------------------------------------------------
### Final configuration.

package Odin;

require "config.pl";

($SCHEME, $DOMAIN, $BASEPATH) = $BASEURL =~ m!^([^:]+)://([^/]+)(/.*)$!;
merge_hash %COOKIE_DEFAULTS, -domain => $DOMAIN, -path => $BASEPATH;
merge_hash %COOKIE_DEFAULTS, -secure => undef if $SCHEME eq "https";

$MAIL_QUALDOM //= $MAIL_DEFDOMAIN;

$SHORTURL = "$BASEURL$SHORTURL_PATH";
$PASTEBIN = "$BASEURL$PASTEBIN_PATH";

###----- That's all, folks --------------------------------------------------

1;