#!/usr/pkg/bin/perl

# Januar 2025, Edgar Fuß, Mathematisches Institut der Universität Bonn
# Artistic or 2-clause BSD licence.

use utf8;
use strict;
use warnings;
use feature 'say';
use threads;
use threads::shared;

use Encode::Locale;

use Getopt::Std;
use Config::Tiny;
use Term::ReadKey;
use IO::Prompter;

use Crypt::LE;

use Data::Dumper;
$Data::Dumper::Sortkeys = 1;

binmode STDIN,  -t STDIN  ? ':encoding(console_in)'  : ':encoding(locale)';
binmode STDOUT, -t STDOUT ? ':encoding(console_out)' : ':encoding(locale)';
binmode STDERR, -t STDERR ? ':encoding(console_out)' : ':encoding(locale)';

my %options;
getopts('nvdsc:b:k:t:D:A:C:U:L:P:B:I:H:', \%options) or die "invalid options\n";

my $dryrun = $options{n};
my $verbose = $options{v};
my $debug = $options{d};
my $staging = $options{s};
my $configfile = $options{c} // 'acmechanic.conf';
my $keyfile = $options{k};
my $type = $options{t};
my $ca = $options{C};
my $domain = $options{D};
my $acme_domain = $options{A};
my $url = $options{U};
my $listen = $options{L};
my $port = $options{P};
my $base = $options{B} // '/.well-known/acme-challenge/';
my $eab_key_id = $options{I};
my $eab_hmac_key = $options{H};

if ($configfile and -e $configfile) {
	my $config = Config::Tiny->read($configfile);
	die "cannot read config from $configfile\n" unless $config;
	my $block = $options{b} // '-';
	$keyfile //= $config->{$block}{keyfile} // $config->{_}{keyfile};
	$type //= $config->{$block}{type} // $config->{_}{type};
	# type hier prüfen, weil das für listen/port benutzt wird
	$ca //= $config->{$block}{ca} // $config->{_}{ca};
	$domain //= $config->{$block}{domain} // $config->{_}{domain};
	$acme_domain //= $config->{$block}{'acme-domain'} // $config->{_}{'acme-domain'};
	$url //= $config->{$block}{url} // $config->{_}{url};
	if ($type) {
		$type = lc $type;
		$type =~ s/-01$//;
		if ($type ne 'none') {
			die "unknown challenge type $type\n" unless $type =~ m/^(dns|http)$/;
			$listen //= $config->{$block}{"$type-listen"} // $config->{_}{"$type-listen"};
			$port //= $config->{$block}{"$type-port"} // $config->{_}{"$type-port"};
		}
	}
	$listen //= $config->{$block}{listen} // $config->{_}{listen};
	$port //= $config->{$block}{port} // $config->{_}{port};
	$base //= $config->{$block}{"http-base"} // $config->{_}{"http-base"} // $config->{$block}{base} // $config->{_}{base};
	$eab_key_id //= $config->{$block}{"eab-key-id"} // $config->{_}{"eab-key-id"};
	$eab_hmac_key //= $config->{$block}{"eab-hmac-key"} // $config->{_}{"eab-hmac-key"};
}

sub get_key {
	my ($val, $env, $msg) = @_;

	if (defined $val) {
		if ($val =~ s/^<//) {
			open(my $fh, '<', $val) or die("can't open $msg key file $val: $!\n");
			$val = <$fh>;
			close($fh);
			chomp $val;
		}
		return $val;
	}
	if (defined $ENV{$env}) {
		return $ENV{$env};
	}
	my ($ttyin, $ttyout);
	open($ttyin, '<', '/dev/tty') or die "ttyin: $!\n";
	open($ttyout, '>', '/dev/tty') or die "ttyout: $!\n";
	$val = prompt("Enter $msg:", -v, -in => $ttyin, -out => $ttyout);
	close($ttyin);
	close($ttyout);
	return $val;
}


if (defined $eab_key_id and $eab_key_id ne '') {
	$eab_hmac_key = get_key($eab_hmac_key, 'EAB_HMAC_KEY', 'EAB-HMAC key');
	die "no EAB-HMAC key\n" if !defined $eab_hmac_key or $eab_hmac_key eq '';
}

# Dummy-logger, weil Crypt::LE sonst nach STDOUT (und nicht STDERR) schreibt.
sub STDERRlogger::new {
	return bless {}, 'STDERRlogger';
}

sub STDERRlogger::debug {
	print STDERR $_[1], "\n";
}

my $le;

sub register {
	my ($email) = @_;
	die "no keyfile\n" unless $keyfile;
	my %opts;
	$opts{ca} = $ca if $ca;
	$opts{live} = 1 unless $staging;
	$opts{dir} = $url if $url;
	$opts{debug} = 1 if $debug;
	$opts{logger} = STDERRlogger::new if $debug;
	$le = Crypt::LE->new(%opts) or die "Crypt::LE->new() failed: " . $le->error_details . "\n";
	say STDERR 'fetching directory' if $verbose;
	$le->directory();
	if ($email) {
		say STDERR "setting account email to $email" if $verbose;
		$le->set_account_email($email);
	}
	say STDERR "loading account key $keyfile" if $verbose;
	$le->load_account_key($keyfile) == 0 or die "load_account_key($keyfile) failed: " . $le->error_details . "\n";
	my @register_args;
	@register_args = ($eab_key_id, $eab_hmac_key) if defined $eab_key_id and $eab_key_id ne '';
	say STDERR 'registering' if $verbose;
	$le->register(@register_args) == 0 or die "register() failed: " . $le->error_details . "\n";
	if ($email) {
		say STDERR 'already registered' unless $le->new_registration();
	} else {
		say STDERR 'not registered' if $le->new_registration();
	}
}

my %challenges :shared; # keys sind Filenamen bei HTTP-01 und Hostnamen bei DNS-01
my %verify_results :shared; # keys sind immer Hostnamen. Wert undef bedeutet, daß noch keine Challenge stattgefunden hat.
my $verify_done :shared;
lock $verify_done; # Hack, um den DNS/HTTP-Thread am Ende zu blockieren

sub verify_cb {
	my ($results, $params) = @_;

	print STDERR 'verify callback: ', Dumper($results) if $debug;
	my $host = $results->{host} or die "verify callback: no host\n";
	my $valid = $results->{valid} or die "verify callback: no valid\n";
	die "verify callback: result for unknown host $host\n" unless exists $verify_results{$host};
	die "verify callback: result already recorded for $host\n" if defined $verify_results{$host};
	say STDERR 'verify ', $valid ? 'OK' : 'NG', " for $host" if $verbose;
	$verify_results{$host} = $valid;
	# Eigentlich müßte man nicht zweimal den Hash durchlaufen und könnte auch beim ersten undefinierten Wert abbrechen, aber das läßt sich nicht so übersichtlich hinschreiben:
	$verify_done = (grep defined, values %verify_results) == (keys %verify_results);
	if ($verbose and $verify_done) {
		my $ok = grep $_, values %verify_results;
		my $num = keys %verify_results;
		say STDERR 'Verifications done, ', $ok == $num ? 'all' : "$ok/$num", ' results OK';
	}

	return 1;
}

# DNS-01

sub dns_challenge_cb {
	my ($data) = @_;

	print STDERR 'DNS callback: ', Dumper($data) if $debug;
	my $d = $domain // '*';
	my $host = $data->{host} or die "DNS callback: no host\n";
	my $dom = $data->{domain} or die "DNS callback: no domain\n";
	my $txt = $data->{record} or die "DNS callback: no record\n";
	undef $verify_results{$host};
	$dom =~ m/^(.*)\.$d$/ or die "DNS callback: $dom doesn't match domain $d\n";
	$challenges{$1} = $txt;

	return 1;
}

sub dns_reply_handler {
	my ($qname, $qclass, $qtype, $peerhost, $query, $conn) = @_;
	my ($rcode, @ans, @auth, @add, $headermask, $optionmask);
	say STDERR 'query:' if $debug;
	$query->print if $debug;
	unless ($qclass eq 'IN') {
		say STDERR "non-IN query ($qclass)" if $debug;
		return 'REFUSED';
	}
	unless ($qtype eq 'TXT') {
		say STDERR "non-TXT query ($qtype)" if $debug;
		return 'NXDOMAIN';
	}
	my $d = $acme_domain // '*';
	my $q = lc $qname; # die schicken lustiges mIXedcAsE.
	unless ($q =~ m/^(.*)\.$d$/) {
		say STDERR "$q doesn't match ACME domain $d" if $debug;
		return 'NXDOMAIN';
	}
	my $h = $1;
	unless (exists $challenges{$h}) {
		say STDERR "no DNS challenge recorded for $h" if $debug;
		return 'NXDOMAIN';
	}
	my ($ttl, $rdata) = (10, $challenges{$h});
	my $ans = "$q $ttl $qclass $qtype $rdata";
	say STDERR "answer: $ans" if $debug;
	my $rr = Net::DNS::RR->new($ans);
	push @ans, $rr;
	$rcode = "NOERROR";
	say STDERR "answering DNS challenge for $q" if $verbose;
	return ($rcode, \@ans, \@auth, \@add, $headermask, $optionmask);
}

sub resolver {
	select STDERR if $debug; # der schreibt sonst nach STDOUT
	my $ns = Net::DNS::Nameserver->new(
		LocalAddr => [ split(',', $listen // '0.0.0.0,::')],
		LocalPort => $port // 53,
		ReplyHandler => \&dns_reply_handler,
		Verbose => $debug,
	) or die "can't create nameserver: $@\n";

	say STDERR 'starting DNS resolver' if $verbose;
	$ns->loop_once(1) until $verify_done;
	say STDERR 'stopped DNS resolver' if $verbose;
	select STDOUT;
	lock $verify_done; # Hack, um OpenSSL internal error: refcount error zu vermeiden
}

# HTTP-01

my %http_hosts :shared; # Nur für Debug-Ausgaben (man hat den Filenamen, will aber den Hostnamen ausgeben)

sub http_challenge_cb {
	my ($data) = @_;

	print STDERR 'HTTP callback: ', Dumper($data) if $debug;
	my $host = $data->{host} or die "HTTP callback: no host\n";
	my $file = $data->{file} or die "HTTP callback: no file\n";
	my $text = $data->{text} or die "HTTP callback: no text\n";
	undef $verify_results{$host};
	$challenges{$file} = $text;
	$http_hosts{$file} = $data->{host};

	return 1;
}

sub httpd {
	my $daemon = HTTP::Daemon->new(
		LocalAddr => $listen // '0.0.0.0', # Hier geht nur eine Adresse
		LocalPort => $port // 80,
		Timeout => 1,
		# Verbose => $debug,
	) or die "can't create httpd: $@\n";
	say STDERR 'starting HTTP server' if $verbose;
	until ($verify_done) {
		if (my $con = $daemon->accept) {
			while (my $req = $con->get_request) {
				if ($req->method eq 'GET') {
					if ($req->uri->path =~ m/^$base(.*)$/) {
						my $file = $1;
						# Wegen des Proxies hat die URL keinen host-Teil
						my $host = $http_hosts{$file} // '<unknown>';
						if (exists $challenges{$file}) {
							my $res = HTTP::Response->new(200,'OK',undef,$challenges{$file}) or die "can't create response: $@\n";
							say STDERR "answering HTTP challenge for $host" if $verbose;
							$con->send_response($res) or die "can't send response: $@\n";
						} else {
							say STDERR "no HTTP challenge recorded for $file (host $host)" if $debug;
							$con->send_error(404);
						}
					} else {
						say STDERR "non-GET method $req->method" if $debug;
						$con->send_error(400);
					}
				} else {
					say STDERR "non-base path $req->path" if $debug;
					$con->send_error(404);
				}
			}
			$con->close;
			undef $con;
		}
	}
	say STDERR 'stopped HTTP server' if $verbose;
	lock $verify_done; # Hack, um OpenSSL internal error: refcount error zu vermeiden
}


sub request {
	my ($csr) = @_;
	
	die "no challenge type\n" unless $type;
	
	register();
	say STDERR 'loading CSR' if $verbose;
	$le->load_csr($csr) == 0 or die "load_csr($csr) failed: " . $le->error_details . "\n";
	unless ($type eq 'none') {
		say STDERR 'requesting challenges' if $verbose;
		if ($le->request_challenge() != 0) {
			my $failed_domains = $le->failed_domains;
			my $msg;
			if (defined $failed_domains) {
				$msg = ' for ' . join(',', $le->failed_domains);
			} else {
				$msg = '';
			}
			die 'request_challenge() failed' . $msg . ': ' . $le->error_details . "\n";
		}
	}
	if ($type eq 'dns') {
		require Net::DNS;
		require Net::DNS::RR;
		require Net::DNS::Nameserver;

		$le->accept_challenge(\&dns_challenge_cb, {}, 'dns') == 0 or die "accept_challenge() failed: " . $le->error_details . "\n";
		if ($debug) {
			say STDERR 'DNS challenges:';
			say STDERR "\t", $_, ':', $challenges{$_} foreach sort keys %challenges;
		}
		if (%challenges) {
			say STDERR 'got DNS challenges for ', join ',', sort keys %challenges if $verbose;
			$verify_done = 0;
			my $thr = threads->create(\&resolver); $thr->detach;
			$le->verify_challenge(\&verify_cb, {}, 'dns') == 0 or die "verify_challenge() failed: " . $le->error_details . "\n";
			say STDERR 'DNS challenges done' if $verbose;
		} else {
			say STDERR 'got no DNS challenges' if $verbose;
		}
	} elsif ($type eq 'http') {
		require HTTP::Daemon;
		require HTTP::Request;
		require URI;
		require HTTP::Response;

		die "HTTP base $base not absolute\n" unless $base =~ m/^\//;
		$base .= '/' unless $base =~ m/\/$/;

		$le->accept_challenge(\&http_challenge_cb, {}, 'http') == 0 or die "accept_challenge() failed: " . $le->error_details . "\n";
		if ($debug) {
			say STDERR 'HTTP challenges:';
			say STDERR "\t", $http_hosts{$_}, ': ', $_, ' -> ', $challenges{$_} foreach sort keys %challenges;
		}
		if (%challenges) {
			say STDERR 'got HTTP challenges for ', join ',', sort values %http_hosts if $verbose;
			$verify_done = 0;
			my $thr = threads->create(\&httpd); $thr->detach;
			$le->verify_challenge(\&verify_cb, {}, 'http') == 0 or die "verify_challenge() failed: " . $le->error_details . "\n";
			say STDERR 'HTTP challenges done' if $verbose;
		} else {
			say STDERR 'got no HTTP challenges' if $verbose;
		}
	} elsif ($type eq 'none') {
		say STDERR 'EAB: no challenges' if $verbose;
	} else {
		die "unknown type $type\n";
	}
	return if $dryrun;
	say STDERR 'requesting certificate' if $verbose;
	$le->request_certificate() == 0 or die "request_certificate() failed: " . $le->error_details . "\n";
	say STDERR 'fetching certificate' if $verbose;
	my $cert = $le->certificate() or die "certificate() failed: " . $le->error_details . "\n";
	say $cert;
}

sub revoke {
	my ($cert) = @_;
	
	register();
	say STDERR 'revoking certificate' if $verbose;
	$le->revoke_certificate($cert) == 0 or die "revoke_certificate($cert) failed: " . $le->error_details . "\n";
}


# Hautprogramm
my $rc = 0;
eval {
	die "missing command\n" unless @ARGV;
	my $cmd = shift @ARGV;
	if ($cmd eq 'register') {
		die "missing email address\n" unless @ARGV;
		my $email = shift @ARGV;
		register($email);
	} elsif ($cmd =~ m/^(csr|request)$/) {
		die "missing CSR\n" unless @ARGV;
		request(shift @ARGV);
	} elsif ($cmd eq 'revoke') {
		die "missing certificate\n" unless @ARGV;
		revoke(shift @ARGV);
	} else {
		die "unknown command $cmd\n";
	}
	die 'extra args: ', join ',', @ARGV, "\n" if @ARGV;
	1; # damit man nicht ohne die in den or-Block läuft
} or do {
	chomp($@);
	say STDERR "$@";
	$rc = 1;
};

say STDERR 'OK' if $verbose and $rc == 0;
exit $rc;

=pod

=encoding utf8

=head1 NAME

L<acmechanic> - request certificates via ACME/DNS-01 or ACME/HTTP-01 by answering proxied request with a built-in DNS/HTTP server (or without challenges if EAB permits)

=head1 SYNOPSIS

acmechanic [-v] [-n] [-d] [-s] [-c F<configfile>] [-b I<config-block>] [-k F<keyfile>] [-t I<challenge-type>] [-D I<domain>] [-A I<acme-domain>] [-C I<CA>] [-U I<URL>] [-L I<addr>] [-P I<port>] [-I I<eab-key-id>] [-H I<eab-hmac-key>] register|request|revoke [I<args>]

=head1 DESCRIPTION

acmechanic requests certificates from a CA using the ACME/DNS-01 or ACME/HTTP-01 protocols. Contrary to common ACME clients, it does B<not> need to update the DNS zone files or deposit (HTTP-accesible) files on the servers it requests certificates for.

For ACME/DNS-01, it contains a dedicated Name Server to answer the challenges posed by the CA. It requires a set of C<CNAME>s on the main DNS server redirecting _acme-challenge.I<name>.I<domain> to I<name>.I<acme-domain> where I<acme-domain> has a C<NS> entry pointing to where C<acmechanic> is running on. These C<CNAME> Resource Records only need to be installed I<once> on the main DNS server and I<not> need to be updated when requesting a new certificate.

For ACME/HTTP-01, it contains a minature HTTP server to answer the challenges. It requires the real HTTP servers to forward/proxy requests for C</.well-known/acme-challenge/*> to the server acmechanic runs on. This proxy configuration only needs to be done I<once> on the HTTP servers and does I<not> need to be updated when requesting a new certificate.

In case the CAs C<EAB> (External Account Binding) permits, acmechanic can also request certificates with no ACME challenges at all.

=head1 OPTIONS

acmechanic understands the dollowing options:

=over 4

=item B<-v>

verbose mode. Report progess on STDERR.

=item B<-n>

dry-run mode. Do not actually request the certificate. Note that, unfortunately, acmechanic is currently unable to invalidate the challenges processed.

=item B<-d>

debugging mode. Print internal debugging information.

=item B<-s>

staging mode. Use the CA's staging server, if available.

=item B<-c> F<configfile>

read config from (C<INI>-style) F<configfile> instead of the default C<acmechanic.conf>. Supported keys are C<type>, C<keyfile>, C<(I<type>-)listen>, C<(I<type>-)port>, C<domain>, C<acme-domain>, C<ca>, C<url>, C<eab-key-id> and C<eab-hmac-key>.

=item B<-b> I<block>

use specified I<block> in F<configfile>.

=item B<-k> I<key>

use I<key> to identify (or register) with the CA.

=item B<-t> I<type>

use the given challenge-type (C<dns>, C<http> or C<none>).
If set to C<none>, acmechanic will I<not> request any challenges.
This assumes that the ACME key has been bound via I<External Account Binding> (C<EAB>) on registration to an identity that is authorized to request certificates without answering the corresponding challenges.

=item B<-C> I<CA>

use the specified CA.

=item B<-U> I<URL>

use the specified I<URL> for the directory handler on the ACME server. Overrides I<CA>.

=item B<-L> I<addr>

let the DNS/HTTP Server listen on the specified address.

=item B<-P> I<port>

let the DNS/HTTP Server listen on the specified port.

=item B<-D> I<domain>

(C<DNS-01> only) specify the DNS domain used in the CSR.
If omitted, strip all of the domain part from FQDNs.

=item B<-A> I<acme-domain>

(C<DNS-01> only) answer challenges for I<acme-domain> (the domain the main DNS server's C<_acme-challenge> C<CNAME>s point to.
If omitted, answer challenges for all domains.

=item B<-I> I<eab-key-id>

Use given I<Key Id> for C<EAB> (I<External Account Binding>). Used on first registration only.

=item B<-H> I<eab-hmac-key>

Use given I<HMAC Key> for C<EAB>. If starting with C<E<lt>>, treat the rest as a file name do read the key from. If this option is absent (but B<-I> or the C<eab-key-id> configuration option is present), use the environment variable C<EAB_HMAC_KEY> if present, otherwise prompt for the key. Used on first registration only.

=back

Note that, for C<DNS-01>, you need to specify both I<domain> and I<acme-domain> when requesting certificates for sub-domains. E.g., in order to get certificates for C<foo.one.example.com> and C<bar.two.example.com>, you would need to set I<domain> to C<example.com> and I<acme-domain> to C<acme.example.com> (or whatever the C<CNAME>s on your main DNS server point to).


=head1 COMMANDS

The recognized commands are:

=over 4

=item B<register> I<email>

register the key in I<keyfile> and the I<email> adress with the CA.

=item B<request|csr> I<CSR>

request a certificate based on I<CSR>.

=item B<revoke> I<certificate>

revoke a certificate.

=back

=head1 DEPENDENCIES

L<Config::Tiny>, L<Crypt::LE>, L<Term::ReadKey>, L<IO::Prompter>, L<Net::DNS>; L<Net::DNS::RR> and L<Net::DNS::Nameserver> for C<DNS-01>; L<HTTP::Daemon>, L<HTTP::Request>, L<URI> and L<HTTP::Response> for C<HTTP-01>.

=head1 AUTHOR

Edgar Fuß, Mathematisches Institut der Universität Bonn <ef@math.uni-bonn.de>

=head1 LICENSE

This script may be redistributed and/or modified unter the same terms as Perl itself or under a 2-clause BSD licence.

=cut