#!/usr/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 Encode::Locale;

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

use LWP::UserAgent;
use HTTP::Request;
use HTTP::Request::Common;
use HTTP::Response;
use HTTP::Cookies;
use HTML::Parser;
use JSON;
use Crypt::PKCS10;

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('nvdu:p:b:XY:', \%options) or die "invalid options\n";

my $dryrun = $options{n};
my $verbose = $options{v};
my $debug = $options{d};
my $base_url;
$base_url = $options{b} // 'https://cm.harica.gr/';
$base_url .= '/' unless $base_url =~ m./$.;
my $api_url = $base_url . 'api';

my $ua = LWP::UserAgent->new;
$ua->env_proxy;
$ua->ssl_opts(verify_hostname => 0) if $options{X};
$ua->ssl_opts(SSL_ca_file => $options{Y}) if $options{Y};
my $cookie_jar = HTTP::Cookies->new;
$ua->cookie_jar($cookie_jar);
my $token;
my $auth;

sub run_req {
	my ($msg, $req, $follow_redir, $dry) = @_;

	print STDERR "$msg: req:", Dumper($req) if $debug;
	return if $dry;
	my $res = $follow_redir ? $ua->request($req) : $ua->simple_request($req);
	print STDERR "$msg: res:", Dumper($res) if $debug;
	die "$msg failed: " . $res->code . ' ' . $res->message . "\n" unless $res->is_success;
	return $res;
}

# Irgendwas aus der Wunderwelt von ASP.NET:
# Um das Token, das man anschließend im Header unter RequestVerificationToken angeben muß, zu bekommen, muß man einen GET auf die Basis-URL machen, dort das (erste) input-Tag suchen, dessen name-Attribut '__RequestVerificationToken' ist, und dessen value-Attribut nehmen.
# Außerdem soll man das laut Doku noch als Wert eines 'HARICA'-Cookies setzen, aber da man sowieso alle anderen Cookies übernehmen muß und das dort offenbar schon gesetzt ist, erübrigt sich das.
sub get_token {
	my ($req, $res);
	$req = HTTP::Request->new(GET => $base_url);
	set_auth($req) if $auth;
	$res = run_req('get_token', $req, 1);
	my $p = HTML::Parser->new();
	my $t;
	$p->handler(start => sub {
		my ($self, $tagname, $attr) = @_;
		if ($tagname eq 'input' and $attr->{name} eq '__RequestVerificationToken') {
			die "no value\n" unless exists $attr->{value};
			$t = $attr->{value};
			$self->eof;
		}
	}, 'self, tagname, attr');
	$p->report_tags(qw/input/);
	$p->parse($res->decoded_content);
	return $t;
}

sub set_token {
	my ($r) = @_;
	die "no token to set\n" unless $token;
	$r->header('RequestVerificationToken' => $token);
}

sub set_auth {
	my ($r) = @_;
	die "no auth to set\n" unless $auth;
	$r->header('Authorization' => $auth);
}

sub set_json {
	my ($r) = @_;
	$r->content_type('application/json;charset=utf-8');
}

# Authentifizierungs-Token beschaffen
sub get_auth {
	my ($user, $password);

	my ($ttyin, $ttyout);
	unless ($options{u} and $options{p}) {
		open($ttyin, '<', '/dev/tty') or die "ttyin: $!\n";
		open($ttyout, '>', '/dev/tty') or die "ttyout: $!\n";
	}
	if ($options{u}) {
		$user = $options{u};
	} else {
		$user = prompt('User: ', -v, -in => $ttyin, -out => $ttyout);
	}
	if ($options{p}) {
		$password = $options{p};
	} else {
		$password = prompt('Password: ', -v, -in => $ttyin, -out => $ttyout, -echo => '*');
	}
	unless ($options{u} and $options{p}) {
		close($ttyin);
		close($ttyout);
	}

	my ($req, $res);
	$req = HTTP::Request->new(POST => "$api_url/User/Login");
	set_token($req);
	set_json($req);
	$req->content(encode_json({email => $user, password => $password}));
	$res = run_req('get_auth', $req);
	return $res->decoded_content();
}

sub logout {
	my $req = HTTP::Request->new(POST => "$api_url/User/SignOut");
	my $res = $ua->simple_request($req);
	die 'logout failed: ' . $res->code . ' ' . $res->message . "\n" unless $res->is_redirect;
}

sub login {
	$token = get_token();
	die "no token\n" unless $token;
	say STDERR 'got token' if $verbose;
	say STDERR "token=$token" if $debug;
	$auth = get_auth();
	die "no auth\n" unless $auth;
	say STDERR 'got auth' if $verbose;
	say STDERR "auth=$auth" if $debug;
	# Da wir noch nicht genügend viele Kekse, Tokens etc. gesammelt haben, nach der Authentifizierung nochmal:
	$token = get_token(); # nochmal mit auth
	say STDERR 'got token' if $verbose;
	say STDERR "token=$token" if $debug;
}

# Per API etwas machen, was möglichst gut approximiert, einen CSR einzuliefern.
# Aus dem CSR, den man am Ende übergibt, wird leider offenbar nur der modulus übernommen.
sub csr {
	my ($csr_name) = @_;
	my $csr_data;
	if ($csr_name) {
		open my $fh, '<', $csr_name or die "can't read CSR $csr_name: $!\n";
		$csr_data = do { local $/; <$fh> };
	} else {
		$csr_data = do { local $/; <> };
	}
	say STDERR "CSR Data: $csr_data" if $debug;
	Crypt::PKCS10->setAPIversion(1);
	my $csr = Crypt::PKCS10->new($csr_data) or die Crypt::PKCS10->error;
	print 'CSR:', $csr if $debug;
	my $cn = $csr->commonName();
	say 'CN:', $cn if $verbose;
	my @san = $csr->subjectAltName('dNSName');
	say STDERR 'SANs: ', join(',',@san) if $verbose;
	my @domains = map { domain => $_ }, @san;

	login unless $token;

	# Die Doku (äh) sagt, daß man alle seine ,,domains'' (sprich: SANs) angeben soll, um die dazugehörige Organisation herauszufinden.
	# Was man machen soll, wenn da mehrere Organisationen herauskommen, sagt man leider nicht.
	my ($req, $res, $json_out);
	$req = HTTP::Request->new(POST => "$api_url/ServerCertificate/CheckMachingOrganization");
	set_token($req);
	set_auth($req);
	set_json($req);
	$req->content(encode_json(\@domains));
	$res = run_req('get org', $req);
	$json_out = decode_json($res->decoded_content());
        print STDERR 'get org: json: ', Dumper($json_out) if $debug;
	die "no organizations\n" unless @{$json_out};
	die "multiple organizations\n" if @{$json_out} > 1;
	die "no org id\n" unless exists $json_out->[0]->{id};
	my %org = %{$json_out->[0]};
	print STDERR 'get org: org:', Dumper(\%org) if $debug;
	say STDERR "get org: id=$org{id}" if $verbose;

	# Kreativer Umgang mit Abkürzungen. Was man als id bekommt, muß man als OrganizationId zurückgeben. Hingegen muß man das, was man als OrganizationName bekommt, als O zurückgeben.
	# Und ja: organizationUnitName, nicht organizationalUnitName.
	my %org_map = (
		OrganizationId => 'id',
		C => 'country',
		ST => 'state',
		L => 'locality',
		O => 'organizationName',
		OU => 'organizationUnitName',
	);

	# Zur Arbeitserleichterung für kleine Blumenläden ist die vorgesehene Methode, um www.mein-kleiner-blumenladen.biz zu bekommen, als domain mein-kleiner-blumenladen.biz mit Option includeWWW (kostet nix extra!) anzugeben.
	# Leider darf ich nicht www.math.uni-bonn.de angeben, sondern muß math.uni-bonn.de mit includeWWW anfordern, obwohl ich weder math.uni-bonn.de als SAN haben will noch ein kleiner Blumenladen bin.
	my %www;
	foreach my $i (@domains) {
		my $domain = $i->{domain} or die "www: no domain\n";
		if ($domain =~ m/^www\.(.*)$/) {
			$www{$1} = 1;
		} else {
			$www{$domain} = 0 unless exists $www{$domain};
		}
	}
	if ($verbose) {
		say $www{$_} ? "www." : "    ", $_ foreach sort keys %www;
	}
	# Die nehmen offenbar den ersten Eintrag als CN.
	# Man kann mit dieser Logik weder reproduzieren, wenn der CN www.irgendwas ist, noch, wenn der CN nicht in den SANs vorkommt (was aber komisch wäre).
	my @www_domains;
	foreach my $domain ($cn, sort keys %www) {
		next if $domain eq $cn and @www_domains; # CN nicht weiter hinten nochmal reinschreiben
		my %i = ( domain => $domain );
		$i{includeWWW} = JSON::true if $www{$domain};
		push @www_domains, \%i;
	}
	print STDERR 'www_domains:', Dumper(\@www_domains) if $debug;

	# Natürlich brauchen auch große Blumenläden nie mehr als hundert SANs.
	say STDERR 'more than 100 SANs, will probably fail' if @www_domains > 100;

	# Die Magie mit form-data funktioniert nicht, wenn man HTTP::Reqest->new() und dann $req->content_type() macht.
	$req = HTTP::Request::Common::POST(
		"$api_url/ServerCertificate/RequestServerCertificate",
		Content_Type => 'form-data',
		Content => [
			friendlyName => $cn,
			domains => encode_json(\@www_domains),
			domainsString => encode_json(\@www_domains),
			duration => 1,
			csr => $csr_data,	# daraus wird offenbar nur der modulus übernommen
			isManualCSR => 'true',
			consentSameKey => 'true',
			transactionType => 'OV',
			organizationDN => join('&', map("$_:$org{$org_map{$_}}", keys %org_map)),
			# organizationDN => join('&', map("$_:$org{$org_map{$_}}", grep($org{$org_map{$_}},qw/OrganizationId C ST L O OU/))), # falls die Reihenfolge relevant ist und man keine leere Felder mitgeben darf
		]
	);
	set_token($req);
	set_auth($req);
	$res = run_req('request cert', $req, 0, $dryrun);
	return if $dryrun;
	$json_out = decode_json($res->decoded_content());
	die "no csr id\n" unless exists $json_out->{id};
	my $id = $json_out->{id};
	say "$id";
}

# Zertifikat abholen
# Die möglichen format-Werte sind die existierenden Key im JSON, das man bekommt: certificate (PEM), pKCS7 (PKCS#7) und pemBundle (PEM mit intermediate chain).
sub get {
	my ($id, $format, $stdout) = @_;
	$format //= 'certificate';

	login unless $token;

	my ($req, $res, $json_out);
	$req = HTTP::Request->new(POST => "$api_url/Certificate/GetCertificate");
	set_token($req);
	set_auth($req);
	set_json($req);
	$req->content(encode_json({ id => $id }));
	$res = run_req('get cert', $req);
	$json_out = decode_json($res->decoded_content());
        print STDERR 'get cert: json: ', Dumper($json_out) if $debug;
	die "get cert: no $format" unless $json_out->{$format};

	# Kreativität an der Shift-Taste (zusätzlich zu pKCS7): dN, sANS.
	# Weitere möglicherweise interessante Felder (es gibt noch mehr): keyType validFrom validTo revocationCode.
	if ($verbose) {
		foreach my $i ( [ friendlyName => 'name' ], [ serial => 'serial' ], [ dN => 'dn' ], [ sANS => 'SANs' ] ) {
			my ($key, $label) = $i->@*;
			say "$label: $json_out->{$key}" if exists $json_out->{$key};
		}
	}

	return if $dryrun;
	if ($stdout) {
		say STDOUT $json_out->{$format};
	} else {
		my $fn = $id;
		if ($format eq 'certificate') {
			$fn .= '.pem';
		} elsif ($format eq 'pKCS7') {
			$fn .= '.pkcs7';
		} elsif ($format eq 'pemBundle') {
			$fn .= '.pembundle';
		}
		open my $fh, '>', $fn or die "can't write output $fn: $!\n";
		say $fh $json_out->{$format};
		close $fh;
	}
}

# Anforderung zurückziehen. Sehr nützlich bei der Entwicklung dieses Skripts.
sub cancel {
	my ($id) = @_;

	login unless $token;

	return if $dryrun;
	my ($req, $res);
	$req = HTTP::Request->new(POST => "$api_url/Transaction/CancelTransaction");
	set_token($req);
	set_auth($req);
	set_json($req);
	$req->content(encode_json({ id => $id }));
	$res = run_req('cancel transaction', $req);
}

# Hautprogramm
my $rc = 0;
eval {
	die "missing command\n" unless @ARGV;
	my $cmd = shift @ARGV;
	if ($cmd eq 'test' or $cmd eq 'login') {
		login;
	} elsif ($cmd eq 'csr' or $cmd eq 'request') {
		if (@ARGV) {
			csr(shift @ARGV) while @ARGV;
		} else {
			csr(undef);
		}
	} elsif ($cmd =~ m/^(print|get)-(certificate|pem|pkcs7|pembundle|bundle)$/) {
		my $stdout = $1 eq 'print';
		my $format;
		if ($2 eq 'pem') {
			$format = 'certificate';
		} elsif ($2 eq 'bundle' or $2 eq 'pembundle') {
			$format = 'pemBundle';
		} elsif ($2 eq 'pkcs7') {
			$format="pKCS7";
		} else {
			$format = $2;
		}
		die "missing get ids\n" unless @ARGV;
		get(shift @ARGV, $format, $stdout) while @ARGV;
	} elsif ($cmd eq 'cancel') {
		die "missing cancel ids\n" unless @ARGV;
		cancel(shift @ARGV) while @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;
};

logout if $auth;

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

=pod

=encoding utf8

=head1 NAME

L<haricari> - minimal client for HARICA's API

=head1 SYNOPSIS

haricari [-v] [-n] [-d] [-u I<username>] [-p I<password>] [-b I<URL>] [-X] [-Y F<certbundle>] test|csr|(get|print)-I<format>|cancel [I<args>]

=head1 DESCRIPTION

haricari is a minimal client for HARICA's API. It currently supports uploading a CSR, downloading a certificate and canceling a request only.

=head1 OPTIONS

haricari understands the dollowing options:

=over 4

=item B<-v>

verbose mode. Print information on progess and SAN conversion.

=item B<-n>

dry-run mode. Don't actually send the final command.

=item B<-d>

debugging mode. Print internal debugging information.

=item B<-u> I<username>

use the specified username instead of prompting for it.

=item B<-p> I<password>

use the specified password instead of prompting for it (not recommended).

=item B<-b> I<URL>

use I<URL> as the base URL for the API instead of the default C<https://cm.harica.gr/>.

=item B<-X>

don't verify SSL certificate (for the https connection to the API, that is).

=item B<-Y> F<certbundle>

use F<certbundle> to verify the HTTPS connection to the API.

=back

=head1 COMMANDS

The recognized commands are:

=over 4

=item B<test|login>

test whether the login credentials work.

=item B<csr|request> F<csr> ...

read a PKCS#10 CSR from each F<csr> argument and, using the API, emulate something close to requesting a certificate based on the information therein.

Unfortunately, HARICA doesn't allow SANs starting with C<www.>, so in order to get a certificate for C<www.domain>, we need to request one for C<domain> and provide a C<includeWWW> option, which will include C<domain> in the SAN list. verbose mode shows what's actually requested.

Prints the transaction id(s) needed to fetch the certificate(s) after confirmation.

=item B<get-I<format>> I<id> ...

Download the certificates with the given I<id>s in I<format>.

the supported formats are:

=over 4

=item C<pem|certificate>

certificate only in PEM format

=item C<pkcs7>

PKCS#7 format

=item C<pembundle|bundle>

certificate bundle in PEM format

=back

The filename used is I<id>.I<ext>, where I<ext> is C<.pem> resp. C<.pkcs7> resp. C<.pembundle> for the I<format>s described above.

=item B<print-I<format>> I<id>

Same as B<get-I<format>>, but outputs to F<stdout> (one certificate only).

=item B<cancel> I<id> ...

cancel transactions (CSRs) with the given I<id>s.

=back

=head1 DEPENDENCIES

L<Term::ReadKey>, L<IO::Prompter>, L<LWP::UserAgent>, L<HTTP::Request>, L<HTTP::Request::Common>, L<HTTP::Response>, L<HTTP::Cookies>, L<HTML::Parser>, L<JSON>, L<Crypt::PKCS10>.

=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