# This file is part of Acmepl
#
# Acmepl is 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/>.
#
# Copyright (C) 2016 - 2017 Raphaël Gertz <acmepl@rapsys.eu>

# acme package
package acme;

# Best practice
use strict;
use warnings;

# Symbol export
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(DS CERT_DIR KEY_DIR REQUEST_CSR ACCOUNT_KEY SERVER_KEY SERVER_CRT CONFIG);

# Load dependancies
use Carp qw(carp confess);
use Date::Parse qw(str2time);
use Digest::SHA qw(sha256_base64);
use Email::Valid;
use File::Path qw(make_path);
use File::Slurp qw(read_file write_file);
use File::Temp; # qw( :seekable );
use IPC::System::Simple qw(capturex);
use JSON qw(from_json to_json);
use LWP;
use MIME::Base64 qw(encode_base64url encode_base64);
use Net::Domain::TLD;
use POSIX qw(EXIT_FAILURE);
use Tie::IxHash;

# Documentation links
#XXX: see https://letsencrypt.github.io/acme-spec/ (probably based on https://ietf-wg-acme.github.io/acme/)
#XXX: see jwk rfc http://www.rfc-editor.org/rfc/rfc7517.txt
#XXX: see javascript implementation https://github.com/diafygi/gethttpsforfree/blob/gh-pages/js/index.js

# Set constants
use constant {
	# Directory separator
	DS => '/',

	# Directory for certificates
	CERT_DIR => 'cert',

	# Directory for keys
	KEY_DIR => 'key',

	# Directory for pending cache
	PENDING_DIR => 'pending',

	# Request certificate file name
	REQUEST_CSR => 'request.der',

	# Account key file name
	ACCOUNT_KEY => 'account.pem',

	# Server private key
	SERVER_KEY => 'server.pem',

	# Server public certificate
	SERVER_CRT => 'server.crt',

	# rsa
	KEY_TYPE => 'rsa',

	# 2048|4096
	KEY_SIZE => 4096,

	# Acme infos
	ACME_CERT => 'https://letsencrypt.org/certs/lets-encrypt-x3-cross-signed.pem',
	ACME_DIR => 'https://acme-staging.api.letsencrypt.org/directory',
	ACME_PROD_DIR => 'https://acme-v01.api.letsencrypt.org/directory',
	ACME_TERMS => 'https://letsencrypt.org/documents/LE-SA-v1.1.1-August-1-2016.pdf',

	# Version
	VERSION => 'v0.6',

	# Config
	CONFIG => '/etc/acmepl/config'
};

# User agent object
our $ua;

# Strerr backup
our $_stderr;

# JSON Web Key (JWK)
#XXX: tie to Tie::IxHash to keep a stable ordering of hash keys
#our %jwk = (
#	pubkey => undef,
#	jwk => {
#		alg => 'RS256',
#		jwk => {
#			# Exponent
#			e => undef,
#			# Key type
#			kty => uc(KEY_TYPE),
#			# Modulus
#			n => undef
#		}
#	},
#	thumbprint => undef
#);
tie(our %jwk, 'Tie::IxHash', pubkey => undef, jwk => undef, thumbprint => undef);
tie(%{$jwk{jwk}}, 'Tie::IxHash', alg => 'RS256', jwk => undef);
#XXX: strict ordering only really needed here for thumbprint sha256 digest
tie(%{$jwk{jwk}{jwk}}, 'Tie::IxHash', e => undef, kty => uc(KEY_TYPE), n => undef);

# Constructor
sub new {
	# Extract params
	my ($class, $mail, $debug, $prod, @domains) = @_;

	# Create self hash
	my $self = {};

	# Link self to package
	bless($self, $class);

	# Save debug
	$self->{debug} = $debug;

	# Save prod
	$self->{prod} = $prod;

	# Add extra check to mail validity
	#XXX: mxcheck fail if there is only a A record on the domain
	my $ev = Email::Valid->new(-fqdn => 1, -tldcheck => 1, -mxcheck => 1);

	# Show error if check fail
	if (! defined $ev->address($mail)) {
		map { carp 'failed check: '.$_ if ($self->{debug}) } $ev->details();
		confess 'Email::Valid->address failed';
	}

	# Save mail
	$self->{mail} = $mail;

	# Create resolver
	my $res = new Net::DNS::Resolver();

	# Check domains
	map {
		my $tld;

		# Extract tld
		unless (($tld) = $_ =~ m/\.(\w+)$/) {
			confess $_.'\'s tld extraction failed';
		}

		# Check if tld exists
		unless(Net::Domain::TLD::tld_exists($tld)) {
			confess $tld.' tld from '.$_.' don\'t exists';
		}

		# Check if we get dns answer
		#XXX: only search A type because letsencrypt don't support ipv6 (AAAA) yet
		unless(my $rep = $res->search($_, 'A')) {
			confess 'search A record for '.$_.' failed';
		} else {
			unless (scalar map { $_->type eq 'A' ? 1 : (); } $rep->answer) {
				confess 'search recursively A record for '.$_.' failed';
			}
		}
	} @domains;

	# Save domains
	@{$self->{domains}} = @domains;

	# Return class reference
	return $self;
}

# Prepare environement
sub prepare {
	my ($self) = @_;

	# Create all paths
	make_path(CERT_DIR, KEY_DIR, PENDING_DIR.'/'.$self->{mail}.'.'.($self->{prod} ? 'prod' : 'staging'), {error => \my $err});
	if (@$err) {
		map {
			my ($file, $msg) = %$_;
			carp ($file eq '' ? '' : $file.': ').$msg if ($self->{debug});
		} @$err;
		confess 'make_path failed';
	}

	# Create user agent
	$ua = LWP::UserAgent->new;
	$ua->agent(__PACKAGE__.'/'.VERSION)
}

# Drop stderr
sub _dropStdErr {
	# Save stderr
	open($_stderr, '>&STDERR') or die $!;
	# Close it
	close(STDERR) or die $!;
	# Send to /dev/null
	open(STDERR, '>', '/dev/null') or die $!;
}

# Restore stderr
sub _restoreStdErr {
	# Close stderr
	close(STDERR);
	# Open it back
	open(STDERR, '>&', $_stderr) or die $!;
}

# Generate required keys
sub genKeys {
	my ($self) = @_;

	# Generate account and server key if required
	map {
		# Check key existence
		if (! -f $_) {
			# Drop stderr
			_dropStdErr();
			# Generate key
			#XXX: we drop stderr here because openssl can't be quiet on this command
			capturex('openssl', ('genrsa', '-out', $_, KEY_SIZE));
			# Restore stderr
			_restoreStdErr();
		}
	} (KEY_DIR.DS.ACCOUNT_KEY, KEY_DIR.DS.SERVER_KEY);

	# Extract modulus and publicExponent jwk
	#XXX: same here we tie to keep ordering
	tie(%{$self->{account}}, 'Tie::IxHash', %jwk);
	map {
		if (/^Modulus=([0-9A-F]+)$/) {
			# Extract to binary from hex and convert to base64 url
			$self->{account}{jwk}{jwk}{n} = encode_base64url(pack("H*", $1) =~ s/^\0+//r);
		} elsif (/^publicExponent:\s([0-9]+)\s\(0x[0-1]+\)$/) {
			# Extract to binary from int, trim leading zeros and convert to base64 url
			chomp ($self->{account}{jwk}{jwk}{e} = encode_base64url(pack("N", $1) =~ s/^\0+//r));
		}
	} capturex('openssl', ('rsa', '-text', '-in', KEY_DIR.DS.ACCOUNT_KEY, '-noout', '-modulus'));

	# Drop stderr
	_dropStdErr();
	# Extract account public key
	$self->{account}{pubkey} = join('', map { chomp; $_; } capturex('openssl', ('rsa', '-in', KEY_DIR.DS.ACCOUNT_KEY, '-pubout')));
	# Restore stderr
	_restoreStdErr();

	# Store thumbprint
	#XXX: convert base64 to base64 url
	$self->{account}{thumbprint} = (sha256_base64(to_json($self->{account}{jwk}{jwk})) =~ s/=+\z//r) =~ tr[+/][-_]r;
}

# Generate certificate request
sub genCsr {
	my ($self) = @_;

	# Openssl config template
	my $oct = File::Temp->new();

	# Load template from data
	map { s/__EMAIL_ADDRESS__/$self->{mail}/; s/__COMMON_NAME__/$self->{domains}[0]/; print $oct $_; } <DATA>;

	# Close data
	close(DATA);

	# Append domain names
	my $i = 1;
	map { print $oct 'DNS.'.$i++.' = '.$_."\n"; } @{$self->{domains}};

	# Generate csr
	capturex('openssl', ('req', '-new', '-outform', 'DER', '-key', KEY_DIR.DS.SERVER_KEY, '-config', $oct->filename, '-out', CERT_DIR.DS.REQUEST_CSR));

	# Close oct
	close($oct);
}

# Directory call
sub directory {
	my ($self) = @_;

	# Set time
	my $time = time;

	# Set directory
	my $dir = $self->{prod} ? ACME_PROD_DIR : ACME_DIR;

	# Create a request
	my $req = HTTP::Request->new(GET => $dir.'?'.$time);

	# Get request
	my $res = $ua->request($req);

	# Handle error
	unless ($res->is_success) {
		confess 'GET '.$dir.'?'.$time.' failed: '.$res->status_line;
	}

	# Save nonce
	$self->{nonce} = $res->headers->{'replay-nonce'};

	# Merge uris in self content
	%$self = (%$self, %{from_json($res->content)});
}

# Post request
sub _post {
	my ($self, $uri, $payload) = @_;

	# Protected field
	my $protected = encode_base64url(to_json({nonce => $self->{nonce}}));

	# Payload field
	$payload = encode_base64url(to_json($payload));

	# Sign temp file
	my $stf = File::Temp->new();

	# Append protect.payload to stf
	print $stf $protected.'.'.$payload;

	# Close stf
	close($stf);

	# Generate digest of stf
	my $signature = encode_base64url(join('', capturex('openssl', ('dgst', '-sha256', '-binary', '-sign', KEY_DIR.DS.ACCOUNT_KEY, $stf->filename))) =~ s/^\0+//r);

	# Create a request
	my $req = HTTP::Request->new(POST => $uri);
	
	# Set new-reg request content
	$req->content(to_json({
		header => $self->{account}{jwk},
		protected => $protected,
		payload => $payload,
		signature => $signature
	}));

	# Post request
	my $res = $ua->request($req);

	# Save nonce
	if (defined $res->headers->{'replay-nonce'}) {
		$self->{nonce} = $res->headers->{'replay-nonce'};
	}

	# Return res object
	return $res;
}

# Resolve dns and check content
#XXX: see https://community.centminmod.com/threads/looks-like-letsencrypt-dns-01-is-ready.5845/#12 for example
sub _dnsCheck {
	my ($self, $domain, $token) = @_;

	# Generate signature from content
	my $signature = ((sha256_base64($token.'.'.$self->{account}{thumbprint})) =~ s/=+\z//r) =~ tr[+/][-_]r;

	# Fix domain
	$domain = '_acme-challenge.'.$domain.'.';

	# Create resolver
	my $res = new Net::DNS::Resolver();

	# Check if we get dns answer
	unless(my $rep = $res->search($domain, 'TXT')) {
		carp 'TXT record search for '.$domain.' failed' if ($self->{debug});
		return;
	} else {
		unless (scalar map { $_->type eq 'TXT' && $_->txtdata =~ /^$signature$/ ? 1 : (); } $rep->answer) {
			carp 'TXT record recursive search for '.$domain.' failed' if ($self->{debug});
			return;
		}
	}

	return 1;
}

# Get uri and check content
sub _httpCheck {
	my ($self, $domain, $token) = @_;

	# Create a request
	my $req = HTTP::Request->new(GET => 'http://'.$domain.'/.well-known/acme-challenge/'.$token);

	# Load config if available
	my $config = undef;
	if (
		#XXX: use eval to workaround a fatal in from_json
		defined eval {
			# Check that file exists
			-f CONFIG &&
			# Read it
			($config = read_file(CONFIG)) &&
			# Decode it
			($config = from_json($config)) &&
			# Check defined
			$config->{thumbprint}
		}
	) {
		# Try to write thumbprint
		write_file($config->{thumbprint}, $self->{account}{thumbprint});
	}

	# Get request
	my $res = $ua->request($req);

	# Handle error
	unless ($res->is_success) {
		carp 'GET http://'.$domain.'/.well-known/acme-challenge/'.$token.' failed: '.$res->status_line if ($self->{debug});
		return;
	}

	# Handle invalid content
	unless($res->content =~ /^$token.$self->{account}{thumbprint}\s*$/) {
		carp 'GET http://'.$domain.'/.well-known/acme-challenge/'.$token.' content match failed: /^'.$token.'.'.$self->{account}{thumbprint}.'\s*$/ !~ '.$res->content if ($self->{debug});
		return;
	}

	# Return success
	return 1;
}

# Register account
#XXX: see doc at https://ietf-wg-acme.github.io/acme/#rfc.section.6.3
sub register {
	my ($self) = @_;

	# Post new-reg request
	#XXX: contact array may contain a tel:+33612345678 for example
	my $res = $self->_post($self->{'new-reg'}, {resource => 'new-reg', contact => ['mailto:'.$self->{mail}], agreement => ACME_TERMS});

	# Handle error
	unless ($res->is_success || $res->code eq 409) {
		confess 'POST '.$self->{'new-reg'}.' failed: '.$res->status_line;
	}

	# Update mail informations
	if ($res->code eq 409) {
		# Save registration uri
		$self->{'reg'} = $res->headers->{location};

		# Post reg request
		#XXX: contact array may contain a tel:+33612345678 for example
		$res = $self->_post($self->{'reg'}, {resource => 'reg', contact => ['mailto:'.$self->{mail}]});

		# Handle error
		unless ($res->is_success) {
			confess 'POST '.$self->{'reg'}.' failed: '.$res->status_line;
		}
	}
}

# Authorize domains
sub authorize {
	my ($self) = @_;

	# Create challenges hash
	%{$self->{challenges}} = ();

	# Pending list
	my @pending = ();

	# Create or load auth request for each domain
	map {
		# Init content
		my $content = undef;

		# Init file
		my $file = PENDING_DIR.'/'.$self->{mail}.'.'.($self->{prod} ? 'prod' : 'staging').'/'.$_;

		# Load auth request content or post a new one
		#TODO: add more check on cache file ???
		if (
			#XXX: use eval to workaround a fatal in from_json
			! defined eval {
				# Check that file exists
				-f $file &&
				# Read it
				($content = read_file($file)) &&
				# Decode it
				($content = from_json($content))
			# Check expiration
			} || (str2time($content->{expires}) <= time()+3600)
		) {
			# Post new-authz request
			my $res = $self->_post($self->{'new-authz'}, {resource => 'new-authz', identifier => {type => 'dns', value => $_}, existing => 'accept'});

			# Handle error
			unless ($res->is_success) {
				confess 'POST '.$self->{'new-authz'}.' for '.$_.' failed: '.$res->status_line;
			}

			# Decode content
			$content = from_json($res->content);

			# Check domain
			unless (defined $content->{identifier}{value} && $content->{identifier}{value} eq $_) {
				confess 'domain matching '.$content->{identifier}{value}.' for '.$_.' failed: '.$res->status_line;
			}

			# Check status
			unless ($content->{status} eq 'valid' or $content->{status} eq 'pending') {
				confess 'POST '.$self->{'new-authz'}.' for '.$_.' failed: '.$res->status_line;
			}

			# Write to file
			write_file($file, to_json($content));
		}

		# Add challenge
		%{$self->{challenges}{$_}} = (
			status => $content->{status},
			expires => $content->{expires},
			polls => []
		);

		# Save pending data
		if ($content->{status} eq 'pending') {
			# Extract validation data
			foreach my $challenge (@{$content->{challenges}}) {
				# One test already validated this auth request
				if ($self->{challenges}{$_}{status} eq 'valid') {
					next;
				} elsif ($challenge->{status} eq 'valid') {
					$self->{challenges}{$_}{status} = $challenge->{status};
					next;
				} elsif ($challenge->{status} eq 'pending') {
					# Handle check
					if (
						($challenge->{type} =~ /^http-01$/ and $self->_httpCheck($_, $challenge->{token})) or
						($challenge->{type} =~ /^dns-01$/ and $self->_dnsCheck($_, $challenge->{token}))
					) {
						# Post challenge request
						my $res = $self->_post($challenge->{uri}, {resource => 'challenge', keyAuthorization => $challenge->{token}.'.'.$self->{account}{thumbprint}});

						# Handle error
						unless ($res->is_success) {
							confess 'POST '.$challenge->{uri}.' failed: '.$res->status_line;
						}

						# Extract content
						my $content = from_json($res->content);

						# Save if valid
						if ($content->{status} eq 'valid') {
							$self->{challenges}{$_}{status} = $content->{status};
						# Check is still polling
						} elsif ($content->{status} eq 'pending') {
							# Add to poll list for later use
							push(@{$self->{challenges}{$_}{polls}}, {
								type => (split(/-/, $challenge->{type}))[0],
								status => $content->{status},
								poll => $content->{uri}
							});
						}
					}
				}
			}
			# Check if check is challenge still in pending and no polls
			if ($self->{challenges}{$_}{status} eq 'pending' && scalar @{$self->{challenges}{$_}{polls}} == 0) {
				# Loop on all remaining challenges
				foreach my $challenge (@{$content->{challenges}}) {
					# Display help for http-01 check
					if ($challenge->{type} eq 'http-01') {
						print STDERR 'Create URI http://'.$_.'/.well-known/acme-challenge/'.$challenge->{token}.' with content '.$challenge->{token}.'.'.$self->{account}{thumbprint}."\n";
					# Display help for dns-01 check
					} elsif ($challenge->{type} eq 'dns-01') {
						print STDERR 'Create TXT record _acme-challenge.'.$_.'. with value '.(((sha256_base64($challenge->{token}.'.'.$self->{account}{thumbprint})) =~ s/=+\z//r) =~ tr[+/][-_]r)."\n";
					}
				}
			}
		}
	} @{$self->{domains}};

	# Init max run
	my $remaining = 10;

	# Poll pending
	while (--$remaining >= 0 and scalar map { $_->{status} eq 'valid' ? 1 : (); } values %{$self->{challenges}}) {
		# Sleep
		sleep(1);
		# Poll remaining pending
		map {
			# Init domain
			my $domain = $_;

			# Poll remaining polls
			map {
				# Create a request
				my $req = HTTP::Request->new(GET => $_->{poll});

				# Get request
				my $res = $ua->request($req);

				# Handle error
				unless ($res->is_success) {
					carp 'GET '.$self->{challenges}{$_}{http_challenge}.' failed: '.$res->status_line if ($self->{debug});
				}

				# Extract content
				my $content = from_json($res->content);

				# Save status
				if ($content->{status} ne 'pending') {
					$self->{challenges}{$domain}{status} = $content->{status};
				}
			} @{$self->{challenges}{$_}{polls}};
		} map { $self->{challenges}{$_}{status} eq 'pending' ? $_ : (); } keys %{$self->{challenges}};
	} 

	# Load config if available
	my $config = undef;
	if (
		#XXX: use eval to workaround a fatal in from_json
		defined eval {
			# Check that file exists
			-f CONFIG &&
			# Read it
			($config = read_file(CONFIG)) &&
			# Decode it
			($config = from_json($config)) &&
			# Check defined
			$config->{thumbprint}
		}
	) {
		# Try to write thumbprint
		write_file($config->{thumbprint}, '');
	}

	# Stop here with remaining chanllenge
	if (scalar map { ! defined $_->{status} or $_->{status} ne 'valid' ? 1 : (); } values %{$self->{challenges}}) {
		# Deactivate all activated domains 
		#XXX: not implemented by letsencrypt
		#map {
		#	# Post deactivation request
		#	my $res = $self->_post($self->{challenges}{$_}{http_uri}, {resource => 'authz', status => 'deactivated'});
		#	# Handle error
		#	unless ($res->is_success) {
		#		confess 'POST '.$self->{challenges}{$_}{http_uri}.' failed: '.$res->status_line;
		#	}
		#} map { $self->{challenges}{$_}{status} eq 'valid' ? $_ : () } keys %{$self->{challenges}};

		# Stop here as a domain of csr list failed authorization
		if ($self->{debug}) {
			my @domains = map { ! defined $self->{challenges}{$_}{status} or $self->{challenges}{$_}{status} ne 'valid' ? $_ : (); } keys %{$self->{challenges}};
			confess 'Fix the challenge'.(scalar @domains > 1?'s':'').' for domain'.(scalar @domains > 1?'s':'').': '.join(', ', @domains);
		} else {
			exit EXIT_FAILURE;
		}
	}
}

# Issue certificate
sub issue {
	my ($self) = @_;

	# Open csr file
	open(my $fh, '<', CERT_DIR.DS.REQUEST_CSR) or die $!;

	# Load csr
	my $csr = encode_base64url(join('', <$fh>) =~ s/^\0+//r);

	# Close csr file
	close($fh) or die $!;

	# Post certificate request
	my $res = $self->_post($self->{'new-cert'}, {resource => 'new-cert', csr => $csr});

	# Handle error
	unless ($res->is_success) {
		confess 'POST '.$self->{'new-cert'}.' failed: '.$res->status_line;
	}

	# Open crt file
	open($fh, '>', CERT_DIR.DS.SERVER_CRT) or die $!;

	# Convert to pem
	print $fh '-----BEGIN CERTIFICATE-----'."\n".encode_base64($res->content).'-----END CERTIFICATE-----'."\n";

	# Create a request
	my $req = HTTP::Request->new(GET => ACME_CERT);

	# Get request
	$res = $ua->request($req);

	# Handle error
	unless ($res->is_success) {
		carp 'GET '.ACME_CERT.' failed: '.$res->status_line if ($self->{debug});
	}

	# Append content
	print $fh $res->content;

	# Close file
	close($fh) or die $!;

	# Print success
	carp 'Success, pem certificate in '.CERT_DIR.DS.SERVER_CRT if ($self->{debug});
}

1;

__DATA__
#
# OpenSSL configuration file.
# This is mostly being used for generation of certificate requests.
#

[ req ]
default_bits		= 2048
default_md		= sha256
prompt			= no
distinguished_name	= req_distinguished_name
# The extentions to add to the self signed cert
x509_extensions	= v3_ca
# The extensions to add to a certificate request
req_extensions = v3_req

# This sets a mask for permitted string types. There are several options. 
# utf8only: only UTF8Strings (PKIX recommendation after 2004).
# WARNING: ancient versions of Netscape crash on BMPStrings or UTF8Strings.
string_mask = utf8only

[ req_distinguished_name ]
countryName			= US
stateOrProvinceName		= State or Province Name
localityName			= Locality Name
organizationName		= Organization Name
organizationalUnitName		= Organizational Unit Name
commonName			= __COMMON_NAME__
emailAddress			= __EMAIL_ADDRESS__

[ v3_req ]
basicConstraints = CA:false
keyUsage = nonRepudiation, digitalSignature, keyEncipherment
subjectAltName = email:move
subjectAltName = @alt_names

[ v3_ca ]
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid:always,issuer
basicConstraints = CA:true

[alt_names]