/KMS/libmikey-sakke/selex/mskms/server/mskms.pl

#!/usr/bin/site_perl/hypnotoad -f

use lib 'lib';

use File::Spec;
BEGIN
{
   if ($ENV{'PAR_TEMP'})
   {
      my $dir = File::Spec->catfile ($ENV{'PAR_TEMP'}, 'inc');
      chdir $dir or die "chdir: '$dir': $!";
   }
}

use Mojolicious::Lite;
use IO::Socket::SSL;

use DBI;
use Digest::SHA1 qw/sha1_base64/;
use Data::Dumper;

# https://bitbucket.org/abutcher/crypt-ecdsa-gmpz.git
use Crypt::ECDSA;
use Crypt::ECDSA::Util qw/bint hex_bint as_hex/;
use Math::GMPz qw/Rmpz_invert/;

# for convenience of demonstration a
# SIP registrar and proxy is provided
use Net::SIP;

use Carp qw/croak/;

sub dbconnect { DBI->connect("dbi:SQLite:mskms.db"); }


say "Initializing signing elliptic curve...";

my $sign_ec = Crypt::ECDSA::Curve::Prime->new(standard => 'ECP-256');

say "sign_ec->Gx:  ".as_hex($sign_ec->{G_x});
say "sign_ec->Gy:  ".as_hex($sign_ec->{G_y});
say "sign_ec->b:   ".as_hex($sign_ec->{b});
say "sign_ec->q:   ".as_hex($sign_ec->{q});


my %sakke_param_sets;
%sakke_param_sets =
(
   1 => { ## RFC 6509

         n    =>  128,

         p    =>  hex_bint (join '',
                  qw/997ABB1F 0A563FDA 65C61198 DAD0657A
                     416C0CE1 9CB48261 BE9AE358 B3E01A2E
                     F40AAB27 E2FC0F1B 228730D5 31A59CB0
                     E791B39F F7C88A19 356D27F4 A666A6D0
                     E26C6487 326B4CD4 512AC5CD 65681CE1
                     B6AFF4A8 31852A82 A7CF3C52 1C3C09AA
                     9F94D6AF 56971F1F FCE3E823 89857DB0
                     80C5DF10 AC7ACE87 666D807A FEA85FEB/),

         q    =>  hex_bint (join '',
                  qw/265EAEC7 C2958FF6 99718466 36B4195E
                     905B0338 672D2098 6FA6B8D6 2CF8068B
                     BD02AAC9 F8BF03C6 C8A1CC35 4C69672C
                     39E46CE7 FDF22286 4D5B49FD 2999A9B4
                     389B1921 CC9AD335 144AB173 595A0738
                     6DABFD2A 0C614AA0 A9F3CF14 870F026A
                     A7E535AB D5A5C7C7 FF38FA08 E2615F6C
                     203177C4 2B1EB3A1 D99B601E BFAA17FB/),

         Px   =>  hex_bint (join '',
                  qw/53FC09EE 332C29AD 0A799005 3ED9B52A
                     2B1A2FD6 0AEC69C6 98B2F204 B6FF7CBF
                     B5EDB6C0 F6CE2308 AB10DB90 30B09E10
                     43D5F22C DB9DFA55 718BD9E7 406CE890
                     9760AF76 5DD5BCCB 337C8654 8B72F2E1
                     A702C339 7A60DE74 A7C1514D BA66910D
                     D5CFB4CC 80728D87 EE9163A5 B63F73EC
                     80EC46C4 967E0979 880DC8AB EAE63895/),

         Py   =>  hex_bint (join '',
                  qw/0A824906 3F6009F1 F9F1F053 3634A135
                     D3E82016 02990696 3D778D82 1E141178
                     F5EA69F4 654EC2B9 E7F7F5E5 F0DE55F6
                     6B598CCF 9A140B2E 416CFF0C A9E032B9
                     70DAE117 AD547C6C CAD696B5 B7652FE0
                     AC6F1E80 164AA989 492D979F C5A4D5F2
                     13515AD7 E9CB99A9 80BDAD5A D5BB4636
                     ADB9B570 6A67DCDE 75573FD7 1BEF16D7/),

         g    =>  hex_bint (join '',
                  qw/66FC2A43 2B6EA392 148F1586 7D623068
                     C6A87BD1 FB94C41E 27FABE65 8E015A87
                     371E9474 4C96FEDA 449AE956 3F8BC446
                     CBFDA85D 5D00EF57 7072DA8F 541721BE
                     EE0FAED1 828EAB90 B99DFB01 38C78433
                     55DF0460 B4A9FD74 B4F1A32B CAFA1FFA
                     D682C033 A7942BCC E3720F20 B9B7B040
                     3C8CAE87 B7A0042A CDE0FAB3 6461EA46/),

         sha => 256, # sha-id
         hash_len => 32, # octets
   }
);

while (my ($id, $set) = each(%sakke_param_sets))
{
   $set->{E} = Crypt::ECDSA::Curve::Prime->new
   (
      standard => 'generic_prime',
      p => $set->{p},
      a => -3,
      b => 0,
   );
   $set->{P} = Crypt::ECDSA::Point->new
   (
      curve => $set->{E},
      X => $set->{Px},
      Y => $set->{Py},
   );
   die "P is not on curve for parameter set $id"
      if not $set->{P}->is_on_curve();
}

# hardcode to param set 1 (6509)
my $sakke_param_set_id = 1;
my $sakke_param_set = $sakke_param_sets{$sakke_param_set_id};


# cache public data
my $this_server_id;
my $Z;
my $KPAK;


if (! -r "mskms.db")
{
   say "Creating database...";

   my $dbh = dbconnect();
   my $sql = <<ENDSQL;

   ------------ MIKEY-SAKKE Data ------------

   CREATE TABLE server_private_data
   (
      kmsSecretAuthenticationKey BLOB,     -- 6507 integer KSAK.
      kmsMasterSecret BLOB                 -- 6508 integer z.
   );
   CREATE TABLE server_public_data
   (
      id INTEGER PRIMARY KEY,              -- internal key per community.
      kmsIdentifier VARCHAR(255) NOT NULL, -- 6509 arbitrary string.
      kmsPublicAuthenticationKey BLOB,     -- 6507 ecpoint KPAK.
      kmsPublicKey BLOB,                   -- 6508 ecpoint Z.
      sakkeParameterSetIndex INTEGER       -- SAKKE parameter set being used.
   );
   CREATE TABLE identities                 -- could identify a device,
   (                                       -- access-point/user-agent or user.
      userIdentifier BLOB                  -- user identifier: in 6709 this
         PRIMARY KEY,                      -- includes a datestamp;
      accountId INTEGER                    -- reference to login account
         REFERENCES accounts(id),          -- that created this data.
      userPublicValidationToken BLOB,      -- 6507 ecpoint PVT
      userSecretSigningKey BLOB,           -- 6507 integer SSK
      receiverSecretKey BLOB               -- 6508 ecpoint RSK
   );
   CREATE TABLE account_uris
   (
      id INTEGER REFERENCES accounts(id),  -- the account
      uri VARCHAR(240) PRIMARY KEY         -- a URI registered to the account
   );
   CREATE INDEX AccountURIs ON account_uris(id);
   CREATE INDEX ServerID ON server_public_data(kmsIdentifier);

   ------------ User Authentication ------------

   CREATE TABLE this_server
   (
      whoami INTEGER                       -- ref to public data
         REFERENCES server_public_data(id),
      dbVersion INTEGER DEFAULT 1          -- db version for migration
   );
   CREATE TABLE accounts
   (
      id INTEGER PRIMARY KEY,              -- internal key.
      name VARCHAR(64) UNIQUE NOT NULL,    -- user name for https access.
      sha1 CHAR(20),                       -- SHA-1 of user's password.
      admin BOOLEAN                        -- whether user has access
                                           -- to administrative functions
   );
   CREATE TABLE auth_sessions
   (
      sid VARCHAR(255) PRIMARY KEY,        -- auth session key
      accountId INTEGER                    -- user authenticated
         REFERENCES accounts(id),
      lastActivity TIMESTAMP               -- last auth activity 
         DEFAULT CURRENT_TIMESTAMP,
      clientData VARCHAR(255)              -- user-agent and ip address
   );
   CREATE INDEX AccountIdentities ON identities(accountId);
   CREATE INDEX AccountSessions ON auth_sessions(accountId);
ENDSQL

   for my $stm (split /(?<=\));/, $sql)
   {
      $dbh->do($stm) or die $dbh->errstr . " in " . $stm;
   }

   print "Creating default users...  ";

   for (['bob', 'bobpass'],
        ['jim', 'jimpass'],
        ['admin', 'admin', 1])
   {
      my ($name, $pass, $admin) = @$_;
      $dbh->do(<<ENDSQL,undef,($name, sha1_base64($pass), !!$admin)) or die $dbh->errstr;
         INSERT INTO accounts (name, sha1, admin) VALUES (?, ?, ?)
ENDSQL
   }

   say "Done.  Login as admin:admin to reconfigure.";

   my $initial_identity = 'unspecified.domain.co.uk';

   $dbh->do("INSERT INTO server_public_data (kmsIdentifier, sakkeParameterSetIndex) ".
            "VALUES ('$initial_identity', $sakke_param_set_id)") or die $dbh->errstr;

   $this_server_id = scalar $dbh->selectrow_array(
            "SELECT id FROM server_public_data ".
            "WHERE kmsIdentifier = '$initial_identity'") or die $dbh->errstr;

   $dbh->do("INSERT INTO this_server (whoami) VALUES ($this_server_id)") or die $dbh->errstr;

   say "Configured initial KMS identity as '$initial_identity'.  Login as an administrator to reconfigure.";

   # Set-up initial MIKEY-SAKKE data
   community_rekey($dbh);

   $dbh->disconnect();
}
else # cache public data
{
   refresh_public_cache();
}


sub refresh_public_cache
{
   my $dbh = dbconnect();

   $this_server_id = scalar $dbh->selectrow_array('SELECT whoami FROM this_server') or die $dbh->errstr;
   $KPAK = Crypt::ECDSA::Point->new(
            curve => $sign_ec,
            octet => pack('H*',$dbh->selectrow_array(
                        "SELECT kmsPublicAuthenticationKey ".
                          "FROM server_public_data ".
                         "WHERE id = $this_server_id")));
   $Z = hex_bint $dbh->selectrow_array("SELECT kmsPublicKey ".
                                         "FROM server_public_data ".
                                        "WHERE id = $this_server_id");
   $sakke_param_set_id = $dbh->selectrow_array("SELECT sakkeParameterSetIndex ".
                                                 "FROM server_public_data ".
                                                "WHERE id = $this_server_id");
   $sakke_param_set = $sakke_param_sets{$sakke_param_set_id};
   $dbh->disconnect();
}


sub bitcount
{
   my $x = shift;
   my $rc = 0;
   while ($x != 0)
   {
      ++$rc;
      $x >>= 1;
   }
   return $rc;
}


sub change_server_name
{
   my $dbh = app->dbh;
   my $newname = shift;

   $dbh->do(<<ENDSQL,undef,($newname)) or croak $dbh->errstr;
      UPDATE server_public_data SET kmsIdentifier = ?
       WHERE id = $this_server_id
ENDSQL
}


sub is_admin ($)
{
   my $accountId_or_mojo = shift;
   $accountId_or_mojo = get_account_from_session($accountId_or_mojo) if ref $accountId_or_mojo;
   return scalar app->dbh->selectrow_array(
      "SELECT admin FROM accounts WHERE id = $accountId_or_mojo");
}

sub json_error
{
   ({error => shift}, status => shift // 500);
}


sub add_user
{
   my $dbh = app->dbh;
   my $accountId = shift;
   
   return json_error "Must be an administrator to add users.", 403 if not is_admin $accountId;

   my $name = shift;
   my $pass = shift;
   my $admin = 0;
   
   $dbh->do(<<ENDSQL,undef,($name, sha1_base64($pass), !!$admin)) or return json_error $dbh->errstr;
     INSERT INTO accounts (name, sha1, admin) VALUES (?, ?, ?)
ENDSQL

   ({success => "User '$name' added."}, status => 201)
}

sub add_account_uri
{
   my $dbh = app->dbh;
   my $accountId = shift;
   my $uri = shift;
   
   return json_error "No 'uri' parameter specified", 400 if not $uri;

   $dbh->do(<<ENDSQL,undef,($accountId, $uri)) or return json_error $dbh->errstr;
      INSERT INTO account_uris (id, uri) VALUES (?, ?)
ENDSQL

   ({success => "URI '$uri' added to account '$accountId'"}, status => 201)
}

sub update_account_uri
{
   my $dbh = app->dbh;
   my ($accountId, $from_uri, $to_uri) = @_;

   return json_error "No 'uri' query parameter specified", 400 if not $from_uri;
   return json_error "No 'uri' field specified in body", 400 if not $to_uri;

   return {success => "No change requested."};

   my $updated = $dbh->do(<<ENDSQL,undef,($to_uri, $accountId, $from_uri));
      UPDATE account_uris SET uri = ? WHERE id = ? AND uri = ?
ENDSQL
   return json_error $dbh->errstr if not $updated;
   return json_error "URI '$from_uri' not associated with account '$accountId'", 404 if not 0+$updated;

   {success => "URI '$from_uri' updated to '$to_uri' for account '$accountId'"}
}

sub remove_account_uri
{
   my $dbh = app->dbh;
   my $accountId = shift;
   my $uri = shift;

   my $removed = $dbh->do(<<ENDSQL,undef,($accountId, $uri));
      DELETE FROM account_uris
       WHERE id = ?
         AND uri = ?
ENDSQL
   return json_error $dbh->errstr if not $removed;
   return json_error "URI '$uri' not associated with account '$accountId'", 404 if not 0+$removed;
   {success => "URI '$uri' removed from account '$accountId'"}
}



sub get_KSAK
{
   return hex_bint app->dbh->selectrow_array(
      "SELECT kmsSecretAuthenticationKey FROM server_private_data");
}


sub get_master_secret
{
   return hex_bint app->dbh->selectrow_array(
      "SELECT kmsMasterSecret FROM server_private_data");
}


sub get_existing_key_material
{
   return json_error "Not implemented", 501
}


sub get_key_material
{
   my $dbh = app->dbh;
   my $accountId = shift;
   my $userIdentifier = shift;

   say "get_key_material($accountId, '".($userIdentifier//'')."')";

   return json_error "Invalid arguments", 400
      if not defined $accountId or not defined $userIdentifier;

   # get URI component for matching to user account (commencing after
   # first NUL character)
   # 
   my $uri = substr($userIdentifier, index($userIdentifier, "\0")+1);

   my $requestedAccountHolder = $dbh->selectrow_array(<<ENDSQL,undef,($uri));
      SELECT id FROM account_uris WHERE uri = ?
ENDSQL

   return json_error "The URI '$uri' is not associated with an account", 404
      if not defined $requestedAccountHolder;

   # if the requesting account is the owner of the uri then
   # return private data in addition to the public data
   #
   my $isOwner = $accountId == $requestedAccountHolder;

   say "Requesing user: $accountId; Details requested for: $uri: (ID:$userIdentifier) (account:$requestedAccountHolder)";

   my $private;
   my $error;

   if ($isOwner)
   {
      $private = $dbh->selectrow_hashref(<<ENDSQL,undef,($userIdentifier));
         SELECT userSecretSigningKey,
                receiverSecretKey
           FROM identities
          WHERE userIdentifier = ?
ENDSQL

      if (not defined($private))
      {
         # ===== Compute signing keys. =====================

         my $AuthKey = Crypt::ECDSA::Key->new(
               curve => $sign_ec,
               X => $sign_ec->{G_x},
               Y => $sign_ec->{G_y},
             # d => bint 0x23456,  ## XXX:TEST RFC6507 example override
            );

         my $PVT = $AuthKey->G * $AuthKey->secret;

         my $hash = new Digest::SHA($sakke_param_set->{sha});

         # XXX:TEST vector from 6507
         # $userIdentifier = "2011-02\0tel:+447700900123\0";

         say "G    := " . unpack('H*', $AuthKey->G->to_octet);
         say "KPAK := " . unpack('H*', $KPAK->to_octet);
         say "ID   := " . $userIdentifier;
         say "PVT  := " . unpack('H*', $PVT->to_octet);

         $hash->add($AuthKey->G->to_octet);
         $hash->add($KPAK->to_octet);
         $hash->add($userIdentifier);
         $hash->add($PVT->to_octet);

         my $HS = hex_bint $hash->hexdigest;

         my $KSAK = get_KSAK;

         my $SSK = ($KSAK + $HS * $AuthKey->secret) % $AuthKey->G->order; 

         my $SSK_hex = substr(as_hex($SSK),2);
         my $PVT_hex = unpack('H*', $PVT->to_octet);

         say "$userIdentifier: PVT = " . $PVT_hex;
         say "$userIdentifier: HS  = " . as_hex($HS);
         say "$userIdentifier: SSK = " . $SSK_hex;
         
         # ===== Compute receiver secret. =====================

         my $z = get_master_secret;

         my $a = hex_bint unpack 'H*', $userIdentifier;
         my $RSK = $a + $z;
                   Rmpz_invert($RSK, $RSK, $sakke_param_set->{q});
            $RSK = $sakke_param_set->{P} * $RSK;
         my $RSK_hex = unpack('H*', $RSK->to_octet);

         say "$userIdentifier: RSK = " . $RSK_hex;


         $dbh->do(<<ENDSQL,undef,($userIdentifier, $accountId, $PVT_hex, $SSK_hex, $RSK_hex));
            INSERT INTO identities (userIdentifier,
                                    accountId,
                                    userPublicValidationToken,
                                    userSecretSigningKey,
                                    receiverSecretKey)
            VALUES (?, ?, ?, ?, ?)
ENDSQL
         
         $error = $dbh->errstr;

         $private =
         {
            userSecretSigningKey => $SSK_hex,
            receiverSecretKey => $RSK_hex,
         }
         if not $error;
      }
   }

   my $public = $dbh->selectrow_hashref(<<ENDSQL,undef,($userIdentifier));
      SELECT identities.userPublicValidationToken
        FROM identities
       WHERE userIdentifier = ?
ENDSQL

   my $community = $dbh->selectall_arrayref(<<ENDSQL, {Slice => {}});
      SELECT kmsIdentifier,
             kmsPublicAuthenticationKey,
             kmsPublicKey,
             sakkeParameterSetIndex 
        FROM server_public_data
ENDSQL

   my %result;

   $result{error} = $error if $error;
   $result{public} = $public if $public;
   $result{community} = $community if $community;
   $result{private} = $private if $private;

   return \%result;
}


sub community_rekey
{
   my $dbh = shift;

   say "Community rekey: Generating new MIKEY-SAKKE secrets and corresponding public data...";

   my $AuthKey = Crypt::ECDSA::Key->new(
         curve => $sign_ec,
         X => $sign_ec->{G_x},
         Y => $sign_ec->{G_y},
       # d => bint 0x12345,  ## XXX:TEST RFC6507 example override
      );

   my $KSAK = $AuthKey->secret;
   $KPAK = $AuthKey->Q; # cache in global

   my $q = $sakke_param_set->{q};

   my $z;
   {
      my $qw = bitcount($q-1);
      say $qw;
      for (;;) # probably unnecessary
      {
         my $zr = Crypt::ECDSA::Util::random_bits($qw);
         $z = $zr % $q;
         last # if $zr != $z;
      }
   } 

   # XXX:TEST overwrite random with RFC6508 example
   # $z = hex_bint join '', qw/AFF429D3 5F84B110 D094803B 3595A6E2 998BC99F/;

   # cache in global
   $Z = $sakke_param_set->{P} * $z;

   open KEYLOG, ">>keys.log";
   for my $file (\*STDERR, \*KEYLOG) {
   say $file "Authentication Keys...";

   say $file "G:         ".unpack('H*', $AuthKey->G->to_octet);
   say $file "KSAK:      ".as_hex($KSAK);
   say $file "KPAK:      ".unpack('H*', $KPAK->to_octet);
   say $file "CHECK:     ".unpack('H*', ($AuthKey->G * $AuthKey->secret)->to_octet);

   say $file "SAKKE Keys...";
  
   say $file "n:         ".$sakke_param_set->{n};
   say $file "p:         ".as_hex($sakke_param_set->{p});
   say $file "q:         ".as_hex($sakke_param_set->{q});
   say $file "Px:        ".as_hex($sakke_param_set->{P}->X);
   say $file "Py:        ".as_hex($sakke_param_set->{P}->Y);
   say $file "P->order:  ".as_hex($sakke_param_set->{P}->order);
   say $file "g:         ".as_hex($sakke_param_set->{g});
   say $file "sha:       ".$sakke_param_set->{sha};
   say $file "hash_len:  ".$sakke_param_set->{hash_len};
   say $file "z:         ".as_hex($z);
   say $file "Z:         ".unpack('H*', $Z->to_octet);
   }
   close KEYLOG;

   $dbh->do('DELETE FROM identities');
   $dbh->do('DELETE FROM server_private_data');
   $dbh->do(<<ENDSQL,undef,(substr(as_hex($KSAK),2), substr(as_hex($z),2)));
      INSERT INTO server_private_data VALUES (?, ?);
ENDSQL

   $dbh->do(<<ENDSQL,undef,(unpack('H*', $KPAK->to_octet), unpack('H*', $Z->to_octet)))
      UPDATE server_public_data
         SET kmsPublicAuthenticationKey = ?,
             kmsPublicKey = ?
       WHERE id = $this_server_id
ENDSQL
}


sub get_account_from_session
{
   my $mojo = shift;
   my $sid = $mojo->session('sid');
   return scalar app->dbh->selectrow_array(<<ENDSQL,undef,($sid));
      SELECT accountId FROM auth_sessions WHERE sid = ?
ENDSQL
}

sub resolve_to_account
{
   my $name_or_uid = shift;
   return scalar app->dbh->selectrow_array(<<ENDSQL,undef,($name_or_uid));
      SELECT id FROM accounts WHERE name = :1 OR id = :1
ENDSQL
}

# set mojo default listen address if not running under hypnotoad (i.e.
# running on windows or standalone)
$ENV{MOJO_LISTEN} = 'https://*:7070' if not $ENV{MOJO_LISTEN};

app->attr(dbh => \&dbconnect);
app->config(hypnotoad => {listen => ['https://*:7070']});

plugin 'auth_helper';
plugin 'basic_auth';

# set to 1 to terminate the SIP thread
my $sip_term = 0;

my $use_net_interface = $^O !~ /MSWin/;

my $get_local_ip_addresses;
sub get_local_ip_addresses { $get_local_ip_addresses->(@_); }

if ($use_net_interface) # posix-ish
{
   eval "use Net::Interface qw/inet_ntoa/";

   $get_local_ip_addresses = sub
   {
      my @ips = ();
      my $opts = shift;
      my $exclude_loopback = not ($opts && $opts->{include_loopback});
      for my $if (Net::Interface->interfaces)
      {
         if (my $raw_addr = $if->address())
         {
            my $addr = inet_ntoa($raw_addr);
            next if $exclude_loopback and ($addr =~ m/^127/ or $addr eq '::1');
            push @ips, $addr;
         }
      }
      return @ips;
   }
}
else # use gethostbyname
{
   $get_local_ip_addresses = sub
   {
      my @ips = ();
      my $opts = shift;

      my ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname('localhost');

      if ($opts && $opts->{include_loopback})
      {
         foreach my $addr (@addrs)
         {
            push @ips, join('.', unpack('C4', $addr));
         }
      }
      ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($name);
      foreach my $addr (@addrs)
      {
         unshift @ips, join('.', unpack('C4', $addr));
      }
      return @ips;
   }
}

sub render_json_error
{
   my $mojo = shift;
   $mojo->render_json(json_error @_);
}

sub render_page
{
   my $mojo = shift;
   my $page = shift;
   my $accountId = get_account_from_session($mojo);
   my ($user, $admin) = app->dbh->selectrow_array(
      "SELECT name, admin FROM accounts WHERE id = $accountId");
   return $mojo->render($page, (uid => $accountId, user => $user, admin => $admin));
}

# under '/' => sub
# {
#    my $mojo = shift;
#    say $mojo->req->method . ' ' . $mojo->req->url;
#    print Dumper($mojo->session);
# };

group
{
   under '/secure' => sub
   {
      my $mojo = shift;
      return 1 if $mojo->check_auth()->{authorized};

      # support direct access via basic-auth for /key subpath
      if ((my $sub = $mojo->req->url->path->parts->[1]))
      {
         if ($sub eq 'key')
         {
            return $mojo->basic_auth('mikey-sakke-kms' => sub
               {
                  if (not $mojo->login(@_)->{authorized})
                  {
                     $mojo->res->headers->www_authenticate("Basic realm=mikey-sakke-kms");
                     $mojo->res->code(401);
                     $mojo->rendered;
                     return 0;
                  }
                  return 1;
               });
         }
         elsif ($sub eq '1') # REST API 1 supports session creation via GET /secure/1/session
         {
            if ($mojo->req->url->path->parts->[2] eq 'session')
            {
               return 1 if $mojo->req->method eq 'GET';
               render_json_error $mojo, "Not authenticated, no session to delete.", 401;
               return 0;
            }
         }
      }
      $mojo->session('post-login-url' => $mojo->req->url->path->to_abs_string);
      $mojo->flash(error => "401:Authentication required.");
      $mojo->redirect_to('/login'); # re-direct to here when not logged in.
      return 0;
   };

   get '/' => sub
   {
      render_page shift, 'main';
   };

   group { under '1'; ## version 1 REST API group

   get '/session' => sub
   {
      my $mojo = shift;
      my $res = $mojo->login($mojo->param('username'), $mojo->param('password'));
      $mojo->res->code(401) if not $res->{authorized};
      return $mojo->render_json($res);
   };

   del '/session' => sub
   {
      my $mojo = shift;
      $mojo->logout($mojo->param('all-sessions'));
      return $mojo->rendered(205);
   };

   any [qw(POST GET)] => '/rekey' => sub
   {
      my $mojo = shift;
      return render_json_error $mojo, "Must be an administrator to purge keys.", 403 if not is_admin $mojo;
      community_rekey app->dbh;
      return $mojo->render_json({success => 'All user keys revoked and community keys recreated.'})
   };

   post '/purge/:sakkeid' => sub
   {
      my $mojo = shift;
      my $sakkeid = $mojo->param('sakkeid');
      my $auth = $mojo->req->json('/auth');
      my $identity = app->dbh->selectrow_array(<<ENDSQL,undef,($sakkeid));
         SELECT userSecretSigningKey,
                receiverSecretKey
           FROM identities
          WHERE userIdentifier = ?
ENDSQL
      return render_json_error $mojo, "No such identity.", 404 if not @$identity;

      my $ssk = hex_bint $identity->[0];
      my $rsk = hex_bint $identity->[1];
      my $xor = (hex_bint $auth) % $ssk;

      say "Purge '$sakkeid': SSK:  $identity->[0]";
      say "Purge '$sakkeid': RSK:  $identity->[1]";
      say "Purge '$sakkeid': AUTH: $auth";
      say "Purge '$sakkeid': XOR:  ".as_hex($xor);

      return render_json_error $mojo, "Refusing to purge keys for '$sakkeid', authentication failed..", 403 if $xor ne $rsk;

      app->dbh->do(<<ENDSQL,undef,($sakkeid));
         DELETE FROM identities
          WHERE userIdentifier = ?
ENDSQL
      say "Purged '$sakkeid' keys.  User agent deemed them invalid."; 

      open KEYLOG, ">>keys.log";
      say KEYLOG "-----Invalid keys for $sakkeid------";
      say KEYLOG "SSK:  $identity->[0]";
      say KEYLOG "RSK:  $identity->[1]";
      say KEYLOG "AUTH: $auth";
      say KEYLOG "XOR:  ".as_hex($xor);
      close KEYLOG;

      return $mojo->render_json({success => "Keys revoked for '$sakkeid'."})
   };

   get '/user' => sub
   {
      my $mojo = shift;
      my $accountId = get_account_from_session($mojo);
      my $where_clause = '';
      $where_clause = "WHERE id = $accountId" if $mojo->param('restrict');
      my $users = app->dbh->selectall_arrayref(
         "SELECT id, name FROM accounts $where_clause", {Slice => {}});
      return $mojo->render_json($users);
   };

   post '/user' => sub
   {
      my $mojo = shift;
      my $accountId = get_account_from_session($mojo);
      my $name = $mojo->req->json('/name');
      my $pass = $mojo->req->json('/pass');
      return render_json_error $mojo, "Both 'user' and 'pass' must be provided and non-empty.", 400
         if not $name or not $pass;
      return $mojo->render_json(add_user($accountId, $name, $pass));
   };

   get '/user/:name_or_uid/keys' => sub
   {
      my $mojo = shift;
      my $requestingAccountId = get_account_from_session($mojo);
      my $subjectAccountId = resolve_to_account($mojo->param('name_or_uid'));
      return render_json_error $mojo, "Only the account owner or an administrator may enumerate key material.", 403
         if $subjectAccountId ne $requestingAccountId and not is_admin $requestingAccountId;
      return $mojo->render_json(get_existing_key_material($requestingAccountId, $subjectAccountId));
   };

   get '/keys' => sub
   {
      my $mojo = shift;
      my $accountId = get_account_from_session($mojo);
      my $userIdentifier = $mojo->param('id');
      return $mojo->render_json(get_key_material($accountId, $userIdentifier));
   };

   any [qw(POST GET PUT DELETE)] => '/user/:name_or_uid/uri' => sub
   {
      my $mojo = shift;
      my $name_or_uid = $mojo->param('name_or_uid');
      my $subjectId = resolve_to_account($name_or_uid);

      return render_json_error $mojo, "No such account '$name_or_uid'", 404
         if not defined $subjectId;

      my $method = $mojo->req->method;

      if ($method eq 'GET')
      {
         my $uris = app->dbh->selectall_arrayref(
            "SELECT uri FROM account_uris WHERE id = $subjectId", {Slice => {}}) ;
         return $mojo->render_json($uris);
      }

      my $accountId = get_account_from_session($mojo);

      return render_json_error $mojo, "Only the account owner or an administrator may add manage URIs.", 403
         if $subjectId ne $accountId and not is_admin $accountId;

      my $body_uri = $mojo->req->json('/uri');
      my $query_uri = $mojo->req->param('uri');

      return $mojo->render_json(add_account_uri $subjectId, $body_uri) if $method eq 'POST';
      return $mojo->render_json(update_account_uri $subjectId, $query_uri, $body_uri) if $method eq 'PUT';
      return $mojo->render_json(remove_account_uri $subjectId, $query_uri) if $method eq 'DELETE';
   };

   }; # version 1 REST API group

   # backward compatibility for previous clients

   get '/key' => sub # FIXME: this duplicates '1/keys' rather than redirecting in order to avoid 302 redirect response; ideally want to reuse (or alias)
   {
      my $mojo = shift;
      my $accountId = get_account_from_session($mojo);
      my $userIdentifier = $mojo->param('id');
      return $mojo->render_json(get_key_material($accountId, $userIdentifier));
   };
};

get '/login' => sub
{
   my $mojo = shift;
   my $error = $mojo->flash('error');
   if ($error and $error =~ m/^([0-9]+):(.*)$/)
   {
      $mojo->res->code($1);
      $error = $2;
   }
   $mojo->render('main', (login => 1, error => $error));
};
post '/login' => sub
{
   my $mojo = shift;

   my $user = $mojo->login($mojo->param('username'), $mojo->param('password'));

   if ($user->{authorized})
   {
      my $post_login_url = $mojo->session('post-login-url') || '/';
      delete $mojo->session->{'post-login-url'};
      return $mojo->redirect_to($post_login_url);
   }

   $mojo->flash(error => "401:Failed to authenticate.");
   $mojo->redirect_to('/login');
};
any ['get', 'post'] => '/logout' => sub
{
   my $mojo = shift;
   $mojo->logout($mojo->param('all-sessions'));
   $mojo->redirect_to('/');
};

get '/ui/:page' => sub
{
   my $mojo = shift;
   render_page $mojo, $mojo->param('page');
};

get '/' => sub
{
   my $mojo = shift;
   return $mojo->redirect_to('/login') if not $mojo->check_auth()->{authorized};
   return $mojo->redirect_to('/secure/')
};

Net::SIP::Debug->level(scalar grep /^-d$/, @ARGV);

# any arguments that look like IP addresses are considered explicit bind addresses for the SIP endpoint
my @bind_addresses = grep /^[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+$/, @ARGV;

@bind_addresses = get_local_ip_addresses {include_loopback => 0}
   if not @bind_addresses;

# start SIP server
use threads;
my $sip_thread = threads->create(sub {
   my @legs = ();
   for my $addr (@bind_addresses)
   {
      push @legs, "udp:$addr:5060";
   }
   my $sip = Net::SIP::Simple->new( legs => \@legs );
   $sip->create_chain([
      $sip->create_registrar(min_expires => 30, max_expires => 3600),
      $sip->create_stateless_proxy, 
   ]);
   say 'SIP endpoint listening on UDP/5060 ('.join(', ', @bind_addresses).")";
   $sip->loop( undef, \$sip_term );
   say 'SIP endpoint stopped.';
});

# start HTTPS server
app->start;

# vim: ft=perlsql