#!/usr/bin/perl -T

#----------------------------------------------------------------------
# Let's Encrypt ACME client
# Copyright © 2015,2016 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 <http://www.gnu.org/licenses/>.
#----------------------------------------------------------------------

use strict;
use warnings;

# Usage: client COMMAND CONFIG_FD SOCKET_FD [ARGUMENTS]
#
# fdopen(3) the file descriptor SOCKET_FD (corresponding to the
# listening letsencrypt-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).

my $PROTOCOL_VERSION = 1;

use LWP::UserAgent ();
use MIME::Base64 qw/encode_base64 encode_base64url/;
use JSON ();
use Digest::SHA qw/sha256 sha256_hex/;

use Config::Tiny ();

# 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 or die "fdopen $1: $!";
(shift @ARGV // die) =~ /\A(\d+)\z/ or die;
open my $S, '+<&=', $1 or die "fdopen $1: $!";


#############################################################################
# Read the protocol version and JSON Web Key (RFC 7517) from the
# letsencrypt-accountd socket
#
die "Error: Invalid client version\n" unless
    $S->getline() =~ /\A(\d+) OK(?:.*)\r\n\z/ and $1 == $PROTOCOL_VERSION;
my $JWK = JSON::->new->decode($S->getline());

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

my $JWK_thumbprint = encode_base64url(sha256(json()->encode($JWK)));
my $NONCE;


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

my $CONFIG = do {
    my $conf = do { local $/ = undef, <$CONFFILE> };
    close $CONFFILE or die "Can't close: $!";
    my $h = Config::Tiny::->read_string($conf) or die Config::Tiny::->errstr()."\n";
    $h->{_} //= {};
    $h->{client}->{$_} //= $h->{_}->{$_} foreach keys %{$h->{_}}; # add defaults
    $h->{client};
};
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( ssl_opts => \%ssl_opts );
} // die "Can't create LWP::UserAgent object";


#############################################################################
# Send an HTTP request to the ACME server.  If $json is defined, send
# its encoding as the request content, with "application/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/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;
}

# List all 'Links' headers with the relationship $rel (RFC 5988)
sub request_link_rel($$) {
    my ($r, $rel) = @_;
    grep defined, map
        { /\A<([^>]+)>.*;\s*rel=([^;]+)/
        ; my ($link, $rels) = ($1, $2 // '')
        ; (grep { $rel eq $_ } map { /^"(.*)"/ ? $1 : $_ } split(/\s+/, $rels)) ? $link : undef
        }
        $r->header('Link');
}

# The request's Status Line; if the Content-Type is
# application/problem+json, parse the decoded content as JSON and add
# the value of the 'detail' field to the Status Line.
# https://tools.ietf.org/html/draft-ietf-appsawg-http-problem
sub request_status_line($) {
    my $r = shift;
    my $msg = $r->status_line;
    if ($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;
}

# 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};
    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';
    $content = json()->decode($content);

    print STDERR json()->pretty->encode($content), "\n" if $dump;
    return $content;
}


#############################################################################
# JSON-encode the hash reference $h and send it to the ACME server $uri
# encapsulated it in a JSON Web Signature (JWS).
# https://tools.ietf.org/html/draft-ietf-acme-acme
#
sub acme($$) {
    my ($uri, $h) = @_;

    # the ACME server MUST provide a Replay-Nonce header field in
    # response to a HEAD request for any valid resource
    request(HEAD => $uri) unless defined $NONCE;

    # Produce the JSON Web Signature: RFC 7515 section 5
    my $payload = encode_base64url(json()->encode($h));
    my %header = ( alg => 'RS256', jwk => $JWK );
    my $protected = encode_base64url(json()->encode({ %header, nonce => $NONCE }));
    my $data = $protected .'.'. $payload;
    $S->printflush($data, "\r\n");
    my $sig = $S->getline();
    $sig =~ s/\r\n\z// or die;

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

my $SERVER_URI = $CONFIG->{server} // 'https://acme-v01.api.letsencrypt.org/';
$SERVER_URI .= '/' unless substr($SERVER_URI, -1, 1) eq '/';

my %RES;
# Get the resource URI from the directory
sub acme_resource($%) {
    my $r = shift;
    # Query the root ACME directory to initialize the nonce and get the resources URIs
    %RES = %{ request_json_decode(request(GET => $SERVER_URI.'directory')) } unless %RES;
    my $uri = $RES{$r} // die "Missing ressource for \"$r\"\n";
    acme($uri, {resource => $r, @_});
}


#############################################################################
# new-reg AGREEMENT_URI [CONTACT ..]
#
if ($COMMAND eq 'new-reg') {
    my $agreement = shift @ARGV;
    print STDERR "Requesting new registration ".(@ARGV ? ("for ".join(', ', @ARGV)) : "")."\n";

    my %h = (contact => \@ARGV);
    $h{agreement} = $agreement if $agreement ne '';
    my $r = acme_resource('new-reg', %h);

    my ($terms) = request_link_rel($r, 'terms-of-service');
    request_json_decode($r,1) if $r->is_success() and $ENV{DEBUG}; # pretty-print the JSON
    print STDERR request_status_line($r), "\n";
    print STDERR "Subscriber Agreement URI: $terms\n" if defined $terms;
    print STDERR "Registration URI: ", $r->header('Location'), "\n";
    exit ($r->is_success() ? 0 : 1);
}


#############################################################################
# reg=URI AGREEMENT_URI [CONTACT ..]
#
elsif ($COMMAND =~ /\Areg=(\p{Print}+)\Z/) {
    die "Empty registration URI (use the 'new-reg' command to determine the URI)\n" if $1 eq '';
    my $uri = $SERVER_URI.$1;
    my $agreement = shift @ARGV;

    my %h = (resource => 'reg');
    $h{agreement} = $agreement if $agreement ne '';
    $h{contact} = \@ARGV if @ARGV; # don't empty the contact list
    my $r = acme($uri, \%h);

    my ($terms) = request_link_rel($r, 'terms-of-service');
    $r->is_success() ? request_json_decode($r,1)  # pretty-print the JSON
                     : print STDERR request_status_line($r), "\n";
    print STDERR "Subscriber Agreement URI: $terms\n" if defined $terms;
    exit ($r->is_success() ? 0 : 1);
}


#############################################################################
# new-cert AUTHZ [AUTHZ ..]
#   Read the CSR (in DER format) from STDIN, print the cert (in PEM format
#   to STDOUT)
#
elsif ($COMMAND eq 'new-cert') {
    die unless @ARGV;
    foreach my $domain (@ARGV) {
        print STDERR "Processing new DNS authz for $domain\n" if $ENV{DEBUG};
        my $r = acme_resource('new-authz', identifier => {type => 'dns', value => $domain});

        my ($challenge) = grep {$_->{type} eq 'http-01'}
                               @{request_json_decode($r)->{challenges} // []};
        die "Missing 'http-01' challenge in server response" unless defined $challenge;
        die "Invalid challenge token ".($challenge->{token} // '')."\n"
            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 (-e $challenge->{token}) {
            print STDERR "WARNING: File exists: $challenge->{token}\n";
        }
        else {
            open my $fh, '>', $challenge->{token} or die "Can't open $challenge->{token}: $!";
            $fh->print($keyAuthorization);
            $fh->close() or die "Can't close: $!";
        }

        $r = acme($challenge->{uri}, {
            resource => 'challenge',
            keyAuthorization => $keyAuthorization
        });
        # wait until the status become 'valid'
        for ( my $i = 0, my $status;
              $status = request_json_decode($r)->{status} // 'pending',
              $status ne 'valid';
              $r = request('GET' => $challenge->{uri}), $i++ ) {
            die "Error: Invalid challenge for $domain (status: ".$status.")\n" if $status ne 'pending';
            die "Timeout exceeded while waiting for challenge to pass ($domain)\n"
                if $i >= ($CONFIG->{timeout} // 10);
            sleep 1;
        }
    }

    my $csr = do { local $/ = undef; <STDIN> };
    my $r = acme_resource('new-cert', csr => encode_base64url($csr));
    die request_status_line($r), "\n" unless $r->is_success();
    my $uri = $r->header('Location');
    # https://acme-v01.api.letsencrypt.org/acme/cert/$serial
    print STDERR "Certificate URI: $uri\n";

    # wait for the cert
    for (my $i = 0; $r->decoded_content() eq ''; $r = request('GET' => $uri), $i++) {
        die request_status_line($r), "\n" unless $r->is_success();
        die "Timeout exceeded while waiting for certificate\n"
            if $i >= ($CONFIG->{timeout} // 10);
        sleep 1;
    }
    my $der = $r->decoded_content();

    # conversion DER -> PEM
    pipe my $rd, my $wd or die "Can't pipe: $!";
    my $pid = fork // die "Can't fork: $!";
    unless ($pid) {
        open STDIN, '<&', $rd or die "Can't dup: $!";
        exec qw/openssl x509 -inform DER -outform PEM/ or die;
    }
    $rd->close() or die "Can't close: $!";
    $wd->print($der);
    $wd->close() or die "Can't close: $!";

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


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

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