#!/usr/bin/env perl
# vim: ts=4:sw=4:et
use warnings;
use strict;
use Authen::SASL;
use Getopt::Long qw(:config bundling no_ignore_case);
use JSON;
use MIME::Base64;
use Net::LDAP;
use Net::LDAP::Constant qw(
    LDAP_CONTROL_ASSERTION
    LDAP_CONTROL_POSTREAD
    LDAP_FEATURE_MODIFY_INCREMENT
);
use Net::LDAP::Control::Assertion;
use Net::LDAP::Control::PostRead;
use Net::LDAP::Util qw(
    escape_dn_value
    escape_filter_value
    time_to_generalizedTime
    generalizedTime_to_time
);
use Time::HiRes qw(usleep);

sub _debug { warn "debug: @_\n" if $ENV{DEBUG}; }
sub _die { die "fatal: @_\n"; }

sub ldap_read_attr {
    my ($conn, $dn, $attr) = @_;
    my $res;

    $res = $conn->search(base => $dn,
                         scope => "base",
                         filter => "(objectClass=*)",
                         attrs => [$attr]);
    ldap_check($res);

    if ($res->count > 0) {
        return $res->entry(0)->get_value($attr);
    } else {
        return undef;
    }
}

sub ldap_cas_attr {
    my ($conn, $dn, $attr, $old, $new) = @_;
    my $control = [];
    my $res;

    if ($old eq $new) {
        _debug("ignoring no-op update '$old' -> '$old'");
        return 1;
    }

    # optimization: RFC 4528 Assertion
    # (not sure if useful; perhaps if used with 'replace'?)

    if ($conn->root_dse->supported_control(LDAP_CONTROL_ASSERTION)) {
        _debug("using Assertion control");
        $control = [
            Net::LDAP::Control::Assertion->new("($attr=$old)"),
        ];
    }

    # atomically delete old value and add the new one
    #
    # (NOTE: actually not sure if LDAP *guarantees* atomicity within the same
    # Modify op, but if all clients cooperate, this should be good enough)

    $res = $conn->modify($dn,
        changes => [
            delete => [ $attr => $old ],
            add    => [ $attr => $new ],
        ],
        control => $control,
    );
    ldap_check($res, $dn, ["LDAP_NO_SUCH_ATTRIBUTE", "LDAP_ASSERTION_FAILED"]);

    return !$res->is_error;
}

sub ldap_increment_attr {
    my ($conn, $dn, $attr, $incr) = @_;
    $incr ||= 1;
    my $res;

    # optimization: RFC 4525 Modify-Increment + RFC 4527 Post-Read

    if ($conn->root_dse->supported_control(LDAP_CONTROL_POSTREAD)
        && $conn->root_dse->supported_feature(LDAP_FEATURE_MODIFY_INCREMENT))
    {
        _debug("using Modify-Increment extension");
        $res = $conn->modify($dn,
            increment => { $attr => $incr },
            control => [ Net::LDAP::Control::PostRead->new(attrs => [$attr]) ],
        );
        ldap_check($res);
        if ($res->control(LDAP_CONTROL_POSTREAD)) {
            return $res->control(LDAP_CONTROL_POSTREAD)->entry->get_value($attr);
        }
    }

    # manual compare-and-swap

    my $val;
    my $done = 0;
    my $wait = 0;
    _debug("unable to use Modify-Increment; using modify loop");
    until ($done) {
        _debug("fetching $attr");
        $val = ldap_read_attr($conn, $dn, $attr);
        _debug("fetched '$val', swapping");
        $done = ldap_cas_attr($conn, $dn, $attr, $val, $val+$incr);
        _debug($done ? "finished" : "retrying");
        if (!$done) {
            usleep(0.05 * 2**int(rand(++$wait)));
        }
    }
    return $val+$incr;
}

sub ldap_format_error {
    my ($res, $dn) = @_;

    my $text = "LDAP error: ".$res->error;
    utf8::decode($text);
    $text .= "\n * error code: ".$res->error_name if $::debug;
    $text .= "\n * failed entry: ".$dn            if $dn;
    $text .= "\n * matched entry: ".$res->dn      if $res->dn;
    my $i = 1;
    while ($::debug) {
        my ($pkg, $file, $line, $subr) = caller($i++);
        if (!$pkg) {
            last;
        }
        $text .= "\n * stack: $pkg | $file:$line | $subr";
    }
    return $text;
}

sub ldap_check {
    my ($res, $dn, $ignore) = @_;

    if (!$res->is_error) {
        return 1;
    }
    utf8::decode($dn) if $dn;
    if (ref $ignore eq 'ARRAY' && grep {$res->error_name eq $_} @$ignore) {
        return 0;
    }
    my $text = ldap_format_error($res, $dn);
    _die($text);
}

sub read_file {
    my ($path) = @_;
    my $buf;
    if (open(my $fh, "<", $path)) {
        $fh->read($buf, 64*1024);
        close($fh);
        return $buf;
    } else {
        _die("could not open '$path': $!");
    }
}

sub encode_pem {
    my ($buf) = @_;
    my $type = "CERTIFICATE";
    return "-----BEGIN $type-----\n"
        .encode_base64($buf)
        ."-----END $type-----\n";
}

sub decode_pem {
    my ($buf) = @_;
    if ($buf =~ /^-----BEGIN .+?-----\n(.+?)\n-----END .+?-----$/ms) {
        return decode_base64($1);
    }
}

my $action;
my %opt = (
    uri => undef,
    dn => undef,
    mech => "GSSAPI",

    serial => undef,
    attr => undef,
    value => undef,
);

GetOptions(
    "A|action=s" => \$action,
    "H|uri=s" => \$opt{uri},
    "b|dn=s" => \$opt{dn},
    "Y|mech=s" => \$opt{mech},
    "s|serial=s" => \$opt{serial},
    "a|attr=s" => \$opt{attr},
    "n|value=s" => \$opt{value},
) or exit(2);

$action or _die("action not specified");
$opt{uri} or _die("LDAP server URI not specified");
$opt{dn} or _die("LDAP base DN not specified");

_debug("connecting to '$opt{uri}'");
my $conn = Net::LDAP->new($opt{uri}) or die "$@";
my $sasl = Authen::SASL->new(mechanism => $opt{mech});

_debug("authenticating via SASL '$opt{mech}'");
ldap_check($conn->bind(sasl => $sasl));

if ($action eq "ping") {
    exit;
}

if ($action eq "increment") {
    $opt{attr} or _die("LDAP attribute name not specified");
    $opt{value} //= 1;

    _debug("incrementing attr '$opt{attr}' of entry '$opt{dn}'");
    my $value = ldap_increment_attr($conn, $opt{dn}, $opt{attr}, $opt{value});

    _debug("received value '$value'");
    print "$value\n";
    exit;
}

if ($action eq "publish-cert") {
    $opt{serial} or _die("serial number not specified");
    $opt{value} or _die("file name not specified");

    my $cert = read_file($opt{value});
    if ($cert =~ /^-----/) {
        $cert = decode_pem($cert);
    }

    my $dn = "serialNumber=".escape_dn_value($opt{serial}).",".$opt{dn};
    _debug("creating entry '$dn'");
    my $res = $conn->add($dn, attrs => [
        "objectClass" => ["pkiCertificate"],
        "userCertificate;binary" => [$cert],
    ]);
    ldap_check($res);
    exit;
}

if ($action eq "publish-crl") {
    $opt{value} or _die("file name not specified");

    my $crl = read_file($opt{value});
    if ($crl =~ /^-----/) {
        $crl = decode_pem($crl);
    }

    _debug("updating entry '$opt{dn}'");
    my $res = $conn->modify($opt{dn}, replace => {
        "certificateRevocationList;binary" => [$crl],
    });
    ldap_check($res);
    exit;
}

if ($action eq "revoke") {
    $opt{serial} or _die("serial number not specified");
    $opt{value} //= int time();

    my $serial = escape_filter_value($opt{serial});
    my $time = time_to_generalizedTime($opt{value});

    _debug("searching for certificates");
    my $res = $conn->search(base => $opt{dn},
                filter => "(&(objectClass=pkiCertificate)(serialNumber=$serial))",
                attrs => ["revocationTime"]);
    ldap_check($res);
    if ($res->count < 1) {
        _die("could not find any certificate with serialNumber=$serial");
    }
    if ($res->count > 1) {
        _die("found more than one certificate with serialNumber=$serial");
    }
    for my $entry ($res->entries) {
        _debug("updating entry '".$entry->dn."'");
        my $res = $conn->modify($entry->dn, add => {revocationTime => $time});
        ldap_check($res);
    }
    exit;
}

if ($action eq "list-revoked") {
    _debug("searching for revoked certificates");
    my $res = $conn->search(base => $opt{dn},
                filter => "(&(objectClass=pkiCertificate)(revocationTime=*))",
                attrs => ["*"]);

    my $output = [];
    for my $entry ($res->entries) {
        my $dn = $entry->dn;
        my $serial = $entry->get_value("serialNumber");
        if (!$serial || $serial !~ /^[0-9]+$/) {
            warn "entry '$dn' has bad serialNumber '$serial'\n";
            next;
        }
        my $cert = $entry->get_value("userCertificate;binary");
        if (!$cert) {
            warn "entry '$dn' is missing userCertificate;binary\n";
            next;
        }
        my $revoked = $entry->get_value("revocationTime");
        my $revoked_tm = generalizedTime_to_time($revoked);
        if (!$revoked || !$revoked_tm) {
            warn "entry '$dn' has bad revocationTime '$revoked'\n";
        }
        push @$output, {dn => $entry->dn,
                serial => $serial,
                cert => encode_pem($cert),
                revoked => int $revoked_tm};
    }

    print JSON->new->encode($output);
    exit;
}
_die("unknown mode '$action'");