#!/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;

our $VERSION = '0.8.0';
my $NAME = 'lacme';

use Errno 'EINTR';
use Fcntl qw/F_GETFD F_SETFD FD_CLOEXEC O_CREAT O_EXCL O_WRONLY SEEK_SET/;
use File::Basename 'dirname';
use File::Temp ();
use Getopt::Long qw/:config posix_default no_ignore_case gnu_getopt auto_version/;
use POSIX ();
use Socket 1.95 qw/AF_UNIX AF_INET AF_INET6 PF_UNIX PF_INET PF_INET6 PF_UNSPEC
                   INADDR_ANY IN6ADDR_ANY IPPROTO_IPV6
                   SOCK_STREAM SOL_SOCKET SO_REUSEADDR SHUT_RDWR/;

use Config::Tiny ();
use Date::Parse ();
use Net::SSLeay ();

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

my ($COMMAND, %OPTS, $CONFFILE, $CONFIG, @CLEANUP);
$SIG{$_} = sub() { exit 1 } 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] [--socket=PATH] [OPTIONS] COMMAND [ARGUMENT ..]\n"
                    ."Consult the manpage for more information.\n";
    }
    exit $rv;
}
usage(1) unless GetOptions(\%OPTS, qw/config=s config-certs=s@ socket=s
    register tos-agreed deactivate
    min-days=i force
    quiet|q
    debug help|h/);
usage(0) if $OPTS{help};

$COMMAND = shift(@ARGV) // usage(1, "Missing command");
$COMMAND = $COMMAND =~ /\A(account|newOrder|new-cert|revokeCert|revoke-cert)\z/ ? $1
         : usage(1, "Invalid command: $COMMAND"); # validate and untaint $COMMAND
@ARGV = map { /\A(\p{Print}*)\z/ ? $1 : die } @ARGV; # untaint @ARGV

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 "%" ? "%"
        : die "Error: \"$str\" has unknown specifier %$1\n";
        die "Error: Undefined expansion %$1 in \"$str\"\n" unless defined $x;
        $x;
    #ge;
    return $str;
}

sub set_FD_CLOEXEC($$);
my $CONFFILENAME = spec_expand($OPTS{config} // "%E/lacme/$NAME.conf");
do {
    print STDERR "Using configuration file: $CONFFILENAME\n" if $OPTS{debug};
    open $CONFFILE, '<', $CONFFILENAME or die "Can't open $CONFFILENAME: $!\n";
    my $conf = do { local $/ = undef; <$CONFFILE> };
    # don't close $CONFFILE so we can pass it to the client
    set_FD_CLOEXEC($CONFFILE, 1);

    my $h = Config::Tiny::->read_string($conf) or die Config::Tiny::->errstr()."\n";
    my $defaults = delete $h->{_} // {};
    my $accountd = defined $OPTS{socket} ? 0 : exists $h->{accountd} ? 1 : 0;
    my %valid = (
        client => {
            socket  => '%t/S.lacme',
            user    => '@@lacme_client_user@@',
            group   => '@@lacme_client_group@@',
            command => '@@libexecdir@@/lacme/client',
            # the rest is for the ACME client
            map {$_ => undef} qw/server timeout SSL_verify SSL_version SSL_cipher_list/
        },
        webserver => {
            listen                => '@@runstatedir@@/lacme-www.socket',
            'challenge-directory' => undef,
            user                  => '@@lacme_www_user@@',
            group                 => '@@lacme_www_group@@',
            command               => '@@libexecdir@@/lacme/webserver',
            iptables              => 'No'

        },
        accountd => {
            user    => '',
            group   => '',
            command => '@@bindir@@/lacme-accountd',
            config  => '',
            privkey => '',
            quiet   => 'Yes',
        }
    );
    foreach my $s (keys %valid) {
        my $h = delete $h->{$s} // {};
        my %v = map { $_ => delete $h->{$_} // $valid{$s}->{$_} } keys %{$valid{$s}};
        die "Unknown option(s) in [$s]: ".join(', ', keys %$h)."\n" if %$h;
        $h->{$_} //= $defaults->{$_} foreach keys %$defaults;
        $CONFIG->{$s} = \%v;
    }
    die "Invalid section(s): ".join(', ', keys %$h)."\n" if %$h;
    $CONFIG->{_} = $defaults;
    delete $CONFIG->{accountd} unless $accountd;
    $OPTS{quiet} = 0 if $OPTS{debug};
};

# Regular expressions for domain validation
my $RE_LABEL  = qr/[0-9a-z](?:[0-9a-z\x2D]{0,61}[0-9a-z])?/aai;
my $RE_DOMAIN = qr/$RE_LABEL(?:\.$RE_LABEL)+/;


#############################################################################
# Generate a Certificate Signing Request (in DER format)
#
sub gen_csr(%) {
    my %args = @_;
    return unless defined $args{'certificate-key'} and defined $args{subject};
    return if defined $args{hash} and !grep { $args{hash} eq $_ } qw/md5 rmd160 sha1 sha224 sha256 sha384 sha512/;

    my $config = File::Temp::->new(SUFFIX => '.conf', TMPDIR => 1) // die;
    $config->print(
        "[ req ]\n",
        "distinguished_name = req_distinguished_name\n",
        "req_extensions     = v3_req\n",

        "[ req_distinguished_name ]\n",

        "[ v3_req ]\n",
        "basicConstraints     = critical, CA:FALSE\n",
        "subjectKeyIdentifier = hash\n"
    );
    $config->print("keyUsage = critical, $args{keyUsage}\n")   if defined $args{keyUsage};
    $config->print("subjectAltName = $args{subjectAltName}\n") if defined $args{subjectAltName};
    $config->print("tlsfeature = $args{tlsfeature}\n") if defined $args{tlsfeature};
    $config->close() or die "close: $!";

    my @args = (qw/-new -batch -key/, $args{'certificate-key'});
    push @args, "-$args{hash}" if defined $args{hash};
    push @args, '-subj', $args{subject}, '-config', $config->filename(), qw/-reqexts v3_req/;

    open my $fh, '-|', qw/openssl req -outform DER/, @args or die "fork: $!";
    my $csr = do { local $/ = undef; <$fh> };
    close $fh or $! ? die "close: $!" : return;

    if ($OPTS{debug}) {
        # print out the CSR in text form
        pipe my $rd, my $wd or die "pipe: $!";
        my $pid = fork // die "fork: $!";
        unless ($pid) {
            open STDIN,  '<&', $rd      or die "dup: $!";
            open STDOUT, '>&', \*STDERR or die "dup: $!";
            exec qw/openssl req -noout -text -inform DER/ or die;
        }
        $rd->close() or die "close: $!";
        $wd->print($csr);
        $wd->close() or die "close: $!";

        waitpid $pid => 0;
        die $? if $? > 0;
    }

    return $csr;
}


#############################################################################
# Get the timestamp of the given cert's expiration date.
# Internally the expiration date is stored as a RFC3339 string (such as
# yyyy-mm-ddThh:mm:ssZ); we convert it to a timestamp manually.
#
sub x509_enddate($) {
    my $filename = shift;
    my ($bio, $x509, $time, $dt);

    $bio  = Net::SSLeay::BIO_new_file($filename, 'r');
    $x509 = Net::SSLeay::PEM_read_bio_X509($bio)        if defined $bio;
    $time = Net::SSLeay::X509_get_notAfter($x509)       if defined $x509;
    $dt   = Net::SSLeay::P_ASN1_TIME_get_isotime($time) if defined $time;

    my $t = Date::Parse::str2time($dt) if defined $dt;

    Net::SSLeay::X509_free($x509) if defined $x509;
    Net::SSLeay::BIO_free($bio)   if defined $bio;
    return $t;
}


#############################################################################
# Drop privileges and chdir afterwards
#
sub drop_privileges($$$) {
    my ($user, $group, $dir) = @_;

    # set effective and real gid; also set the list of supplementary gids to that single gid
    if ($group ne '') {
        my $gid = getgrnam($group) // die "getgrnam($group): $!";
        $) = "$gid $gid";
        die "setgroups: $!" if $@;
        POSIX::setgid($gid) or die "setgid: $!";
        die "Couldn't setgid/setguid" unless $( eq "$gid $gid" and $) eq "$gid $gid"; # safety check
    }

    # set effective and real uid
    if ($user ne '') {
        my $uid = getpwnam($user) // die "getpwnam($user): $!";
        POSIX::setuid($uid) or die "setuid: $!";
        die "Couldn't setuid/seteuid" unless $< == $uid and $> == $uid; # safety check
    }

    # sanitize environment
    my $term = $ENV{TERM};
    my @ent = getpwuid($<) or die "getpwuid($<): $!";
    %ENV = ( USER => $ent[0], LOGNAME => $ent[0], HOME => $ent[7], SHELL => $ent[8] );
    $ENV{PATH} = $< == 0 ? "/usr/sbin:/usr/bin:/sbin:/bin" : "/usr/bin:/bin";
    $ENV{TERM} = $term if defined $term; # preserve $TERM

    chdir $dir or die "chdir($dir): $!";
}


#############################################################################
# Ensure the FD_CLOEXEC bit is $set on $fd
#
sub set_FD_CLOEXEC($$) {
    my ($fd, $set) = @_;
    my $flags = fcntl($fd, F_GETFD, 0) or die "fcntl F_GETFD: $!";
    my $flags2 = $set ? ($flags | FD_CLOEXEC) : ($flags & ~FD_CLOEXEC);
    return if $flags == $flags2;
    fcntl($fd, F_SETFD, $flags2) or die "fcntl F_SETFD: $!";
}


#############################################################################
# If 'listen' is not empty, bind socket(s) to the given addresse(s) and
# spawn webserver(s) to serve ACME challenge reponses.
# The temporary challenge directory is returned.
#
sub spawn_webserver() {
    my $conf = $CONFIG->{webserver};

    # parse and pack addresses to listen to
    my @sockaddr;
    foreach my $a (split /[[:blank:],]\s*/, $conf->{listen}) {
        my $sockaddr;
        if ($a =~ /\A\//) { # absolute path to a unix domain socket
            $sockaddr = Socket::pack_sockaddr_un($a);
        } elsif ($a =~ /\A(\d+(?:\.\d+){3})(?::(\d+))?\z/) {
            my $n = Socket::inet_pton(AF_INET, $1);
            $sockaddr = Socket::pack_sockaddr_in($2 // 80, $n) if defined $n;
        } elsif ($a =~ /\A\[([[:xdigit:]:.]{2,39})\](?::(\d+))?\z/) {
            my $n = Socket::inet_pton(AF_INET6, $1);
            $sockaddr = Socket::pack_sockaddr_in6($2 // 80, $n) if defined $n;
        }
        die "Invalid address: $a\n" unless defined $sockaddr;
        push @sockaddr, $sockaddr;
    }

    # Use existing HTTPd to serve challenge files using 'challenge-directory'
    # as document root
    if (defined (my $dir = $conf->{'challenge-directory'})) {
        $dir = spec_expand($dir);
        print STDERR "[$$] Using existing webserver on $dir\n" if $OPTS{debug};
        # lacme(8) doesn't have the list of challenge files to delete on
        # cleanup -- instead, we unlink all files and fails at
        # initialization stage when the challenge directory is not empty

        opendir my $dh, $dir or die "opendir($dir): $!\n";
        while (readdir $dh) {
            die "Error: Refusing to use non-empty challenge directory $dir\n"
                unless $_ eq '.' or $_ eq '..';
        }
        closedir $dh or die "closedir: $!";
        undef $dh;

        # use a "lock file" (NFS-friendly) to avoid concurrent usages
        my $lockfile = ".$NAME.lock";
        sysopen(my $fh, "$dir/$lockfile", O_CREAT|O_EXCL|O_WRONLY, 0600)
            or die "Can't create lockfile in challenge directory: $!";
        print $fh $$, "\n";
        close $fh or die "close: $!";
        undef $fh;

        push @CLEANUP, sub() {
            if (opendir(my $dh, $dir)) {
                my @files = grep { $_ ne '.' and $_ ne '..' and $_ ne $lockfile } readdir $dh;
                closedir $dh or warn "closedir: $!";
                push @files, $lockfile; # unlink $lockfile last
                foreach (@files) {
                    die unless /\A(.+)\z/; # untaint
                    unlink "$dir/$1" or warn "unlink($dir/$1): $!";
                }
            } else {
                warn "opendir($dir): $!\n";
            }
        };
        return $dir; # ignore 'listen' and 'iptables'
    }

    die "'challenge-directory' option is required in section [webserver] when 'listen' is empty\n"
        unless @sockaddr;

    # create a temporary directory; give write access to the ACME client
    # and read access to the webserver
    my $tmpdir = File::Temp::->newdir(CLEANUP => 1, TMPDIR => 1, TEMPLATE => "acme-challenge.XXXXXXXXXX") // die;
    chmod 0755, $tmpdir or die "chmod: $!";
    if ((my $username = $CONFIG->{client}->{user}) ne '') {
        my $uid = getpwnam($username) // die "getpwnam($username): $!";
        chown($uid, -1, $tmpdir) or die "chown: $!";
    }

    # create socket(s) and spawn webserver(s)
    my @sockaddr4;
    foreach my $sockaddr (@sockaddr) {
        my $domain = Socket::sockaddr_family($sockaddr) // die;
        socket(my $sock, $domain, SOCK_STREAM, 0) or die "socket: $!";
        setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
            if $domain == AF_INET or $domain == AF_INET6;

        my $p; # pretty-print the address/port
        if ($domain == AF_UNIX) {
            $p = Socket::unpack_sockaddr_un($sockaddr);
        } elsif ($domain == AF_INET) {
            my ($port, $addr) = Socket::unpack_sockaddr_in($sockaddr);
            $p = Socket::inet_ntop($domain, $addr).":$port";
        } elsif ($domain == AF_INET6) {
            my ($port, $addr) = Socket::unpack_sockaddr_in6($sockaddr);
            $p = "[".Socket::inet_ntop($domain, $addr)."]:$port";
        }

        if ($domain == AF_UNIX) {
            # bind(2) with a loose umask(2) to allow anyone to connect
            my $umask = umask(0111) // die "umask: $!";
            my $path = Socket::unpack_sockaddr_un($sockaddr);
            bind($sock, $sockaddr) or die "Couldn't bind to $p: $!";
            push @CLEANUP, sub() {
                print STDERR "Unlinking $path\n" if $OPTS{debug};
                unlink $path or warn "Warning: Couldn't unlink $path: $!";
            };
            umask($umask) // die "umask: $!";
        }
        else {
            bind($sock, $sockaddr) or die "Couldn't bind to $p: $!";
        }

        listen($sock, 5) or die "listen: $!";

        # spawn a webserver component bound to the given socket
        my $pid = fork() // "fork: $!";
        unless ($pid) {
            drop_privileges($conf->{user}, $conf->{group}, $tmpdir);
            open STDIN, '<', '/dev/null' or die "open(/dev/null): $!";
            set_FD_CLOEXEC($sock, 0);
            $ENV{DEBUG} = $OPTS{debug} // 0;
            # use execve(2) rather than a Perl pseudo-process to ensure that
            # the child doesn't have access to the parent's memory
            my ($cmd, @args) = split(/\s+/, $conf->{command}) or die "Empty webserver command\n";
            exec { $cmd } $cmd, @args, fileno($sock) or die;
        }

        print STDERR "[$$] Forking ACME webserver bound to $p, child PID $pid\n" if $OPTS{debug};
        set_FD_CLOEXEC($sock, 1);
        push @CLEANUP, sub() {
            print STDERR "[$$] Shutting down ACME webserver bound to $p\n" if $OPTS{debug};
            kill 15 => $pid;
            waitpid $pid => 0;
            shutdown($sock, SHUT_RDWR) or warn "shutdown: $!";
        };

        # on dual-stack ipv4/ipv6, we'll need to open the port for the
        # v4-mapped address as well
        if ($domain == AF_INET6) {
            my $v6only = getsockopt($sock, Socket::IPPROTO_IPV6, Socket::IPV6_V6ONLY)
                // die "getsockopt(IPV6_V6ONLY): $!";
            my ($port, $addr) = Socket::unpack_sockaddr_in6($sockaddr);
            my $mask   = "\xFF" x 12              . "\x00" x 4;
            my $prefix = "\x00" x 10 . "\xFF" x 2 . "\x00" x 4;

            if (unpack('i', $v6only) == 0) {
                if ($addr eq IN6ADDR_ANY) {
                    push @sockaddr4, Socket::pack_sockaddr_in($port, INADDR_ANY);
                } elsif (($addr & $mask) eq $prefix) {
                    my $v4 = substr($addr, 12);
                    push @sockaddr4, Socket::pack_sockaddr_in($port, $v4);
                }
            }
        }
    }

    # allow incoming traffic on the given addresses
    if (lc ($conf->{iptables} // 'No') eq 'yes') {
        iptables_save(AF_INET,  @sockaddr, @sockaddr4);
        iptables_save(AF_INET6, @sockaddr);
    }

    return $tmpdir;
}


#############################################################################
# Save current iptables/ipv6tables to a temporary file and install
# temporary rules to open the given addresses/ports.
sub iptables_save($@) {
    my $domain = shift;
    my @sockaddr = grep { Socket::sockaddr_family($_) == $domain } @_;
    return unless @sockaddr; # no address in that domain

    # install iptables
    my $iptables_bin = $domain == AF_INET ? 'iptables' : $domain == AF_INET6 ? 'ip6tables' : die;
    my $iptables_tmp = File::Temp::->new(TMPDIR => 1) // die;
    set_FD_CLOEXEC($iptables_tmp, 1);

    my $pid = fork() // die "fork: $!";
    unless ($pid) {
        open STDIN,  '<',  '/dev/null'   or die "open(/dev/null): $!";
        open STDOUT, '>&', $iptables_tmp or die "dup: $!";
        $| = 1; # turn off buffering for STDOUT
        exec "/usr/sbin/$iptables_bin-save", "-c" or die;
    }
    waitpid $pid => 0;
    die "Error: /usr/sbin/$iptables_bin-save exited with value ".($? >> 8) if $? > 0;

    # seek back to the begining, as we'll restore directly from the
    # handle and not from the file.  XXX if there was a way in Perl to
    # use open(2) with the O_TMPFILE flag we would use that to avoid
    # creating a file to start with
    seek($iptables_tmp, SEEK_SET, 0) or die "seek: $!";

    push @CLEANUP, sub() {
        print STDERR "[$$] Restoring $iptables_bin\n" if $OPTS{debug};
        my $pid = fork() // die "fork: $!";
        unless ($pid) {
            open STDIN, '<&', $iptables_tmp or die "dup: $!";
            open STDOUT, '>', '/dev/null'   or die "open(/dev/null): $!";
            exec "/usr/sbin/$iptables_bin-restore", "-c" or die;
        }
        waitpid $pid => 0;
        warn "Warning: /usr/sbin/$iptables_bin-restore exited with value ".($? >> 8) if $? > 0;
    };


    # it's safe to install the new iptables to open $addr:$port now that
    # the restore hook is in place

    foreach my $sockaddr (@sockaddr) {
        my ($port, $addr, $mask);
        if ($domain == AF_INET) {
            ($port, $addr) = Socket::unpack_sockaddr_in($sockaddr);
            $mask = $addr eq INADDR_ANY ? '0' : '32';
        } elsif ($domain == AF_INET6) {
            ($port, $addr) = Socket::unpack_sockaddr_in6($sockaddr);
            $mask = $addr eq IN6ADDR_ANY ? '0' : '128';
        }

        my $dest = Socket::inet_ntop($domain, $addr) .'/'. $mask;
        system ("/usr/sbin/$iptables_bin", qw/-I INPUT  -p tcp -m tcp -m state/,
                '-d', $dest, '--dport', $port,
                '--state', 'NEW,ESTABLISHED', '-j', 'ACCEPT') == 0 or die;
        system ("/usr/sbin/$iptables_bin", qw/-I OUTPUT -p tcp -m tcp -m state/,
                '-s', $dest, '--sport', $port,
                '--state',     'ESTABLISHED', '-j', 'ACCEPT') == 0 or die;
    }
}


#############################################################################
# Spawn the client component, and wait for it to return.
# If $args->{in} is defined, the data is written to the client's STDIN.
# If $args->{out} is defined, its value is set to client's STDOUT data.
#
sub acme_client($@) {
    my $args = shift;
    my @args = @_;

    my ($client, $cleanup);
    my $conf = $CONFIG->{client};
    if (defined (my $accountd = $CONFIG->{accountd})) {
        warn "Setting 'privkey' in lacme.conf's [accountd] section is deprecated and will become an error in a future release! "
            ."Set it in lacme-accountd.conf instead.\n" if $accountd->{privkey} ne '';
        my $GPG_TTY = $ENV{GPG_TTY};
        socketpair($client, my $s, AF_UNIX, SOCK_STREAM, PF_UNSPEC) or die "socketpair: $!";
        my $pid = fork() // "fork: $!";
        unless ($pid) {
            drop_privileges($accountd->{user}, $accountd->{group}, '/');
            $client->close() or die "close: $!";
            open STDIN,  '<&', $s or die "dup: $!";
            open STDOUT, '>&', $s or die "dup: $!";
            set_FD_CLOEXEC($s, 1);
            $ENV{GPG_TTY} = $GPG_TTY if defined $GPG_TTY;
            my ($cmd, @args) = split(/\s+/, $accountd->{command}) or die "Empty accountd command\n";
            $_ = spec_expand($_) foreach ($cmd, @args); # expand %-specifiers after privilege drop and whitespace split
            push @args, '--stdio';
            push @args, '--config='.spec_expand($accountd->{config}) if $accountd->{config} ne '';
            push @args, '--privkey='.$accountd->{privkey} if $accountd->{privkey} ne ''; # XXX deprecated in 0.8.0
            push @args, '--quiet' unless lc $accountd->{quiet} eq 'no';
            push @args, '--debug' if $OPTS{debug};
            exec { $cmd } $cmd, @args or die;
        }
        print STDERR "[$$] Forking lacme-accountd, child PID $pid\n" if $OPTS{debug};
        $s->close() or die "close: $!";
        $cleanup = sub() {
            print STDERR "[$$] Shutting down lacme-accountd\n" if $OPTS{debug};
            shutdown($client, SHUT_RDWR) or warn "shutdown: $!";
            $client->close() or warn "close: $!";
        };
        push @CLEANUP, $cleanup;
    }
    else {
        my @stat;
        my $sockname = spec_expand($OPTS{socket} // $conf->{socket});
        $sockname = $sockname =~ /\A(\p{Print}+)\z/ ? $1 : die "Invalid socket name\n"; # untaint $sockname

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

        # ensure we're the only user with read/write access to the socket
        @stat = stat($sockname) or die "Can't stat $sockname: $! (Is lacme-accountd running?)\n";
        die "Error: Insecure permissions on $sockname\n" if ($stat[2] & 0066) != 0;

        # connect(2) to the socket
        socket($client, PF_UNIX, SOCK_STREAM, 0) or die "socket: $!";
        my $sockaddr = Socket::sockaddr_un($sockname) // die "Invalid address $sockname\n";
        until (connect($client, $sockaddr)) {
            next if $! == EINTR; # try again if connect(2) was interrupted by a signal
            die "connect: $!";
        }
    }

    # use execve(2) rather than a Perl pseudo-process to ensure that the
    # child doesn't have access to the parent's memory
    my ($cmd, @args2) = split(/\s+/, $conf->{command}) or die "Empty client command\n";
    my @fileno = map { fileno($_) =~ /^(\d+)$/ ? $1 : die } ($CONFFILE, $client); # untaint fileno
    set_FD_CLOEXEC($client, 1);
    my $rv = spawn({in => $args->{in}, out => $args->{out}, child => sub() {
        drop_privileges($conf->{user}, $conf->{group}, $args->{chdir} // '/');
        set_FD_CLOEXEC($_, 0) foreach ($CONFFILE, $client);
        seek($CONFFILE, SEEK_SET, 0) or die "seek: $!";
        $ENV{DEBUG} = $OPTS{debug} // 0;
    }}, $cmd, @args2, $COMMAND, @fileno, @args);

    if (defined $cleanup) {
        @CLEANUP = grep { $_ ne $cleanup } @CLEANUP;
        $cleanup->();
    }
    return $rv;
}

sub spawn($@) {
    my $args = shift;
    my ($cmd, @args) = @_;

    # create communication pipes if needed
    my ($in_rd, $in_wd, $out_rd, $out_wd);
    if (defined $args->{in}) {
        pipe $in_rd, $in_wd or die "pipe: $!";
    }
    if (defined $args->{out} and ref $args->{out} ne 'GLOB') {
        pipe $out_rd, $out_wd or die "pipe: $!";
    }

    my $pid = fork() // "fork: $!";
    unless ($pid) {
        # child
        $args->{child}->() if defined $args->{child};
        if (defined $args->{in}) {
            close $in_wd or die "close: $!";
            open STDIN, '<&', $in_rd or die "dup: $!";
        } else {
            open STDIN, '<', '/dev/null' or die "open(/dev/null): $!";
        }
        if (!defined $args->{out}) {
            open STDOUT, '>', '/dev/null' or die "open(/dev/null): $!";
        } elsif (ref $args->{out} ne 'GLOB') {
            close $out_rd or die "close: $!";
            open STDOUT, '>&', $out_wd or die "dup: $!";
        } elsif (fileno(STDOUT) != fileno($args->{out})) {
            open STDOUT, '>&', $args->{out} or die "dup: $!";
        }
        exec { $cmd } $cmd, @args or die;
    }
    push @CLEANUP, sub() {
        kill 15 => $pid;
        waitpid $pid => 0;
    };

    # parent
    print STDERR "[$$] Forking $cmd, child PID $pid\n" if $OPTS{debug};
    if (defined $args->{in}) {
        $in_rd->close() or die "close: $!";
        $in_wd->print($args->{in});
        $in_wd->close() or die "close: $!";
    }
    if (defined $args->{out} and ref $args->{out} ne 'GLOB') {
        $out_wd->close() or die "close: $!";
        if (ref $args->{out} eq 'CODE') {
            $args->{out}->($out_rd);
        } elsif (ref $args->{out} eq 'SCALAR') {
            ${$args->{out}} = do { local $/ = undef; $out_rd->getline() };
        }
        $out_rd->close() or die "close: $!";
    }
    waitpid $pid => 0;
    pop @CLEANUP;
    undef ${$args->{out}} if defined $args->{out} and ref $args->{out} eq 'SCALAR' and $? > 0;
    return $? > 255 ? ($? >> 8) : $? > 0 ? 1 : 0;
}


#############################################################################
# Install the certificate (optionally excluding the chain of trust)
#
sub install_cert($$;$) {
    my ($filename, $chain, $leafonly) = @_;

    my ($dirname, $basename) =
        $filename =~ /\A(.*)\/([^\/]+)\z/ ? ($1, $2) : ('.', $filename);
    my $fh = File::Temp::->new(UNLINK => 0, DIR => $dirname,
                               TEMPLATE => "$basename.XXXXXX") // die;

    eval {
        my $umask = umask() // die "umask: $!";
        chmod(0644 &~ $umask, $fh) or die "chmod: $!";
        if ($leafonly) {
            # keep only the leaf certificate
            pipe my $rd, my $wd or die "pipe: $!";
            my $pid = fork // die "fork: $!";
            unless ($pid) {
                open STDIN,  '<&', $rd or die "dup: $!";
                open STDOUT, '>&', $fh or die "dup: $!";
                exec qw/openssl x509 -outform PEM/ or die;
            }
            $rd->close() or die "close: $!";
            $wd->print($chain);
            $wd->close() or die "close: $!";

            waitpid $pid => 0;
            die $? if $? > 0;
        } else {
            $fh->print($chain) or die "print: $!";
        }
        $fh->close() or die "close: $!";
    };
    my $path = $fh->filename();
    if ($@) {
        print STDERR "Unlinking $path\n" if $OPTS{debug};
        unlink $path or warn "unlink($path): $!";
        die $@;
    }
    rename($path, $filename) or die "rename($path, $filename): $!";
}


#############################################################################
# account [--tos-agreed] [CONTACT ..]
#
if ($COMMAND eq 'account') {
    my $flags = 0;
    $flags |= 1 if $OPTS{'register'};
    $flags |= 2 if $OPTS{'tos-agreed'};
    $flags |= 4 if $OPTS{'deactivate'};
    exit acme_client({out => \*STDOUT}, $flags, @ARGV);
}


#############################################################################
# newOrder [SECTION ..]
#
elsif ($COMMAND eq 'newOrder' or $COMMAND eq 'new-cert') {
    $OPTS{'min-days'} = -1 if $OPTS{force};
    $COMMAND = 'newOrder';
    my $conffiles = defined $OPTS{'config-certs'} ? $OPTS{'config-certs'}
                  : defined $CONFIG->{_}->{'config-certs'} ? [ split(/\s+/, $CONFIG->{_}->{'config-certs'}) ]
                  : [ "$NAME-certs.conf", "$NAME-certs.conf.d/" ];
    $_ = spec_expand($_) foreach @$conffiles;
    my ($conf, %defaults);
    foreach my $conffile (@$conffiles) {
        $conffile = dirname($CONFFILENAME) .'/'. $conffile unless $conffile =~ /\A\//;
        my @filenames;
        unless ($conffile =~ s#/\z## or -d $conffile) {
            @filenames = ($conffile);
        } else {
            opendir my $dh, $conffile or die "opendir($conffile): $!\n";
            while (readdir $dh) {
                if (/\.conf\z/) {
                    push @filenames, "$conffile/$_";
                } elsif ($_ ne '.' and $_ ne '..') {
                    warn "$conffile/$_ has unknown suffix, skipping\n";
                }
            }
            closedir $dh or die "closedir: $!";
        }
        foreach my $filename (sort @filenames) {
            print STDERR "Reading $filename\n" if $OPTS{debug};
            my $h = Config::Tiny::->read($filename) or die Config::Tiny::->errstr()."\n";
            my $def = delete $h->{_} // {};
            $defaults{$_} = $def->{$_} foreach keys %$def;
            my @valid = qw/certificate certificate-chain certificate-key min-days CAfile
                           hash keyUsage subject subjectAltName tlsfeature chown chmod notify/;
            foreach my $s (keys %$h) {
                $conf->{$s} = { map { $_ => delete $h->{$s}->{$_} } @valid };
                die "Unknown option(s) in [$s]: ".join(', ', keys %{$h->{$s}})."\n" if %{$h->{$s}};
                $conf->{$s}->{$_} //= $defaults{$_} foreach keys %defaults;
            }
        }
    }

    my $challenge_dir;
    my $rv = 0;
    foreach my $s (@ARGV ? @ARGV : sort (keys %$conf)) {
        my $conf = $conf->{$s} // do {
            print STDERR "Warning: No such section $s, skipping\n";
            $rv = 1;
            next;
        };

        if ($OPTS{debug}) {
            print STDERR "Configuration option for $s:\n";
            print STDERR "    $_ = $conf->{$_}\n" foreach grep { defined $conf->{$_} } (sort keys %$conf);
        }

        my $cert = $conf->{'certificate-chain'} // $conf->{'certificate'};
        unless (defined $cert) {
            print STDERR "[$s] Warning: Missing 'certificate' and 'certificate-chain', skipping\n";
            $rv = 1;
            next;
        }

        # skip certificates that expire at least $conf->{'min-days'} days in the future
        if (-f $cert and defined (my $t = x509_enddate($cert))) {
            my $d = $OPTS{'min-days'} // $conf->{'min-days'} // 21;
            if ($d >= 0 and $t - time > $d*86400) {
                my $d = POSIX::strftime('%Y-%m-%d %H:%M:%S UTC', gmtime($t));
                print STDERR "[$s] Valid until $d, skipping\n" unless $OPTS{quiet};
                next;
            }
        }

        # generate the CSR
        my $csr = gen_csr(map {$_ => $conf->{$_}} qw/certificate-key keyUsage subject subjectAltName tlsfeature hash/) // do {
            print STDERR "[$s] Warning: Couldn't generate CSR, skipping\n";
            $rv = 1;
            next;
        };

        # spawn the webserver if not done already
        $challenge_dir //= spawn_webserver();

        # list all authorization domains to request
        my @authz;
        push @authz, $1 if defined $conf->{subject} =~ /\A.*\/CN=($RE_DOMAIN)\z/o;
        if (defined $conf->{subjectAltName}) {
            foreach my $d (split /,/, $conf->{subjectAltName}) {
                next unless $d =~ s/\A\s*DNS://;
                if ($d =~ /\A$RE_DOMAIN\z/o) {
                    push @authz, $d unless grep {$_ eq $d} @authz;
                } else {
                    print STDERR "[$s] Warning: Ignoring invalid domain $d\n";
                }
            }
        }

        my ($x509, $csr_pubkey, $x509_pubkey);
        print STDERR "[$s] Will request authorization for: ".join(", ", @authz), "\n" if $OPTS{debug};
        if (acme_client({chdir => $challenge_dir, in => $csr, out => \$x509}, @authz)) {
            print STDERR "[$s] Error: Couldn't issue X.509 certificate!\n";
            $rv = 1;
            next;
        }

        # extract pubkeys from CSR and cert, and ensure they match
        spawn({in => $csr,  out => \$csr_pubkey }, qw/openssl req  -inform DER -noout -pubkey/);
        spawn({in => $x509, out => \$x509_pubkey}, qw/openssl x509 -inform PEM -noout -pubkey/);
        unless (defined $x509_pubkey and defined $csr_pubkey and $x509_pubkey eq $csr_pubkey) {
            print STDERR "[$s] Error: Received bogus X.509 certificate from ACME server!\n";
            $rv = 1;
            next;
        };

        # verify certificate validity against the CA bundle
        if ((my $CAfile = $conf->{CAfile} // '@@datadir@@/lacme/ca-certificates.crt') ne '') {
            my %args = (in => $x509);
            $args{out} = \*STDERR if $OPTS{debug};
            my @options = ('-trusted', $CAfile, '-purpose', 'sslserver', '-x509_strict');
            push @options, '-show_chain' if $OPTS{debug};
            if (spawn(\%args, 'openssl', 'verify', @options)) {
                print STDERR "[$s] Error: Received invalid X.509 certificate from ACME server!\n";
                $rv = 1;
                next;
            }
        }

        # install certificate
        if (defined $conf->{'certificate'}) {
            print STDERR "Installing X.509 certificate $conf->{'certificate'}\n";
            install_cert($conf->{'certificate'}, $x509, 1);
        }
        if (defined $conf->{'certificate-chain'}) {
            print STDERR "Installing X.509 certificate chain $conf->{'certificate-chain'}\n";
            install_cert($conf->{'certificate-chain'}, $x509);
        }

        if (defined $conf->{chown}) {
            my ($user, $group) = split /:/, $conf->{chown}, 2;
            my $uid = getpwnam($user) // die "getpwnam($user): $!";
            my $gid = defined $group ? (getgrnam($group) // die "getgrnam($group): $!") : -1;
            foreach (grep defined, @$conf{qw/certificate certificate-chain/}) {
                chown($uid, $gid, $_) or die "chown: $!";
            }
        }
        if (defined $conf->{chmod}) {
            my $mode = oct($conf->{chmod}) // die;
            foreach (grep defined, @$conf{qw/certificate certificate-chain/}) {
                chmod($mode, $_) or die "chown: $!";
            }
        }

        my @certopts = join ',', qw/no_header no_version no_pubkey no_sigdump/;
        open my $fh, '|-', qw/openssl x509 -noout -fingerprint -sha256 -text -certopt/, @certopts
            or die "fork: $!";
        print $fh $x509;
        close $fh or die $! ?
            "close: $!" :
            "Error: x509(1ssl) exited with value ".($? >> 8)."\n";

        if (defined $conf->{notify}) {
            print STDERR "Running notification command `$conf->{notify}`\n";
            if (system($conf->{notify}) != 0) {
                print STDERR "Warning: notification command exited with value ".($? >> 8)."\n";
                $rv = 1;
            }
        }
    }
    undef $challenge_dir;
    exit $rv;
}


#############################################################################
# revokeCert FILE [FILE ..]
#
elsif ($COMMAND eq 'revokeCert' or $COMMAND eq 'revoke-cert') {
    die "Nothing to revoke\n" unless @ARGV;
    my $rv = 0;
    $COMMAND = 'revokeCert';
    foreach my $filename (@ARGV) {
        print STDERR "Revoking $filename\n";

        # conversion PEM -> DER
        open my $fh, '-|', qw/openssl x509 -outform DER -in/, $filename or die "fork: $!";
        my $der = do { local $/ = undef; <$fh> };
        close $fh or die $! ?
            "close: $!" :
            "Error: x509(1ssl) exited with value ".($? >> 8)."\n";

        my @certopts = join ',', qw/no_header no_version no_pubkey no_sigdump no_extensions/;
        open my $fh2, '|-', qw/openssl x509 -inform DER -noout -fingerprint -sha256 -text -certopt/, @certopts
            or die "fork: $!";
        print $fh2 $der;
        close $fh2 or die $! ?
            "close: $!" :
            "Error: x509(1ssl) exited with value ".($? >> 8)."\n";

        if (acme_client({in => $der})) {
            print STDERR "Warning: Couldn't revoke $filename\n";
            $rv = 1;
        }
    }
    exit $rv;
}


#############################################################################
#
else {
    die "Unknown command $COMMAND"
}


END {
    local $?;
    $_->() foreach reverse @CLEANUP;
}