#!/usr/bin/perl -T

#----------------------------------------------------------------------
# ACME client written with process isolation and minimal privileges in mind
# (account key manager)
# Copyright © 2015-2021 Guilhem Moulin <guilhem@fripost.org>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.
#----------------------------------------------------------------------

use v5.14.2;
use strict;
use warnings;

our $VERSION = '0.8.0';
my $PROTOCOL_VERSION = 1;
my $NAME = 'lacme-accountd';

use Digest::SHA 'sha256';
use Errno 'EINTR';
use File::Basename 'dirname';
use Getopt::Long qw/:config posix_default no_ignore_case gnu_getopt auto_version/;
use MIME::Base64 qw/decode_base64url encode_base64url/;
use Socket qw/PF_UNIX SOCK_STREAM SHUT_RDWR/;

use Config::Tiny ();
use JSON ();

# Clean up PATH
$ENV{PATH} = join ':', qw{/usr/bin /bin};
delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};

my ($SOCKNAME, $S, %OPTS);
$SIG{$_} = sub() { exit } foreach qw/INT TERM/; # run the END block upon SIGINT/SIGTERM


#############################################################################
# Parse and validate configuration
#
sub usage(;$$) {
    my $rv = shift // 0;
    if ($rv) {
        my $msg = shift;
        print STDERR $msg."\n" if defined $msg;
        print STDERR "Try '$NAME --help' or consult the manpage for more information.\n";
    }
    else {
        print STDERR "Usage: $NAME [--config=FILE] [--privkey=ARG] [--socket=PATH] [--quiet]\n"
                    ."Consult the manpage for more information.\n";
    }
    exit $rv;
}
usage(1) unless GetOptions(\%OPTS, qw/config=s privkey=s socket=s stdio quiet|q debug help|h/);
usage(0) if $OPTS{help};

my $LOG;
sub logmsg($@) {
    my $lvl = shift // "all";
    if (defined $LOG) {
        my $now = localtime;
        $LOG->printflush("[", $now, "] ", @_, "\n") or warn "print: $!";
    }
    unless (($lvl eq "debug" and !$OPTS{debug}) or ($lvl eq "noquiet" and $OPTS{quiet})) {
        print STDERR @_, "\n" or warn "print: $!";
    }
}
sub info(@) { logmsg(all => @_); }
sub error(@) {
    my @msg = ("Error: ", @_);
    info(@msg);
    exit 255;
}
sub panic(@) {
    my @loc = caller;
    my @msg = ("PANIC at line $loc[2] in $loc[1]");
    push @msg, ": ", @_ if @_;
    info(@msg);
    exit 255;
}

sub env_fallback($$) {
    my $v = $ENV{ shift() };
    return (defined $v and $v ne "") ? $v : shift;
}
sub spec_expand($) {
    my $str = shift;
    $str =~ s#%(.)# my $x =
          $1 eq "C" ? ($< == 0 ? "@@localstatedir@@/cache" : env_fallback(XDG_CACHE_HOME => "$ENV{HOME}/.cache"))
        : $1 eq "E" ? ($< == 0 ? "@@sysconfdir@@" : env_fallback(XDG_CONFIG_HOME => "$ENV{HOME}/.config"))
        : $1 eq "g" ? (getgrgid((split /\s/,$()[0]))[0]
        : $1 eq "G" ? $( =~ s/\s.*//r
        : $1 eq "h" ? (getpwuid($<))[7]
        : $1 eq "u" ? (getpwuid($<))[0]
        : $1 eq "U" ? $<
        : $1 eq "t" ? ($< == 0 ? "@@runstatedir@@" : $ENV{XDG_RUNTIME_DIR})
        : $1 eq "T" ? env_fallback(TMPDIR => "/tmp")
        : $1 eq "%" ? "%"
        : error("\"$str\" has unknown specifier %$1");
        error("Undefined expansion %$1 in \"$str\"") unless defined $x;
        $x;
    #ge;
    return $str;
}

do {
    my $conffile = spec_expand($OPTS{config} // "%E/lacme/$NAME.conf");

    if (defined $OPTS{config} or -e $conffile) {
        print STDERR "Using configuration file: $conffile\n" if $OPTS{debug};
        my $h = Config::Tiny::->read($conffile) or error(Config::Tiny::->errstr());
        my $h2 = delete $h->{_} // {};
        if ((my $logfile = $h2->{logfile} // "") ne "") {
            $logfile = spec_expand($logfile);
            die "Invalid log file name\n" unless $logfile =~ /\A(\p{Print}+)\z/; # untaint
            open $LOG, ">>", $1 or die "Can't open $1: $!"; # open ASAP (before config validation)
        }
        error("Invalid section(s): ".join(', ', keys %$h)) if %$h;
        my %h = map { $_ => delete $h2->{$_} } qw/privkey gpg socket logfile keyid quiet/;
        error("Unknown option(s): ".join(', ', keys %$h2)) if %$h2;
        $h{quiet} = lc $h{quiet} eq 'yes' ? 1 : 0 if defined $h{quiet};
        $OPTS{$_} //= $h{$_} foreach grep {defined $h{$_}} keys %h;
    } else {
        print STDERR "Ignoring missing configuration file at default location $conffile\n" if $OPTS{debug};
    }

    $OPTS{quiet} = 0 if $OPTS{debug};
    error("'privkey' is not specified") unless defined $OPTS{privkey};
};


#############################################################################
# Build the JSON Web Key (RFC 7517) from the account key's public parameters,
# and determine the signing method $SIGN.
#
my ($EXTRA_GREETING_STR, $JWK_STR, $SIGN);
if ($OPTS{privkey} =~ /\A(file|gpg):(\p{Print}+)\z/) {
    my ($method, $filename) = ($1, spec_expand($2));
    my ($fh, @command);
    if ($method eq 'file') {
        # generate with `openssl genpkey -algorithm RSA`
        open $fh, '<', $filename or error("Can't open $filename: $!");
    }
    elsif ($method eq 'gpg') {
        @command = split /\s+/, ($OPTS{gpg} // 'gpg --quiet');
        open $fh, '-|', @command, qw/-o - --decrypt --/, $filename or panic("fork: $!");
    }
    else {
        panic(); # impossible
    }

    my $str = do {local $/ = undef; <$fh>};
    close $fh or ($! or !@command) ?
        panic("close: $!") :
        error("$command[0] exited with value ".($? >> 8));

    require 'Crypt/OpenSSL/RSA.pm';
    my $rsa = Crypt::OpenSSL::RSA->new_private_key($str);
    undef $str;

    error("$filename: Not a private key") unless $rsa->is_private();
    error("$filename: Invalid key")       unless $rsa->check_key();
    $rsa->use_sha256_hash();

    require 'Crypt/OpenSSL/Bignum.pm';
    my ($n, $e) = $rsa->get_key_parameters(); # don't include private params!
    $_ = encode_base64url($_->to_bin()) foreach ($n, $e);

    my %extra_greeting;
    my %jwk = ( kty => 'RSA', n => $n, e => $e );
    $extra_greeting{alg} = 'RS256'; # SHA256withRSA (RFC 7518 sec. A.1)
    $SIGN = sub($) { $rsa->sign($_[0]) };

    # use of SHA-256 digest in the thumbprint is hardcoded, see RFC 8555 sec. 8.1
    $JWK_STR = JSON::->new->utf8->canonical->encode(\%jwk);
    $extra_greeting{"jwk-thumbprint"} = encode_base64url(sha256($JWK_STR));

    if ((my $kid = $OPTS{keyid} // "") ne "") {
        $extra_greeting{kid} = $kid;
        $JWK_STR = "{}";
    }
    $EXTRA_GREETING_STR = JSON::->new->encode(\%extra_greeting);
}
else {
    error("Unsupported method: $OPTS{privkey}");
}


#############################################################################
# Create the server UNIX socket and bind(2) against it.
# NOTE: We don't use the abstract namespace so we can rely on the file
# permissions to keep other users out.  (Also, OpenSSH 7.1 doesn't seem
# to support the abstract namespace.)  The downside is that we have to
# delete the file manually.
#
unless (defined $OPTS{stdio}) {
    my $sockname = spec_expand($OPTS{socket} // '%t/S.lacme');
    $sockname = $sockname =~ /\A(\p{Print}+)\z/ ? $1 : error("Invalid socket name"); # untaint

    # ensure we're the only user with write access to the parent dir
    my $dirname = dirname($sockname);
    my @stat = stat($dirname) or error("stat($dirname): $!");
    error("Insecure permissions on $dirname") if ($stat[2] & 0022) != 0;

    my $umask = umask(0177) // panic("umask: $!");

    logmsg(noquiet => "Starting lacme Account Key Manager at $sockname");
    socket(my $sock, PF_UNIX, SOCK_STREAM, 0) or panic("socket: $!");
    my $sockaddr = Socket::sockaddr_un($sockname) // panic();
    bind($sock, $sockaddr) or panic("bind: $!");

    ($SOCKNAME, $S) = ($sockname, $sock);
    listen($S, 1) or panic("listen: $!");

    umask($umask) // panic("umask: $!");
};


#############################################################################
# For each new connection, send the protocol version and the account key's
# public parameters, then sign whatever comes in
#
sub conn($$$) {
    my ($in, $out, $id) = @_;
    $out->printflush( "$PROTOCOL_VERSION OK ", $EXTRA_GREETING_STR, "\r\n",
        $JWK_STR, "\r\n" ) or warn "print: $!";

    while (defined (my $data = $in->getline())) {
        $data =~ s/\r\n\z// or panic();

        # validate JWS Signing Input from RFC 7515:
        # ASCII(BASE64URL(UTF8(JWS Protected Header)) || '.' || BASE64URL(JWS Payload))
        my ($header, $payload) = split(/\./, $data, 2);
        if (defined $header and $header =~ /\A[A-Za-z0-9\-_]+\z/) {
            $header = decode_base64url($header);
        } else {
            info("[$id] NOSIGN [malformed JWS Protected Header]");
            last;
        }
        if (defined $payload and $payload =~ /\A[A-Za-z0-9\-_]*\z/) {
            # empty payloads are valid, and used for POST-as-GET (RFC 8555 sec. 6.3)
            $payload = decode_base64url($payload);
        } else {
            info("[$id] NOSIGN [malformed JWS Payload]");
            last;
        }

        my $req = "header=base64url($header) playload=base64url($payload)";

        eval { $header = JSON::->new->decode($header); };
        if ($@ or # couldn't decode (parse error)
                # RFC 7515: not a JSON object
                !defined($header) or ref($header) ne "HASH" or
                # RFC 8555 sec. 6.2: the protected Header MUST include all these fields
                grep !defined, @$header{qw/alg nonce url/} or
                # RFC 8555 sec. 6.2: the protected header MUST include any of these fields
                !grep defined, @$header{qw/jwk kid/}) {
            info("[$id] NOSIGN [invalid JWS Protected Header] ", $req);
            last;
        }

        my $sig = eval { $SIGN->($data) };
        panic($@) if $@ or !defined $sig;
        logmsg(noquiet => "[$id] SIGNED ", $req);
        $out->printflush( encode_base64url($sig), "\r\n" ) or warn "print: $!";
    }
}

if (defined $OPTS{stdio}) {
    conn(\*STDIN, \*STDOUT, $$);
} else {
    $SIG{PIPE} = 'IGNORE'; # ignore broken pipes
    for (my $count = 0;; $count++) {
        accept(my $conn, $S) or do {
            next if $! == EINTR; # try again if accept(2) was interrupted by a signal
            panic("accept: $!");
        };
        logmsg(noquiet => "[$count] Accepted new connection");
        conn($conn, $conn, $count);
        logmsg(noquiet => "[$count] Connection terminated");
        $conn->close() or warn "close: $!";
    }
}


#############################################################################
#
END {
    if (defined $SOCKNAME and -S $SOCKNAME) {
        logmsg(debug => "Unlinking $SOCKNAME");
        unlink $SOCKNAME or info("Error: unlink($SOCKNAME): $!");
    }
    if (defined $S) {
        logmsg(noquiet => "Shutting down and closing lacme Account Key Manager");
        shutdown($S, SHUT_RDWR) or info("Error: shutdown: $!");
        close $S or info("Error: close: $!");
    }
}