#!/usr/bin/perl -T

#----------------------------------------------------------------------
# ACME client written with process isolation and minimal privileges in mind
# 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;

# Usage: client COMMAND CONFIG_FD SOCKET_FD [ARGUMENTS]
#
# fdopen(3) the file descriptor SOCKET_FD (corresponding to the
# listening lacme-accountd socket), connect(2) to it to retrieve the
# account key's public parameters and later send data to be signed by
# the master component (using the account key).
#
# CONFIG_FD is a read-only file descriptor associated with the
# configuration file at pos 0.  (This is needed since this process
# doesn't know its name and might not have read access to it.)
#
# NOTE: one needs to chdir(2) to an appropriate ACME challenge directory
# before running this program, since challenge tokens are (on purpose)
# only written to the current directory.  If COMMAND is challenge-less,
# one should chdir(2) to the root directory "/" instead.
#
# NOTE: one should run this program as an unprivileged user:group such
# as "nobody:nogroup"; bind(2)'ing to a restricted UNIX socket (for
# instance own by another user and created with umask 0177) is not a
# problem since SOCKET_FD can be bound as root prior to the execve(2).

our $VERSION = '0.8.3';
my $PROTOCOL_VERSION = 1;
my $NAME = 'lacme-client';

use Errno 'EEXIST';
use Fcntl qw/O_CREAT O_EXCL O_WRONLY/;
use Digest::SHA 'sha256';
use MIME::Base64 qw/encode_base64 encode_base64url/;

use Date::Parse ();
use LWP::UserAgent ();
use JSON ();

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

my $COMMAND = shift @ARGV // die;

# Untaint and fdopen(3) the configuration file and listening socket
(shift @ARGV // die) =~ /\A(\d+)\z/ or die;
open (my $CONFFILE, '<&=', $1+0) or die "fdopen $1: $!";
(shift @ARGV // die) =~ /\A(\d+)\z/ or die;
open (my $S, '+<&=', $1+0) or die "fdopen $1: $!";

# JSON keys need to be sorted lexicographically (for instance in the thumbprint)
sub json() { JSON::->new->utf8->canonical(); }


#############################################################################
# Read the protocol version and JSON Web Key (RFC 7517) from the
# lacme-accountd socket
#

my ($JWK, $JWK_thumbprint, $ALG, $KID);
do {
    my $greeting = $S->getline();
    die "Error: Invalid client version\n" unless defined $greeting and
        $greeting =~ /\A(\d+) OK(?: (.*))?\r\n\z/ and $1 == $PROTOCOL_VERSION;
    if (defined (my $extra = $2)) {
        my $h = eval { JSON::->new->decode($extra) };
        if ($@ or !defined $h) {
            print STDERR "Warning: Ignoring extra greeting data from accountd \"$extra\"\n";
        } else {
            print STDERR "Received extra greeting data from accountd: $extra\n" if $ENV{DEBUG};
            ($JWK_thumbprint, $ALG, $KID) = @$h{qw/jwk-thumbprint alg kid/};
        }
    }
    my $jwk_str = $S->getline() // die "Error: No JWK from lacme-accountd\n";
    $JWK = JSON::->new->decode($jwk_str);
    $JWK_thumbprint //= encode_base64url(sha256(json()->encode($JWK))); # SHA-256 is hardcoded, see RFC 8555 sec. 8.1
    $ALG //= "RS256";
};


#############################################################################
# Parse configuration (already validated by the master) and create the
# LWP::UserAgent object
#

my $CONFIG = do {
    my $conf = do { local $/ = undef; <$CONFFILE> };
    JSON::->new->decode($conf);
};
my $UA = do {
    my %args = %$CONFIG;
    my $verify = lc (delete $args{SSL_verify} // 'Yes') eq 'no' ? 0 : 1;
    my %ssl_opts = ( verify_hostname => $verify );
    $ssl_opts{$_} = $args{$_} foreach grep /^SSL_/, keys %args;
    LWP::UserAgent::->new( agent => "$NAME/$VERSION", ssl_opts => \%ssl_opts );
} // die "Can't create LWP::UserAgent object";
$UA->default_header( 'Accept-Language' => 'en' );
my $NONCE;


#############################################################################
# Send an HTTP request to the ACME server.  If $json is defined, send
# its encoding as the request content, with "application/jose+json" as
# Content-Type.
#
sub request($$;$) {
    my ($method, $uri, $json) = @_;
    print STDERR "[$$] >>> $method $uri <<<\n" if $ENV{DEBUG};

    my $req = HTTP::Request::->new($method => $uri) or die "Can't $method $uri";
    if (defined $json) {
        $req->content_type('application/jose+json');
        $req->content(json()->encode($json));
    }
    my $r = $UA->request($req) or die "Can't $method $uri";
    $NONCE //= $r->header('Replay-Nonce'); # undef $NONCE if the header is missing
    print STDERR "[$$] >>> ", $r->status_line, "\n", $r->headers->as_string("\n") if $ENV{DEBUG};
    return $r;
}

# The request's Status Line; if the Content-Type is
# application/problem+json (RFC 7807), parse the decoded content as JSON
# and add the value of the 'detail' field to the Status Line.
sub request_status_line($) {
    my $r = shift;
    my $msg = $r->status_line;
    if (!$r->is_success() and $r->content_type() eq 'application/problem+json') {
        my $content = json()->decode($r->decoded_content());
        print STDERR json()->pretty->encode($content), "\n" if $ENV{DEBUG};
        $msg .= " (".$content->{detail}.")" if defined $content->{detail};
    }
    return $msg;
}

# The request's Retry-After header (RFC 7231 sec. 7.1.3), converted to
# waiting time in seconds.
sub request_retry_after($) {
    my $r = shift;
    my $v = $r->header('Retry-After');
    if (defined $v and $v !~ /\A\d+\z/) {
        $v = Date::Parse::str2time($v);
        if (defined $v) {
            $v = $v - time;
            undef $v if $v <= 0;
        }
    }
    return $v;
}

# Parse and return the request's decoded content as JSON; or print the
# Status Line and fail if the request failed.
# If $dump is set, also pretty-print the decoded content.
sub request_json_decode($;$$) {
    my $r = shift;
    my $dump = shift || $ENV{DEBUG};
    my $fh = shift // \*STDERR;
    die request_status_line($r), "\n" unless $r->is_success();
    my $content = $r->decoded_content();

    die "Content-Type: ".$r->content_type()." is not application/json\n"
        unless $r->content_type() eq 'application/json';

    my $json = json()->decode($content);
    print $fh (-t $fh ? (json()->pretty->encode($json)."\n") : $content)
        if $dump;
    return $json;
}


#############################################################################
# JSON-encode the hash reference $payload and send it to the ACME server
# $url encapsulated it in a JSON Web Signature (JWS).  $header MUST
# contain either "jwk" (JSON Web Key) or "kid" per RFC 8555 sec. 6.2
# https://tools.ietf.org/html/rfc8555
#
sub acme2($$;$) {
    my ($url, $header, $payload) = @_;

    # Produce the JSON Web Signature: RFC 7515 section 5
    $header->{alg} = $ALG;
    $header->{nonce} = $NONCE // die "Missing nonce\n";
    $header->{url} = $url;
    my $protected = encode_base64url(json()->encode($header));
    $payload = defined $payload ? encode_base64url(json()->encode($payload)) : "";

    $S->printflush($protected, ".", $payload, "\r\n");
    my $sig = $S->getline() // die "Error: lost connection with lacme-accountd\n";
    $sig =~ s/\r\n\z// or die;
    undef $NONCE; # consume the nonce

    # Flattened JSON Serialization, RFC 7515 section 7.2.2
    request(POST => $url, {
        payload => $payload,
        protected => $protected,
        signature => $sig
    });
}

# Like above, but always use "kid"
sub acme($;$) {
    my ($url, $payload) = @_;
    die "Missing KID\n" unless defined $KID;
    acme2($url, {kid => $KID}, $payload)
}

my $SERVER_URI = $CONFIG->{server} // '@@acmeapi_server@@';

my %RES;
# Get the resource URI from the directory
sub acme_resource($%) {
    my $r = shift;
    my %payload = @_;
    my %protected;

    unless (%RES) {
        # query the ACME directory to get resources URIs
        %RES = %{ request_json_decode(request(GET => $SERVER_URI)) };
        # send a HEAD request to the newNonce resource to get a fresh nonce
        die "Unknown resource 'newNonce'\n" unless defined $RES{newNonce};
        request(HEAD => $RES{newNonce});
    }
    my $uri = $RES{$r} // die "Unknown resource '$r'\n";

    if ($r eq "newAccount" or ($r eq "revokeCert" and !defined $KID)) {
        # per RFC 8555 sec. 6.2 these requests MUST have a JWK
        print STDERR "Warning: lacme-accountd supplied an empty JWK; try removing 'keyid' ",
                     "setting from lacme-accountd.conf if the ACME resource request fails.\n"
            unless %$JWK;
        return acme2($uri, {jwk => $JWK}, \%payload);
    } else {
        # per RFC 8555 sec. 6.2 all other requests MUST have a KID
        return acme($uri, \%payload);
    }
}

# Set the key ID (registration URI)
sub set_kid(;$) {
    my $die = shift // 1;
    return if defined $KID; # already set
    my $r = acme_resource('newAccount', onlyReturnExisting => JSON::true );
    if ($r->is_success()) {
        $KID = $r->header('Location');
    } elsif ($die) {
        die request_status_line($r), "\n";
    }
}


#############################################################################
# account FLAGS [CONTACT ..]
#
if ($COMMAND eq 'account') {
    my $flags = shift @ARGV;

    my %h = ( contact => \@ARGV ) if @ARGV;
    $h{onlyReturnExisting}   = JSON::true    unless $flags & 0x01;
    $h{termsOfServiceAgreed} = JSON::true    if     $flags & 0x02;
    $h{status}               = "deactivated" if     $flags & 0x04;

    print STDERR "Requesting new registration ".(@ARGV ? ("for ".join(', ', @ARGV)) : "")."\n"
        if $flags & 0x01;

    my $r = acme_resource('newAccount', %h);
    # TODO: list account orders: https://github.com/letsencrypt/boulder/issues/3335

    print STDERR "Terms of Service: $RES{meta}->{termsOfService}\n"
        if defined $RES{meta} and defined $RES{meta}->{termsOfService};

    if ($r->is_success()) {
        $KID = $r->header('Location');
        print STDERR "Key ID: $KID\n";
        $r = acme($KID, \%h);
        request_json_decode($r, 1, \*STDOUT)
            if $r->is_success() and $r->content_type() eq 'application/json';
    }

    print STDERR request_status_line($r), "\n"
        if !$r->is_success() or $ENV{DEBUG};
    exit ($r->is_success() ? 0 : 1);
}


#############################################################################
# newOrder AUTHZ [AUTHZ ..]
#   Read the CSR (in DER format) from STDIN, print the cert (in PEM format
#   to STDOUT)
#
elsif ($COMMAND eq 'newOrder') {
    die unless @ARGV;
    my $timeout = $CONFIG->{timeout} // 30;
    my $csr = do { local $/ = undef; <STDIN> };

    set_kid();
    my @identifiers = map {{ type => 'dns', value => $_ }} @ARGV;
    my $r = acme_resource('newOrder', identifiers => \@identifiers);
    my $order = request_json_decode($r);
    my $orderurl = $r->header('Location');

    foreach (@{$order->{authorizations}}) {
        my $authz = request_json_decode(acme($_));
        next unless $authz->{status} eq 'pending';

        my $identifier = $authz->{identifier}->{value};
        my ($challenge) = grep {$_->{type} eq 'http-01'} @{$authz->{challenges} // []};
        die "Missing 'http-01' challenge in server response for '$identifier'\n"
            unless defined $challenge;

        die "Invalid challenge token ".($challenge->{token} // '')."\n"
            # ensure we don't write outside the cwd
            unless ($challenge->{token} // '') =~ /\A[A-Za-z0-9_\-]+\z/;

        my $keyAuthorization = $challenge->{token}.'.'.$JWK_thumbprint;

        # serve $keyAuthorization at http://$domain/.well-known/acme-challenge/$challenge->{token}
        if (sysopen(my $fh, $challenge->{token}, O_CREAT|O_EXCL|O_WRONLY)) {
            # note: the file is created mode 0666 minus umask restrictions
            $fh->print($keyAuthorization);
            $fh->close() or die "close: $!";
        } elsif ($! == EEXIST) {
            print STDERR "Warning: File exists: $challenge->{token}\n";
        } else {
            die "open($challenge->{token}): $!";
        }
        my $r = acme($challenge->{url}, {});
        request_json_decode($r);
    }

    # poll the order URL (to get the status of all challenges at once)
    # until the status become 'valid'; see RFC 8555 sec. 7.1.6 for the
    # the status change flow
    my $orderstr = join(', ', map {uc($_->{type}) .":". $_->{value}} @identifiers);
    my $certuri;
    for (my $i = 0, my $url = $orderurl, my $payload;;) {
        my $r = acme($url => $payload);
        my $resp = request_json_decode($r);
        if (defined (my $problem = $resp->{error})) { # problem document (RFC 7807)
            my $msg = $problem->{status};
            $msg .= " " .$problem->{title}      if defined $problem->{title};
            $msg .= " (".$problem->{detail}.")" if defined $problem->{detail};
            die $msg, "\n";
        }
        my $status = $resp->{status};
        if (!defined $status or $status eq "invalid") {
            die "Error: Invalid order $orderstr\n";
        } elsif ($status eq "pending") {
            # keep retrying
        } elsif ($status eq "ready") {
            $url = $order->{finalize};
            $payload = {csr => encode_base64url($csr)};
            # retry after moving to "processing" or "valid" state
            next;
        } elsif ($status eq "processing") {
            $url = $orderurl;
            undef $payload;
        } elsif ($status eq "valid") {
            $certuri = $resp->{certificate} //
                die "Error: Missing \"certificate\" field in \"valid\" order\n";
            last;
        } else {
            warn "Unknown order status: $status\n";
        }

        my $retry_after = request_retry_after($r) // 1;
        print STDERR "Retrying after $retry_after seconds...\n";
        $i += $retry_after;
        die "Timeout exceeded while waiting for challenges to pass ($orderstr)\n"
            if $timeout > 0 and $i >= $timeout;
        sleep $retry_after;
    }

    # poll until the cert is available
    print STDERR "Certificate URI: $certuri\n";
    for (my $i = 0;;) {
        $r = acme($certuri);
        die request_status_line($r), "\n" unless $r->is_success();
        last unless $r->code == 202; # Accepted
        my $retry_after = request_retry_after($r) // 1;
        print STDERR "Retrying after $retry_after seconds...\n";
        $i += $retry_after;
        die "Timeout exceeded while waiting for certificate\n" if $timeout > 0 and $i >= $timeout;
        sleep $retry_after;
    }
    print $r->decoded_content();
}


#############################################################################
# revokeCert
#   The certificate to revoke is passed (in DER format) to STDIN; this
#   is needed since the ACME client might not have read access to the
#   X.509 file
#
elsif ($COMMAND eq 'revokeCert') {
    die if @ARGV;
    my $der = do { local $/ = undef; <STDIN> };
    close STDIN or die "close: $!";

    # RFC 8555 sec. 6.2: send a KID if the request is signed with the
    # acccount key, otherwise send a JWK
    # We have no way to know which of the account key or certificate key
    # is used, so we try to get a KID and fallback to sending the JWK
    set_kid(0);

    my $r = acme_resource('revokeCert', certificate => encode_base64url($der));
    exit 0 if $r->is_success();
    die request_status_line($r), "\n";
}