/selex/mskms/server/mskms.pl
Perl | 994 lines | 956 code | 32 blank | 6 comment | 7 complexity | 37be9eb5561ef21e76f5a2c01973bb3c MD5 | raw file
Possible License(s): LGPL-2.1
- #!/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