#!/usr/bin/perl
#
# hn-user: the accounts of the fleet -- mail, calendar, address book and drive -- behind one
# command.
#
#   list   the accounts, their state and the addresses that reach them
#   add    a person: account, secret, mailbox, share, aliases
#   mod    an existing person: secret, state, aliases, share membership
#   del    a person, in two steps: disable (reversible) then purge (final, archived)
#   sync   reconciles what the store holds with what the accounts say
#   secret one password per device, beside the one of the person (ldap alone)
#   cert   the S/MIME certificates of a person, published in her entry (ldap alone)
#   admin  a person in or out of the administrators group of luminary (ldap alone); luminary
#          creates no account, this script is where a person and an administrator are made
#
# Two axes decide what each verb DOES, and both come from /etc/hn.conf, itself rendered from the
# repository variables of the mail role:
#
#   auth   credentials | masterpasswd | ldap   where the identity, the secret and the aliases live
#   store  cyrus | dovecot                     which mailboxes exist, which ACLs, which DAV
#
# Nothing here hardcodes either one. A verb that has no meaning under the configured value is a
# NO-OP with a line saying so, never an error: dovecot autocreates the INBOX at delivery and has
# neither Cyrus ACLs nor DAV collections, so `sync` has nothing to reconcile there.
#
# Aliases are the one place where the two branches differ in KIND rather than in detail. Under
# `ldap` the addresses are attributes of the person and the script writes them. Otherwise the
# table is rendered by ansible from host_vars/mail.yml, which this host does not own: the script
# PRINTS the lines to carry there and changes nothing. Editing /etc/mail/aliases in place would
# be undone by the next play.
#
# Run AS ROOT for add / mod / del / sync / admin (reads the 0400 passwords, writes the accounts).
# `list` runs as anyone, and says `?` where it lacks the privilege to know.
#
use strict;
use warnings;
use FindBin;
use lib $FindBin::Bin;
use IPC::Open2;
use File::Path qw(make_path);
use File::Temp qw(tempdir);
use MIME::Base64 qw(decode_base64 encode_base64);
use Digest::SHA qw(sha256_hex);
use Encode qw(decode);
use Unicode::Normalize qw(NFD);
use HnUser;

$| = 1;

# ------------------------------------------------------------------ the environment ----------
# Root runs this, and every tool below is named without a path: the PATH is the one of the
# system, never the caller's. curl reads <scheme>_proxy, ALL_PROXY and NO_PROXY in either case,
# and its curlrc under CURL_HOME [verifie:curl 8.22.0 docs/cmdline-opts/config.md, the curlrc
# search; docs/cmdline-opts/_ENVIRONMENT.md]: a proxy set in the shell of the operator would carry a
# password of the DAV requests elsewhere. The tests extract subs and never run these two lines,
# so their stubs on PATH keep working.
$ENV{PATH} = '/usr/bin:/bin:/usr/sbin:/sbin:/usr/local/bin:/usr/local/sbin';
delete @ENV{ grep { /_proxy\z/i || /\Acurl_home\z/i } keys %ENV };

my $MASTER  = '/etc/master.passwd';
# The two rendered tables, in the order a person appears in them. aliases_user holds what is
# reachable from OUTSIDE and is where a person lives; aliases holds what belongs to the machine
# -- the system block, the RFC 2142 roles, the service accounts of the __mail_aliases bus. Both
# are read, because "what reaches this login" is the union, and neither is written: ansible
# renders them from host_vars/mail.yml and the next play would undo any edit made here.
my @ALIASES = ('/etc/mail/aliases_user', '/etc/mail/aliases');
my $ARCHIVE = '/opt/var/archive/mail';

# Anti-spam Sieve installed on every account. Cyrus has NO global script applied at delivery --
# cyr_info conf-all knows only autocreate_sieve* (account creation alone) and the lmtpd binary
# carries no such symbol -- hence the account-by-account pass in `sync`.
my $SIEVE_SRC  = '/etc/cyrus/hn-spam.sieve';
my $SIEVE_NAME = 'hn-spam';

my $IMAP_HOST = 'localhost';
my $IMAP_PORT = 14300;
my $IMAP_ADMIN = '_cyrusadm';

# ---------------------------------------------------------------------------- usage ----------
sub usage {
    print <<'EOF';
Usage: hn-user <verb> [options]

  list                                   the accounts, their state, their addresses
  add    [--login L] [--given G] [--family F] [--alias a,b] [--share|--no-share]
  mod    <login> [--password] [--enable] [--disable]
                 [--alias +a,-b] [--share|--no-share]
  del    <login> --disable                lock the auth, keep the mailbox (reversible); its active
                                           sieve script is turned off, hn-spam as written here aside;
                                           under auth=ldap, out of the administrators of luminary
  del    <login> --purge                  archive the home then delete everything (final);
                                           refused under auth=ldap: --disable is the way there
  del    <login> --purge-system           archive the home, drop the system account alone --
                                           LDAP entry, mailbox and shares untouched (final).
                                           Reaches a login the account source does not hold,
                                           left behind by a migration, after one confirmation
  sync   [--reinvite]                     reconcile the store with the accounts
  secret add  <login> <device>            one more password, for that device alone (auth=ldap)
  secret del  <login> <device>            take it back
  secret list <login>                     the devices that hold one, name and id
  cert   add  <login> <file.pem> [--ca <ca.pem>]
                                         publish one more S/MIME certificate of the person (auth=ldap)
  cert   del  <login> [<sha256>]          take that one back; without a fingerprint, all of them
  cert   show <login>                     subject, issuer, address, expiry, sha256 of each one held
  admin  add  <login>                     into the administrators group of luminary (auth=ldap)
  admin  del  <login>                     out of it

Common: -h, --help. add/mod/del/sync, secret, cert add/del and admin need root. What is missing from
the command line is asked for; nothing needed is ever taken from argv when it is a password.
Under auth=ldap an alias is an address written into the entry: `--alias given.family` takes the
domain of /etc/hn.conf, `--alias given.family@other.tld` keeps the one it names. Under the other
auth axes it is a key of the table ansible renders, which the script prints rather than writes.
An alias keeps to [a-z0-9@.-]: anything else is refused, with the canonical form named. Its
local part is not empty and neither starts nor ends on a dot; a domain given is one of
/etc/mail/domains. An alias that already reaches another person is refused when given (add
--alias, mod); the alias derived from the names (alias_pattern) is skipped with a warning
instead, by add and by sync. Under auth=ldap mod refuses to remove <login>@<domain>.
add refuses a login over 31 bytes (<login>@<domain> counted under auth=ldap), anyone, anonymous,
the shared user of /etc/hn.conf, a login whose address already reaches someone, and a login whose
mailbox is still in the store with no account behind it.
`list` STATE: active, locked, nopass (empty master.passwd field: no password asked), devices
(auth=ldap: device secrets alone), `?` without the privilege to read it.
Under auth=ldap `list` and `secret list` name on stderr an entry carrying several userPassword
values no description claims, and `list` a registration whose value is gone.
Under auth=ldap a device secret is one more userPassword value of the entry, registered by a
description `hn-device: <device> <id>`; the device keeps to [a-z0-9-]. The secret is generated,
printed once, and never stored in clear. `mod --password` changes the password of the person and
leaves the devices alone; `del --disable` removes every value, devices included, and `secret add`
is refused until `mod --password` has given the person a password again.
Under auth=ldap every password written -- add, mod --password, secret add -- is hashed {ARGON2}
(argon2id) by slappasswd, its argon2 module loaded, the secret on its stdin; a value held in
another scheme ({SSHA}) keeps working until it is changed. slapd needs that module to bind them.
Under auth=ldap `cert add` reads a PEM file -- the certificate of the person, optionally followed
by its chain, LF or CRLF -- and adds one value to userCertificate;binary (DER) and one to
userSMIMECertificate (PKCS#7 of the leaf and the chain of the file; slapd refuses ;binary on that
attribute); a leaf given alone is published alone, the roots of smime_cas never. The
leaf must verify for S/MIME signing against the certificates of smime_cas, plus those of --ca (an
external CA trusted for this add alone), the chain of the file serving as intermediates. The
certificates already held stay. Refused: a file over 64 KiB or holding more than 10 certificates,
a subjectAltName entry other than rfc822Name, a control character in the subject or in
subjectAltName, no emailProtection usage, expired, no subjectAltName email that is an address of
the entry (one suffices), a certificate already published, no trust anchor at all, or a leaf that
does not verify (the reason of openssl given). A certificate is named by the sha256 of its DER, colons and case free. `list` shows the nearest
expiry in the column SMIME, `/<n>` behind it when n >= 2 certificates are held.
Under auth=ldap `admin` writes the login into memberUid of cn=<admins_group>,ou=groups,<suffix>
(admins_group of /etc/hn.conf, admins without it), what luminary reads at log-in: a member already
in, or already out, writes nothing. The person must be an account; the group must exist, made by
the setup wizard of luminary, which creates no account itself. A session of luminary already
open keeps what it was given at its log-in.
EOF
    exit 0;
}

my $verb = shift @ARGV // '';
usage() if $verb eq '' || $verb eq '-h' || $verb eq '--help';
usage() if grep { $_ eq '-h' || $_ eq '--help' } @ARGV;

# ------------------------------------------------------------------- small helpers -----------
sub ask {
    my ($prompt, $default) = @_;
    print $default ? "$prompt [$default] : " : "$prompt : ";
    my $a = <STDIN>;
    return $default unless defined $a;
    $a =~ s/^\s+|\s+$//g;
    return length($a) ? $a : ($default // '');
}

# A secret as typed: the line end goes, nothing else. A blank at either end is a character of the
# password, and trimming it would set a password other than the one typed -- the next login,
# blanks included, would then fail. ask() trims: a login or a name never means its blanks.
sub ask_raw {
    my ($prompt) = @_;
    print "$prompt : ";
    my $a = <STDIN>;
    return '' unless defined $a;
    $a =~ s/\r?\n\z//;
    return $a;
}

sub ask_secret {
    my ($prompt) = @_;
    # An interrupt between the two stty calls would leave the terminal without echo.
    local $SIG{INT} = sub { system('stty', 'echo'); print "\n"; exit 130; };
    system('stty', '-echo');
    my $a = ask_raw($prompt);
    print "\n";
    my $b = ask_raw('Confirm');
    print "\n";
    system('stty', 'echo');
    die "empty password\n" unless length $a;
    die "passwords differ\n" unless $a eq $b;
    return $a;
}

# lowercase, accents folded, and only what $keep allows through. The login keeps [a-z0-9]; an
# alias keeps the hyphen, the dot and the '@' too -- compound given names carry the first, the
# convention <given>.<family> the second, and an alias given on another domain the third.
# The input is BYTES -- what the terminal or argv handed over, UTF-8 on this fleet -- and is
# decoded before anything looks at it: a byte-wise fold sees two bytes per accented letter and
# turns "Berengere" with its accents into "baorenganre". NFD then splits each letter from its
# mark, and the marks go. Bytes that are not UTF-8 are taken as Latin-1 rather than refused.
# Some letters carry no decomposition at all -- o-slash, sharp s, ae, oe, l-stroke, d-stroke, thorn,
# dotless i, eth, h-stroke, eng, t-stroke, kra, the ligature ij, long s, l with middle dot,
# n preceded by apostrophe: NFD leaves each one whole, the last four having a compatibility
# decomposition alone, which NFD does not apply [verifie:perl 5.34 Unicode::Normalize 1.28 NFD,
# length 1 on each, 2026-10-11], and the strip would then drop the letter itself, "Strauss" with
# its sharp s turning into "straus" and "Lukasz" with its l-stroke into "ukasz". They are spelled
# out first, both cases, inside the sub: the tests run it extracted from this file.
sub fold {
    my ($s, $keep) = @_;
    my %tr = ("\x{f8}" => 'o', "\x{d8}" => 'O', "\x{df}" => 'ss', "\x{1e9e}" => 'SS',
              "\x{e6}" => 'ae', "\x{c6}" => 'AE', "\x{153}" => 'oe', "\x{152}" => 'OE',
              "\x{142}" => 'l', "\x{141}" => 'L', "\x{111}" => 'd', "\x{110}" => 'D',
              "\x{fe}" => 'th', "\x{de}" => 'TH', "\x{131}" => 'i', "\x{f0}" => 'd', "\x{d0}" => 'D',
              "\x{127}" => 'h', "\x{126}" => 'H', "\x{14b}" => 'n', "\x{14a}" => 'N',
              "\x{167}" => 't', "\x{166}" => 'T', "\x{138}" => 'k', "\x{133}" => 'ij', "\x{132}" => 'IJ',
              "\x{17f}" => 's', "\x{140}" => 'l', "\x{13f}" => 'L', "\x{149}" => 'n');
    $s //= '';
    $s = eval { decode('UTF-8', $s, Encode::FB_CROAK()) } // decode('iso-8859-1', $s);
    my $re = join '', keys %tr;
    $s =~ s/([$re])/$tr{$1}/g;
    $s = NFD(lc $s);
    $s =~ s/\p{Mn}//g;
    $s =~ s/[^$keep]//g;
    return $s;
}
sub slug       { return fold($_[0], 'a-z0-9'); }
# Suggested login: the initial of each given name, then the family name. The initial is taken
# AFTER the fold: the name arrives as bytes, and the first byte of a letter outside ASCII is half
# of it -- the lead byte of a UTF-8 o-slash alone reads as Latin-1 A-tilde, and folds to 'a'.
sub suggest_login {
    my ($given, $family) = @_;
    return join('', map { substr(slug($_), 0, 1) } grep { length } split /-/, $given) . slug($family);
}
# '@' before the dot, and the hyphen last: ".-@" inside the class would be the RANGE 0x2e-0x40,
# which swallows ':' and ';'.
sub slug_alias { return fold($_[0], 'a-z0-9@.-'); }

# An alias given on the command line is carried as it is typed, or not at all. Folding a hand
# written token puts in the table an address nobody chose -- `--alias JG` is not `jg`, and the
# operator reads the one and gets the other. The other writer of the attribute refuses the same
# token on the same fold and says the same word [roles/mail/files/migration/hn-ldap-import, sub aliases:
# "skipped (not canonical)"]: what one refuses, the other refuses.
# '+' stays outside the class: smtpd cuts the tag off the local part and looks up user@domain
# right after user+tag@domain, so a tagged address already reaches the account without an alias
# of its own [verifie:openbsd/src usr.sbin/smtpd/aliases.c, aliases_virtual_get ;
# smtpd-defines.h, SUBADDRESSING_DELIMITER "+"].
sub canonical_alias {
    my ($t, $removal) = @_;
    my $canon = slug_alias($t);
    die "not canonical  $t (canonical $canon) -- an alias keeps to [a-z0-9@.-]\n"
        if $canon ne $t;
    # A removal names a value already written, whatever its shape: refusing it would keep it.
    my $why = $removal ? undef : alias_shape_error($t);
    die "alias $t refused: $why\n" if defined $why;
    return $t;
}

sub split_list {
    my ($s) = @_;
    return () unless defined $s && length $s;
    return grep { length } map { s/^\s+|\s+$//gr } split /,/, $s;
}

# Options, in the one shape every verb here uses: --flag and --key value. Returns a hashref;
# anything not starting with `--` stays in @ARGV for the verb to read as a positional.
sub opts {
    my (%takes_value) = @_;
    my (%o, @rest);
    while (@ARGV) {
        my $a = shift @ARGV;
        if ($a =~ /^--(.+)\z/) {
            my $k = $1;
            $o{$k} = $takes_value{$k} ? (shift(@ARGV) // '') : 1;
        } else {
            push @rest, $a;
        }
    }
    @ARGV = @rest;
    return \%o;
}

sub need_root { die "run as root\n" if $>; }

# ------------------------------------------------------------------ the two axes -------------
my $CONF = HnUser::conf();
my $AUTH  = $CONF->{auth}  // 'masterpasswd';
my $STORE = $CONF->{store} // 'cyrus';

sub auth_is_system { return $AUTH eq 'masterpasswd'; }

# A verb that cannot act under the configured axis says so and stops, naming the axis. Not a
# warning: the caller asked for a change that will not happen.
sub unsupported {
    my ($what) = @_;
    die "auth=$AUTH: $what not implemented\n";
}

# ---------------------------------------------------------------------- the state ------------
# Whether an account can authenticate, under the system axes. Under `ldap` the entry says it:
# ldap_states(), in the secret block. The hash field is '*' when locked. getpwent(3) does NOT
# hand it over -- OpenBSD serves the shadowed entry only through getpwnam_shadow(3), which perl
# does not bind -- so the answer comes from master.passwd, readable by root alone. Anyone else
# gets '?', which is honest; guessing would not be.
sub locked_state {
    my %st;
    open(my $fh, '<', $MASTER) or return undef;
    while (<$fh>) {
        next if /^\s*#/;
        my @f = split /:/, $_, 10;
        next unless @f >= 2;
        # '*' alone is what secret_lock writes; usermod -Z keeps the hash and PREFIXES it with
        # '*' [verifie:man.openbsd.org/usermod.8, -Z]. Both refuse every password. An EMPTY field
        # is the opposite: "no password will be required to gain access to the machine"
        # [verifie:man.openbsd.org/master.passwd.5, the password field] -- its own state, never
        # shown as locked.
        $st{$f[0]} = $f[1] eq ''    ? 'nopass'
                   : $f[1] =~ /^\*/ ? 'locked'
                   :                  'active';
    }
    close $fh;
    return \%st;
}

# ------------------------------------------------------------------------ aliases ------------
# An alias is a FULL address, and this is the one place that decides it. A value already
# carrying an '@' names its own domain and passes through -- that is how an alias on one of the
# other domains of /etc/mail/domains is given; a bare local part takes the domain of hn.conf.
# The directory wants it that way: mailLocalAddress is the "RFC822 email address of this
# recipient" [verifie:openldap servers/slapd/schema/misc.schema, inetLocalMailRecipient], and
# smtpd finds "user@domain" at the second of its six tries on a virtual table
# [verifie:openbsd/src usr.sbin/smtpd/aliases.c, aliases_virtual_get].
# The template renders the key domain under `mail_cyrus_virtual` alone
# [roles/mail/templates/etc_hn.conf.j2, {% if mail_cyrus_virtual | d(true) %}], so it can be
# missing. Under `ldap` a bare value then STOPS the run: written as it stands it would put a
# local part in mailLocalAddress, which the schema does not describe and which smtpd reaches
# only at the fourth of its six tries -- a wrong value in the directory costs more than a halt,
# and the import writing the same attribute has a domain or dies too [hn-ldap-import, "mail
# domain unknown"]. Under the file axes the rendered table matches local parts: the bare value
# is the form that branch prints.
sub qualify_alias {
    my ($a) = @_;
    return $a unless defined $a && length $a;
    return $a if index($a, '@') >= 0;
    my $d = $CONF->{domain};
    return "$a\@$d" if defined $d && length $d;
    die "alias $a: no domain to qualify it with, set the key domain of /etc/hn.conf\n"
        if $AUTH eq 'ldap';
    return $a;
}

# The shape of an address, once the class is right: one local part, not empty, neither starting
# nor ending on a dot, and at most one '@' followed by a domain smtpd serves. An empty part makes
# a key smtpd reads as something else: after user@domain and user, aliases_virtual_get looks up
# '@<domain>', the catch-all of the domain, then '@', the catch-all of every domain
# [verifie:openbsd/src usr.sbin/smtpd/aliases.c 1.79:126-170], so an alias '@hors-norme.fr' or '@'
# takes the mail of every address nobody holds, and 'jean.dupont@' is a key no lookup ever
# builds. The domains are those of /etc/mail/domains, the table smtpd matches recipients against,
# plus the one of hn.conf. undef when the shape holds, the reason otherwise.
my $DOMAINS = '/etc/mail/domains';
sub alias_shape_error {
    my ($t) = @_;
    my ($local, $domain, @more) = split /\@/, $t, -1;
    return 'more than one @' if @more;
    return 'empty local part' unless defined $local && length $local;
    return 'local part starting or ending on a dot' if $local =~ /^\.|\.\z/;
    return undef unless defined $domain;
    return 'empty domain after the @' unless length $domain;
    my %served = map { lc $_ => 1 } grep { length } ($CONF->{domain} // '');
    if (open(my $fh, '<', $DOMAINS)) {
        while (my $l = <$fh>) {
            $l =~ s/#.*//;
            $l =~ s/^\s+|\s+\z//g;
            $served{lc $l} = 1 if length $l;
        }
        close $fh;
    }
    return "domain $domain is not one smtpd serves ($DOMAINS)" unless $served{lc $domain};
    return undef;
}

# The addresses that reach a login. Two sources, and they hold different things: under `ldap`
# they are attributes of the person, mail and mailLocalAddress, full addresses both; otherwise
# they are the KEYS of the rendered tables, which smtpd matches as local parts. The display is
# one -- the keys are qualified on the way out -- so `list` shows an address whatever the axis
# and the difference stays where it belongs, in the source.
sub addresses_of {
    my ($user) = @_;
    return ldap_addresses($user) if $AUTH eq 'ldap';
    my %a;
    for my $f (@ALIASES) {
        open(my $fh, '<', $f) or next;
        while (my $l = <$fh>) {
            next if $l =~ /^\s*(#|$)/;
            my ($k, $v) = split /:/, $l, 2;
            next unless defined $v;
            $k =~ s/^\s+|\s+$//g;
            next unless grep { $_ eq $user } split_list($v);
            $a{qualify_alias($k)} = 1;
        }
        close $fh;
    }
    return sort keys %a;
}

# Who already holds an address: the login (or, for a directory entry without uid, the DN) that it
# reaches, or undef when it is free or reaches $user herself. An address reaching two people
# delivers to both, so no writer may give one away twice.
#   ldap        one search on the whole suffix, (|(mail=x)(mailLocalAddress=x)), the value escaped
#               per RFC 4515: an entry outside ou=people holding it is as much a holder.
#   file axes   the keys of the tables smtpd reads, aliases(5) folding them to lowercase
#               [verifie:man.openbsd.org/aliases.5]: a key whose value list does not name $user.
sub alias_holder {
    my ($user, $alias) = @_;
    if ($AUTH eq 'ldap') {
        my $v = ldap_filter_value(qualify_alias($alias));
        (my $mine = lc ldap_dn($user)) =~ s/,\s+/,/g;
        for my $e (ldap_search(ldap_suffix(), 'sub', "(|(mail=$v)(mailLocalAddress=$v))", 'uid')) {
            (my $dn = lc($e->{dn}[0] // '')) =~ s/,\s+/,/g;
            next if $dn eq $mine;
            return $e->{uid} ? $e->{uid}[0] : $e->{dn}[0];
        }
        return undef;
    }
    my %seen;
    for my $f (grep { !$seen{$_}++ } @ALIASES, $CONF->{aliases_file} // '/etc/mail/aliases_user') {
        open(my $fh, '<', $f) or next;
        while (my $l = <$fh>) {
            next if $l =~ /^\s*(#|$)/;
            my ($k, $v) = split /:/, $l, 2;
            next unless defined $v;
            $k =~ s/^\s+|\s+$//g;
            next unless lc $k eq lc $alias;
            my @to = split_list($v);
            next if grep { $_ eq $user } @to;
            close $fh;
            return join(',', @to);
        }
        close $fh;
    }
    return undef;
}

# Every alias of the list free, or a refusal naming the first one taken and who holds it, before
# anything is written.
sub alias_guard {
    my ($user, $add) = @_;
    for my $a (@$add) {
        my $h = alias_holder($user, $a);
        die "alias $a already reaches $h -- refused, nothing written for it\n" if defined $h;
    }
}

# The alias a person answers to by convention: alias_pattern with <given> and <family> filled
# in. The pattern is configuration, not a rule of the protocol -- hence its place in hn.conf.
sub derived_alias {
    my ($given, $family) = @_;
    my $p = $CONF->{alias_pattern} // '<given>.<family>';
    $p =~ s/<given>/slug_alias($given)/ge;
    $p =~ s/<family>/slug_alias($family)/ge;
    return $p;
}

# Carrying the aliases. Two branches, and they differ in kind: `ldap` writes them, anything else
# prints what a human must carry to the repository, because ansible owns the rendered table and
# an edit made here would not survive the next play.
# Qualification happens HERE, on both lists and on the directory branch alone: what goes into an
# entry is an address, what goes into the rendered table is the local part the table matches.
# Removal takes the same road -- `--alias -prenom.nom` must reach the qualified value, or the
# delta finds nothing and the removal passes in silence.
sub alias_apply {
    my ($user, $add, $del) = @_;
    return ldap_alias_apply($user, [map { qualify_alias($_) } @$add],
                                   [map { qualify_alias($_) } @$del]) if $AUTH eq 'ldap';
    return file_alias_apply($user, $add, $del);
}

# The file the `virtual` dispatcher reads under the non-directory axes. This script owns its
# content, ansible the file and its mode: a person is not configuration, and a table a play
# rewrites cannot hold an account created between two of them.
#
# Read first, rewrite whole: the table holds one value per key, so a key both added and already
# present must leave ONE line, and the rewrite is what guarantees it. Sorted on the key, one
# column for the value: a diff between two hosts stays readable.
#
# Write beside, then rename. A table truncated mid-write is a table smtpd reloads with half the
# addresses, where rename "guarantees that if to already exists, an instance of to will always
# exist, even if the system should crash in the middle of the operation"
# [verifie:man.openbsd.org/rename.2]. Same filesystem, hence the temporary beside the target.
sub file_alias_apply {
    my ($user, $add, $del) = @_;
    return unless @$add || @$del;
    my $f = $CONF->{aliases_file} // '/etc/mail/aliases_user';

    my (%val, @head);
    if (-e $f) {
        open(my $fh, '<', $f) or die "$f: $!\n";
        while (my $l = <$fh>) {
            chomp $l;
            # The banner and whatever a hand left above the first entry: kept as it stands.
            if ($l =~ /^\s*(#|$)/) { push @head, $l unless %val; next; }
            my ($k, $v) = split /:/, $l, 2;
            next unless defined $v;
            $k =~ s/^\s+|\s+$//g;
            $v =~ s/^\s+|\s+$//g;
            $val{$k} = $v if length $k;
        }
        close $fh;
    }
    @head = ('# hn-user writes this table; ansible lays the file down and owns its mode alone.')
        unless @head;

    my (@new, @gone);
    for my $a (@$add) {
        next if exists $val{$a} && $val{$a} eq $user;
        push @new, $a;
        $val{$a} = $user;
    }
    for my $a (@$del) {
        next unless exists $val{$a};
        push @gone, $a;
        delete $val{$a};
    }
    unless (@new || @gone) {
        print "alias : $user already carries them, nothing to change\n";
        return;
    }

    my $tmp = "$f.new.$$";
    open(my $out, '>', $tmp) or die "$tmp: $!\n";
    print $out "$_\n" for @head;
    printf $out "%-24s%s\n", "$_:", $val{$_} for sort keys %val;
    close $out or die "$tmp: $!\n";
    chmod 0644, $tmp;
    rename $tmp, $f or do { unlink $tmp; die "$f: $!\n" };

    print "alias  $_ -> $user\n" for @new;
    print "alias  removed $_\n" for @gone;
    table_reload($f);
}

# `file:` tables are read once and kept in lka, so a rewritten file is not seen until the table is
# updated; smtpd.conf itself is parsed at startup alone, which is why this is an update and not a
# reload [verifie:man.openbsd.org/smtpctl.8]. Silent when smtpd is not running: hn-user is also
# used on a host being installed, where the table will be read at the first start anyway.
sub table_reload {
    my ($f) = @_;
    my $name = (split m{/}, $f)[-1];
    return unless -x '/usr/sbin/smtpctl';
    return if system('/usr/sbin/rcctl', 'check', 'smtpd') != 0;
    system('/usr/sbin/smtpctl', 'update', 'table', $name) == 0
        or warn "smtpctl update table $name failed\n";
}

# ---------------------------------------------------------------------------- LDAP -----------
# The directory is reached through the command line tools rather than Net::LDAP, absent from the
# base system. `uri` and `basedn` are the two the read path needs; `binddn` with `bindpw` -- a
# PATH to a file, never the secret itself, like every other secret this config names -- is what
# a write needs when the SASL EXTERNAL of a local socket is not available. The keys are absent
# from /etc/hn.conf while auth=ldap stays reserved, and the message below names the ones
# missing rather than failing further down on an empty argument.
sub ldap_conf {
    my @missing = grep { !defined $CONF->{$_} || !length $CONF->{$_} } qw(uri basedn);
    die "auth=ldap: /etc/hn.conf lacks " . join(', ', @missing) . "\n" if @missing;
    return $CONF;
}

# basedn IS the base of the person entries, ou=people,<suffix>
# [roles/mail/templates/etc_hn.conf.j2, basedn={{ mail_cyrus_sasl_ldap_search_base }}]. The same
# reading as HnUser::accounts(), saslauthd and login_ldap: a person carries the RDN alone above
# it.
sub ldap_dn {
    my ($user) = @_;
    my $c = ldap_conf();
    return "uid=$user,$c->{basedn}";
}

# The suffix of the directory, where cn=lastUID sits and under which ou=groups hangs. hn.conf has
# no key for it [roles/mail/templates/etc_hn.conf.j2: uri, basedn, home_base, shell,
# alias_pattern, domain]: basedn with its first RDN taken off -- ou=people,<suffix> -> <suffix>.
# A key `suffix`, when the template grows one, wins over the derivation.
sub ldap_suffix {
    my $c = ldap_conf();
    return $c->{suffix} if defined $c->{suffix} && length $c->{suffix};
    (my $s = $c->{basedn}) =~ s/^[^,]+,\s*//;
    die "auth=ldap: no suffix above basedn $c->{basedn}, set the key suffix of /etc/hn.conf\n"
        if $s eq $c->{basedn} || !length $s;
    return $s;
}

# One LDIF line. A value that is not a SAFE-STRING -- a leading space, colon or '<', any byte
# outside printable ASCII, the accents of a cn -- goes base64 behind '::'
# [verifie:RFC 2849, Formal Syntax Definition of LDIF, SAFE-STRING and value-spec].
# \z, not $: `$` matches before a final newline, and "Dupont\n" would go out bare, its newline
# ending the line and the record with it [verifie:perlre, "$" and "\z"]. Every gate below that
# validates a value ends the same way.
sub ldif_line {
    my ($attr, $v) = @_;
    $v = '' unless defined $v;
    return "$attr: $v\n" if $v =~ /^[\x21-\x39\x3b\x3d-\x7f][\x01-\x09\x0b\x0c\x0e-\x7f]*\z/;
    # ${attr}: a bare "$attr::" would name the package variable of that spelling.
    return "${attr}:: " . encode_base64($v, '') . "\n";
}

# One LDIF line whose value is BINARY -- a DER certificate, a PKCS#7 -- base64 behind '::'
# whatever its bytes: ldif_line would pass a value that happens to be printable as it stands, and
# nothing about a DER promises it is not.
sub ldif_bin {
    my ($attr, $v) = @_;
    return "${attr}:: " . encode_base64($v // '', '') . "\n";
}

# No binddn in hn.conf: SASL EXTERNAL on the local socket. slapd maps the local root to
# gidNumber=0+uidNumber=0,cn=peercred,cn=external,cn=auth, the identity olcAccess {6} of dbe_ldap
# grants `manage` on the whole suffix -- writing here takes no service account and no secret
# [roles/dbe_ldap/templates/config.ldif.j2, `olcAccess: {3}to dn.subtree="{{ dbe_ldap_suffix }}"`,
# `by dn.exact="{{ dbe_ldap_root_peercred }}" manage`]. The uri is the one hn.conf names,
# ldapi:/// on the parc.
# A binddn switches to a simple bind and needs -x: without it the tools bind through SASL, where
# -D is ignored and -y is the password of a simple bind alone [verifie:openldap
# doc/man/man1/ldapmodify.1, -x, -D, -y].
sub ldap_bind_args {
    my $c = ldap_conf();
    my @a = ('-H', $c->{uri});
    if (defined $c->{binddn} && length $c->{binddn}) {
        die "auth=ldap: binddn set without bindpw in /etc/hn.conf\n"
            unless defined $c->{bindpw} && length $c->{bindpw};
        push @a, '-x', '-D', $c->{binddn}, '-y', $c->{bindpw};
    } else {
        push @a, '-Y', 'EXTERNAL', '-Q';
    }
    return @a;
}

# One search, the entries as a list of hashes: attributes as lists under LOWERCASED names --
# LDAP attribute names are case insensitive and the answer echoes the schema spelling.
# ldif-wrap=no keeps a value on one line, and a value that is not LDIF-safe arrives base64
# behind '::' [verifie:RFC 2849, Formal Syntax Definition of LDIF, value-spec]; userPassword
# always does, whatever it holds [verifie:openldap libraries/libldap/ldif.c,
# default_must_b64_encode]. A search that FAILS dies, cause named: read as "this person has no
# address", a failure would turn a removal into a silent no-op and hide every address from
# `list`. One exception: scope base on a DN that does not exist is rc 32, noSuchObject, "the
# object does not exist in the DIT" [verifie:RFC 4511, Appendix A.2] -- that is the answer
# "absent" the callers below ask for, not a failure of the directory.
# An attribute description may carry options behind ';' -- `userCertificate;binary` is answered
# under that very spelling when requested so [verifie:RFC 4522, 2, the binary option] -- hence the
# ';' in the class of the name; the key is lowercased option included.
sub ldap_search {
    my ($base, $scope, $filter, @attrs) = @_;
    my @cmd = ('ldapsearch', '-LLL', '-o', 'ldif-wrap=no', ldap_bind_args(),
               '-b', $base, '-s', $scope, $filter, @attrs);
    open(my $p, '-|', @cmd) or die "ldapsearch $base: $!\n";
    my (@out, %e);
    while (<$p>) {
        chomp;
        if (!length) { push @out, {%e} if %e; %e = (); next; }
        next unless /^([A-Za-z][-A-Za-z0-9;]*):(:?)\s*(.*)$/;
        my ($k, $b64, $v) = ($1, $2, $3);
        push @{ $e{lc $k} }, length($b64) ? decode_base64($v) : $v;
    }
    close $p;
    push @out, {%e} if %e;
    my $rc = $? >> 8;
    return () if $? && $rc == 32 && $scope eq 'base';
    die "ldapsearch $base failed (rc=$rc): directory unreachable, bind refused or base absent\n"
        if $?;
    return grep { exists $_->{dn} } @out;
}

# A value placed in a search filter: '*', '(', ')', '\' and NUL "are represented as a backslash
# followed by the two hexadecimal digits" [verifie:RFC 4515, 3]; any other byte outside printable
# ASCII too, which the same section allows. Without it an alias carrying '*' would be a substring
# match, and a ')' would close the filter early.
sub ldap_filter_value {
    my ($v) = @_;
    $v = '' unless defined $v;
    utf8::encode($v) if utf8::is_utf8($v);
    $v =~ s/([\x00-\x1f\x7f-\xff*()\\])/sprintf('\\%02x', ord $1)/ge;
    return $v;
}

# One entry by login, or undef when the base holds no such login: the search runs on basedn, so
# an absent person is an empty answer, not an error.
sub ldap_entry {
    my ($user, @attrs) = @_;
    my $c = ldap_conf();
    my ($e) = ldap_search($c->{basedn}, 'sub', "(uid=$user)", @attrs);
    return $e;
}

# One entry by DN, or undef when the DN does not exist.
sub ldap_read_dn {
    my ($dn, @attrs) = @_;
    my ($e) = ldap_search($dn, 'base', '(objectClass=*)', @attrs);
    return $e;
}

sub ldap_addresses {
    my ($user) = @_;
    my $e = ldap_entry($user, 'mail', 'mailLocalAddress') or return ();
    my %seen;
    return grep { !$seen{$_}++ }
           sort (@{ $e->{mail} // [] }, @{ $e->{maillocaladdress} // [] });
}

# Written against what the entry HOLDS: one read, then a single modify carrying the delta alone.
# Adding a value already there is error 20, deleting an absent one error 16, and the operations
# of one modify are applied in order to the same entry, schema checked once at the end
# [verifie:openldap servers/slapd/back-mdb/modify.c, mdb_modify_internal] -- either fault would
# take the whole record down with it. Same shape as the memberUid rename of hn-ldap-import: read
# first, emit what the directory does not say yet.
sub ldap_alias_apply {
    my ($user, $add, $del) = @_;
    return unless @$add || @$del;
    my $c = ldap_conf();
    my $e = ldap_entry($user, 'objectClass', 'mailLocalAddress')
        or die "auth=ldap: no entry uid=$user under $c->{basedn}\n";
    # The delta is folded on both sides: mailLocalAddress matches caseIgnoreIA5Match
    # [verifie:openldap servers/slapd/schema/misc.schema, mailLocalAddress EQUALITY], so
    # "JG@Hors-Norme.fr" held by the entry and "jg@hors-norme.fr" asked for are one value. The
    # value WRITTEN keeps the case it was given; the directory matches it either way.
    my %have = map { lc $_ => 1 } @{ $e->{maillocaladdress} // [] };
    my %oc   = map { lc $_ => 1 } @{ $e->{objectclass} // [] };
    my %seen;
    my @new  = grep { !$have{lc $_} && !$seen{lc $_}++ } @$add;
    %seen = ();
    my @gone = grep { $have{lc $_} && !$seen{lc $_}++ } @$del;
    unless (@new || @gone) {
        print "alias : $user already carries them, nothing to change\n";
        return;
    }
    my $ldif = 'dn: ' . ldap_dn($user) . "\nchangetype: modify\n";
    # mailLocalAddress belongs to inetLocalMailRecipient, auxiliary: an entry without that class
    # refuses the attribute. In the same record as the values, so a refused write leaves no class
    # behind.
    $ldif .= "add: objectClass\nobjectClass: inetLocalMailRecipient\n-\n"
        if @new && !$oc{inetlocalmailrecipient};
    $ldif .= "add: mailLocalAddress\n" . join('', map { "mailLocalAddress: $_\n" } @new) . "-\n"
        if @new;
    $ldif .= "delete: mailLocalAddress\n" . join('', map { "mailLocalAddress: $_\n" } @gone) . "-\n"
        if @gone;
    ldap_modify($ldif);
    print "alias  $_ -> $user\n" for @new;
    print "alias  removed $_\n" for @gone;
}

# One LDIF record on stdin. SIGPIPE ignored: ldapmodify exiting on the bind leaves the write
# without a reader, and the default disposition would kill this script before it can name the rc.
sub ldap_modify {
    my ($ldif) = @_;
    my $rc = ldap_modify_rc($ldif);
    die "ldapmodify failed (rc=$rc)\n" if $rc;
}

# The same, the rc handed back: ldapmodify exits with the LDAP result code of the record that
# failed [verifie:openldap OPENLDAP_REL_ENG_2_6 clients/tools/ldapmodify.c:315-317, 374;
# common.c:1687-1694, tool_exit], so a caller can tell one refusal from another.
# A failed close is never rc 0: a child killed by a signal has exit code 0 in $? >> 8, and $? is
# -1 when the wait itself failed [verifie:perl 5.34 perldoc perlvar, $? -- exit value $? >> 8,
# signal $? & 127; perldoc -f system, $? == -1]. A signal reads 128 + n, as a shell names it;
# anything else non-zero, 1. rc 16 stays what ldapmodify said, for the uid retry.
sub ldap_modify_rc {
    my ($ldif) = @_;
    local $SIG{PIPE} = 'IGNORE';
    my @cmd = ('ldapmodify', ldap_bind_args());
    my $pid = open(my $in, '|-', @cmd);
    die "ldapmodify: $!\n" unless $pid;
    print $in $ldif;
    return 0 if close($in);
    my $st = $?;
    return 1 if $st == -1;
    return ($st >> 8) || (($st & 127) ? 128 + ($st & 127) : 1);
}

# A person in the directory, shaped like the entries luminary writes and the import wrote: the
# four classes, cn `<family> <given>` (the gecos convention of the fleet, family first), the
# posix fields, mail and mailLocalAddress on the domain of hn.conf, one {ARGON2} userPassword.
#
# uidNumber comes from cn=lastUID,<suffix>, a `device` entry the setup wizard of luminary creates
# [verifie:wheelybird/luminary@dace57b www/setup/setup_ldap.php:89-108, setup_last_uid] and whose
# serialNumber its ldap_new_account kept: the highest id + 1, written back there
# [verifie:same sha, www/includes/ldap_functions.inc.php:1020-1023, 1053-1064,
# fetch_id_stored_in_ldap:350-365]. Account creation is closed in luminary
# [ports-hn www/luminary, patch-www_account_manager_new_user_php]: this verb is the one writer of
# the counter. The counter absent, it stops rather than guess, and names who creates it. gidNumber is the one of luminary's default group,
# cn=everybody,ou=groups,<suffix> (DEFAULT_USER_GROUP, 'everybody' unless the role says
# otherwise), and the login joins that group's memberUid as luminary's ldap_add_member_to_group
# does [verifie:same file:1025-1034, 1051]. gids are not allocated here: cn=lastGID is not read.
#
# The uid is RESERVED before the entry exists, by one modify that deletes the value read and adds
# the next: the delete of a value the entry no longer holds is noSuchAttribute (16), and the whole
# modify with it [verifie:openldap OPENLDAP_REL_ENG_2_6 servers/slapd/mods.c:252-262, 282-296,
# modify/delete "no such value"; RFC 4511, Appendix A.2]. A second writer that moved the counter
# between the read and the write therefore makes this one fail instead of handing out its uid:
# read again, try again, five times. The delete needs an EQUALITY rule, which serialNumber has,
# caseIgnoreMatch [verifie:openldap OPENLDAP_REL_ENG_2_6 servers/slapd/schema/core.schema:89-93];
# without one slapd answers inappropriateMatching (18) [verifie:mods.c:241-249].
# A uid reserved and an add of the entry that fails afterwards: that uid is burnt, never reused.
#
# Three writes: the counter, the entry, the group. Returns what the caller prints.
sub ldap_account_add {
    my ($user, $given, $family, $plain) = @_;
    my $c = ldap_conf();
    my $suffix = ldap_suffix();
    my $dn = ldap_dn($user);
    die "user '$user' already exists in the directory ($dn)\n" if ldap_entry($user, 'uid');

    my $domain = $c->{domain};
    die "auth=ldap: no domain for the mail address of $user, set the key domain of /etc/hn.conf\n"
        unless defined $domain && length $domain;

    my $group = $c->{group} // 'everybody';
    my $gdn = "cn=$group,ou=groups,$suffix";
    my $g = ldap_read_dn($gdn, 'gidNumber', 'memberUid');
    my $gid = $g ? $g->{gidnumber}[0] : undef;
    die "auth=ldap: $gdn absent or without gidNumber -- luminary's DEFAULT_USER_GROUP, the"
      . " primary group of every person; create it through luminary, or set the key group of"
      . " /etc/hn.conf to the posixGroup to use\n"
        unless defined $gid && $gid =~ /^\d+\z/;

    my $uid = ldap_uid_reserve("cn=lastUID,$suffix");

    my $base = $c->{home_base} // HnUser::home_base();
    $base =~ s{/+\z}{};
    my $home  = "$base/$user";
    my $shell = $c->{shell} // '/bin/ksh';
    my $gecos = "$family $given";
    my $ldif = join '', map { ldif_line(@$_) }
        ['dn', $dn], ['changetype', 'add'],
        (map { ['objectClass', $_] } qw(person inetOrgPerson posixAccount inetLocalMailRecipient)),
        ['uid', $user], ['cn', $gecos], ['sn', $family], ['givenName', $given],
        ['uidNumber', $uid], ['gidNumber', $gid], ['homeDirectory', $home], ['loginShell', $shell],
        ['mail', "$user\@$domain"], ['mailLocalAddress', "$user\@$domain"],
        ['userPassword', argon2_hash($plain)];
    ldap_modify($ldif);
    # Already a member: an add interrupted between the second and the third write; nothing to send.
    my $joined = (grep { $_ eq $user } @{ $g->{memberuid} // [] }) ? 0 : 1;
    ldap_modify("dn: $gdn\nchangetype: modify\nadd: memberUid\nmemberUid: $user\n-\n") if $joined;
    return { gecos => $gecos, uid => $uid, gid => $gid, home => $home, group_dn => $gdn, joined => $joined };
}

# The test-and-set of the counter: the uid reserved, or death after five refusals. Any rc other
# than 16 is a failure of its own, not a race, and stops at once.
sub ldap_uid_reserve {
    my ($last_dn) = @_;
    for my $try (1 .. 5) {
        my $last = ldap_read_dn($last_dn, 'serialNumber');
        my $cur = $last ? $last->{serialnumber}[0] : undef;
        die "auth=ldap: $last_dn absent or without a numeric serialNumber -- the setup wizard of"
          . " luminary creates that counter (its uid counter check); run it, or add the entry by"
          . " hand: objectClass device, serialNumber = highest uidNumber in use\n"
            unless defined $cur && $cur =~ /^\d+\z/;
        my $next = $cur + 1;
        my $rc = ldap_modify_rc("dn: $last_dn\nchangetype: modify\n"
                              . "delete: serialNumber\nserialNumber: $cur\n-\n"
                              . "add: serialNumber\nserialNumber: $next\n-\n");
        return $next unless $rc;
        die "ldapmodify failed (rc=$rc) reserving a uid on $last_dn\n" unless $rc == 16;
    }
    die "auth=ldap: $last_dn moved under each of 5 reservations -- another writer is creating"
      . " accounts; run add again\n";
}

# The administrators of luminary: its group LDAP_ADMINS_GROUP, cn=<name>,ou=groups,<suffix> -- the
# group attribute cn and the unit groups, defaults the role keeps, the DN its own
# ldap_add_member_to_group builds [verifie:wheelybird/luminary@dace57b
# www/includes/config_registry.inc.php:174, 185, 208, 1244-1253; ldap_functions.inc.php:1170; infra.git
# roles/web_luminary/defaults/main.yml, LDAP_ADMINS_GROUP]. The name is the key admins_group of
# hn.conf, admins without it: the default of luminary and the value of the role.
#
# What luminary reads: the log-in asks ldap_is_group_member, which reads ONE attribute,
# group_membership_attribute, and compares its values to the login [verifie:same sha,
# www/log_in/index.php:30; www/includes/ldap_functions.inc.php:535-597]. The role sets neither
# LDAP_GROUP_MEMBERSHIP_ATTRIBUTE nor FORCE_RFC2307BIS, so ldap_detect_rfc2307bis decides: a
# posixGroup that is not AUXILIARY in the schema gives memberUid, valued with the login
# [ldap_functions.inc.php:1338-1452]. dbe_ldap loads nis, where posixGroup is STRUCTURAL
# [verifie:openldap OPENLDAP_REL_ENG_2_6 servers/slapd/schema/nis.schema:175-179]. A group
# carrying groupOfNames or groupOfUniqueNames is one luminary would read through member or
# uniqueMember: refused, never written in an attribute nobody reads.
sub ldap_admins_read {
    my $c = ldap_conf();
    my $name = (defined $c->{admins_group} && length $c->{admins_group}) ? $c->{admins_group} : 'admins';
    my $dn = "cn=$name,ou=groups," . ldap_suffix();
    return ($dn, ldap_read_dn($dn, 'objectClass', 'memberUid'));
}

# In ($join true) or out. Read first, then the change alone, as ldap_group does: a member already
# in, or already out, writes nothing [RFC 4511, Appendix A.2, codes 20 and 16]; memberUid matches
# caseExactIA5Match [nis.schema:93-96], hence eq. A group absent: fatal to an add, which names who
# creates it; nothing to remove for a removal. Returns 1 when it wrote.
sub ldap_admin {
    my ($user, $join) = @_;
    my ($dn, $g) = ldap_admins_read();
    unless ($g) {
        die "auth=ldap: $dn absent -- the setup wizard of luminary creates it\n" if $join;
        print "admin  $user not in $dn: no such group\n";
        return 0;
    }
    my %oc = map { lc $_ => 1 } @{ $g->{objectclass} // [] };
    die "auth=ldap: $dn is no posixGroup alone -- luminary would not read memberUid there; nothing"
      . " written\n"
        unless $oc{posixgroup} && !$oc{groupofnames} && !$oc{groupofuniquenames};
    my $in = grep { $_ eq $user } @{ $g->{memberuid} // [] };
    if ($join ? $in : !$in) {
        print "admin  $user " . ($join ? 'already in' : 'not in') . " $dn\n";
        return 0;
    }
    my $op = $join ? 'add' : 'delete';
    ldap_modify("dn: $dn\nchangetype: modify\n$op: memberUid\nmemberUid: $user\n-\n");
    print "admin  $user " . ($join ? 'added to' : 'removed from') . " $dn\n";
    return 1;
}

# ---------------------------------------------------------------------- the secret -----------
# Where the password of a person is stored. One function, so that the day it moves the callers
# do not each learn a new way of writing it.
sub secret_set {
    my ($user, $plain) = @_;
    return ldap_secret_set($user, $plain) if $AUTH eq 'ldap';
    unsupported('password change') unless auth_is_system();
    my $hash = encrypt_pw($plain);
    my $rc = system('usermod', '-p', $hash, $user);
    die "usermod failed (rc=$rc)\n" if $rc;
}

sub secret_lock {
    my ($user) = @_;
    return ldap_secret_lock($user) if $AUTH eq 'ldap';
    unsupported('disable') unless auth_is_system();
    # '*' matches no password: crypt(3) never produces it, so getpwent + crypt refuses, and so
    # does the interactive login. Reversible -- the mailbox and the home stay.
    my $rc = system('usermod', '-p', '*', $user);
    die "usermod failed (rc=$rc)\n" if $rc;
}

# Under `ldap` the secret is the userPassword attribute, and it is MULTI-VALUED: slapd tries the
# credential against every value and a bind succeeds on any of them [verifie:openldap
# servers/slapd/passwd.c, slap_passwd_check, the loop over a_vals]. That is what carries one
# password per device beside the one of the person -- a phone that leaks its secret loses that
# secret alone. The registry of which value belongs to which device is the `description`
# attribute (MAY of person [verifie:openldap servers/slapd/schema/core.schema, person]), one
# value `hn-device: <device> <id>` per device, <id> the first 16 hex of sha256 over the exact
# userPassword string. Nothing else is stable: the value is the key. The password of the PERSON is
# the userPassword value no description claims. luminary does not touch description
# [verifie:wheelybird/luminary@dace57b www/includes/config_registry.inc.php, attribute map].
#
# The hash is computed HERE, never asked of slapd: Password Modify (ldappasswd) replaces every
# value [verifie:openldap servers/slapd/passwd.c, passwd_extop, sml_op = LDAP_MOD_REPLACE on
# userPassword], which would take the devices down with the password.
#
# Scheme {ARGON2}, made by slappasswd with the argon2 module of openldap-server, the code slapd
# verifies with: argon2id, through libsodium on OpenBSD [verifie:openldap OPENLDAP_REL_ENG_2_6
# servers/slapd/pwmods/argon2.c:41-51, 120-136; openbsd/ports databases/openldap/Makefile:58-63,
# --with-argon2=libsodium], module defaults. A value already held keeps its scheme: slapd picks
# the checker by the {SCHEME} prefix of each value [verifie:libraries/liblutil/passwd.c:264-310],
# so the {SSHA} values luminary and the import wrote bind through the SSHA checker of slapd. A
# slapd without the module matches no {ARGON2} value: the bind fails [same lines, unknown scheme
# -> 1].
# The secret goes on the stdin of slappasswd, never on an argv nor a file: -T /dev/stdin, read whole
# by lutil_get_filed_password, no line end stripped, a pipe read to EOF
# [verifie:libraries/liblutil/passfile.c:32-110; man.openbsd.org/fd.4, /dev/stdin]. -n: no newline
# after the hash. slappasswd checks the hash it made before printing it
# [verifie:servers/slapd/slappasswd.c:168-170, 244-292]. module-load=argon2 resolves under
# LDAP_MODULEDIR, /usr/local/libexec/openldap [verifie:servers/slapd/module.c:58-72;
# databases/openldap/pkg/PLIST-server, libexec/openldap/argon2.la]. The hash goes on the stdin of
# ldapmodify, never on an argv.
sub argon2_hash {
    my ($plain) = @_;
    utf8::encode($plain) if utf8::is_utf8($plain);
    local $SIG{PIPE} = 'IGNORE';
    my $pid = open2(my $out, my $in, 'slappasswd', '-n', '-h', '{ARGON2}',
                    '-o', 'module-load=argon2', '-T', '/dev/stdin');
    binmode $in; binmode $out;
    print $in $plain;
    close $in;
    my $h = do { local $/; <$out> };
    close $out;
    waitpid($pid, 0);
    my $st = $?;
    my $rc = $st == -1 ? 1 : ($st >> 8) || (($st & 127) ? 128 + ($st & 127) : 0);
    die "slappasswd failed (rc=$rc)\n" if $rc;
    die "slappasswd: no {ARGON2} hash on its output\n"
        unless defined $h && $h =~ /\A\{ARGON2\}\$argon2id\$[!-~]+\z/;
    return $h;
}

sub urandom {
    my ($n) = @_;
    open(my $fh, '<', '/dev/urandom') or die "/dev/urandom: $!\n";
    binmode $fh;
    my $got = read($fh, my $buf, $n);
    close $fh;
    die "/dev/urandom: short read\n" unless defined $got && $got == $n;
    return $buf;
}

sub device_id { return substr(sha256_hex($_[0]), 0, 16); }

# What the entry holds, read once: every userPassword value, the devices the descriptions
# register -- with the value each one claims, when it is still there -- and the values nobody
# claims, which are the password of the person (one, on a healthy entry).
sub ldap_secrets {
    my ($user) = @_;
    my $c = ldap_conf();
    my $e = ldap_entry($user, 'userPassword', 'description')
        or die "auth=ldap: no entry uid=$user under $c->{basedn}\n";
    return secrets_of($e);
}

# The same reading, on an entry already in hand.
sub secrets_of {
    my ($e) = @_;
    my @values = @{ $e->{userpassword} // [] };
    my %by_id = map { device_id($_) => $_ } @values;
    my (%dev, %claimed);
    for my $d (@{ $e->{description} // [] }) {
        next unless $d =~ /^hn-device: ([a-z0-9][a-z0-9-]*) ([0-9a-f]{16})\z/;
        $dev{$1} = { id => $2, desc => $d, value => $by_id{$2} };
        $claimed{$2} = 1;
    }
    my @human = grep { !$claimed{ device_id($_) } } @values;
    return { values => \@values, devices => \%dev, human => \@human };
}

# The STATE column of `list` under `ldap`, read from the entries and not from master.passwd, which
# the directory accounts are not in: `active` with a password of the person, `locked` with no
# userPassword value at all (what `del --disable` leaves), `devices` when device secrets alone
# remain. One search for every person. Through ldapi, userPassword is read by the peercred of root
# and refused to another local caller [roles/dbe_ldap/templates/config.ldif.j2, olcAccess {0}
# attrs=userPassword, `by dn.exact="{{ dbe_ldap_root_peercred }}" manage`, `by * none`]: the caller
# asks only as root, and prints '?' otherwise -- an entry read without the attribute would look
# locked. $notes, an array, receives what secret_notes says of each entry.
sub ldap_states {
    my ($notes) = @_;
    my $c = ldap_conf();
    my %st;
    for my $e (ldap_search($c->{basedn}, 'sub', '(objectClass=posixAccount)',
                           'uid', 'userPassword', 'description')) {
        next unless $e->{uid};
        my $s = secrets_of($e);
        $st{ $e->{uid}[0] } = @{ $s->{human} }  ? 'active'
                            : @{ $s->{values} } ? 'devices'
                            :                     'locked';
        push @$notes, secret_notes($e->{uid}[0], $s) if $notes;
    }
    return \%st;
}

# What an entry holds that this script did not leave there, one line each. Several values no
# description claims: one is the password of the person, the others are secrets nobody can name
# -- a device secret luminary swapped for a new password, or a value written by hand -- that
# `secret del` never reaches and every bind still accepts. A registration whose value is gone:
# it names a device that opens nothing.
sub secret_notes {
    my ($user, $s) = @_;
    my @gone = grep { !defined $s->{devices}{$_}{value} } sort keys %{ $s->{devices} };
    return (unclaimed_note($user, $s),
            map { "!! $user: device $_ registered, its userPassword value gone"
                . " (hn-user secret del $user $_)" } @gone);
}

sub unclaimed_note {
    my ($user, $s) = @_;
    my $n = @{ $s->{human} };
    return () unless $n > 1;
    return "!! $user carries $n userPassword values no hn-device description claims -- one is the"
         . " password, the others open the account unnamed: clean the entry by hand";
}

# The password of the person: the unclaimed value goes, the new one comes, in ONE modify, and the
# device values are not named -- a modify names what it changes, the rest of the attribute stays
# [verifie:RFC 4511, 4.6, delete with values]. No unclaimed value -- a disabled account, or an
# entry whose devices alone hold one -- is an add; several is an entry this script did not
# write and will not guess about.
sub ldap_secret_set {
    my ($user, $plain) = @_;
    my $s = ldap_secrets($user);
    my @h = @{ $s->{human} };
    die "auth=ldap: uid=$user carries " . scalar(@h) . " userPassword values that no hn-device"
      . " description claims -- clean the entry by hand before setting a password\n" if @h > 1;
    my $ldif = 'dn: ' . ldap_dn($user) . "\nchangetype: modify\n";
    $ldif .= "delete: userPassword\n" . ldif_line('userPassword', $h[0]) . "-\n" if @h;
    $ldif .= "add: userPassword\n" . ldif_line('userPassword', argon2_hash($plain)) . "-\n";
    ldap_modify($ldif);
}

# Disabled: no userPassword value at all, person and devices alike, and the registry emptied with
# them -- a description left behind would claim a value that no longer exists. `delete` without
# values takes the whole attribute [verifie:RFC 4511, 4.6]. The entry, the mailbox and the
# aliases stay: `mod --password` is the way back.
sub ldap_secret_lock {
    my ($user) = @_;
    my $s = ldap_secrets($user);
    my @desc = sort map { $_->{desc} } values %{ $s->{devices} };
    unless (@{ $s->{values} } || @desc) {
        print "secret  $user already carries no password\n";
        return;
    }
    my $ldif = 'dn: ' . ldap_dn($user) . "\nchangetype: modify\n";
    $ldif .= "delete: userPassword\n-\n" if @{ $s->{values} };
    $ldif .= "delete: description\n" . join('', map { ldif_line('description', $_) } @desc) . "-\n"
        if @desc;
    ldap_modify($ldif);
}

# One device: 18 bytes of entropy, 24 characters of base64 -- typed once into a client, then
# kept by it. Returned to the caller, who prints it ONCE; nothing here stores it in clear.
# Refused on an entry without a password of its own -- what `del --disable` leaves, no userPassword
# value at all: a device secret would open again, through that device, an account disabled on
# purpose. The way back goes through the password of the person first.
sub device_add {
    my ($user, $device) = @_;
    my $s = ldap_secrets($user);
    die "secret add refused: $user has no password of its own (disabled); set one first: hn-user mod $user --password\n"
        unless @{ $s->{human} };
    die "device '$device' already holds a secret on $user (secret del $user $device first)\n"
        if $s->{devices}{$device};
    my $secret = encode_base64(urandom(18), '');
    my $hash   = argon2_hash($secret);
    my $ldif = 'dn: ' . ldap_dn($user) . "\nchangetype: modify\n"
             . "add: userPassword\n" . ldif_line('userPassword', $hash) . "-\n"
             . "add: description\n" . ldif_line('description', "hn-device: $device " . device_id($hash)) . "-\n";
    ldap_modify($ldif);
    return $secret;
}

sub device_del {
    my ($user, $device) = @_;
    my $s = ldap_secrets($user);
    my $d = $s->{devices}{$device}
        or die "no secret registered for device '$device' on $user\n";
    my $ldif = 'dn: ' . ldap_dn($user) . "\nchangetype: modify\n";
    if (defined $d->{value}) {
        $ldif .= "delete: userPassword\n" . ldif_line('userPassword', $d->{value}) . "-\n";
    } else {
        warn "!! the userPassword value of $device is already gone; its registration alone goes\n";
    }
    $ldif .= "delete: description\n" . ldif_line('description', $d->{desc}) . "-\n";
    ldap_modify($ldif);
}

# The devices of a person, sorted by name: [name, id, whether the value is still there].
sub device_list {
    my ($user) = @_;
    my $s = ldap_secrets($user);
    return map { [$_, $s->{devices}{$_}{id}, defined $s->{devices}{$_}{value} ? 1 : 0] }
           sort keys %{ $s->{devices} };
}

sub encrypt_pw {
    my ($p) = @_;
    my $pid = open2(my $out, my $in, 'encrypt');
    print $in "$p\n";
    close $in;
    my $h = <$out>;
    close $out;
    waitpid($pid, 0);
    chomp $h;
    die "encrypt failed\n" unless defined $h && $h =~ /^\$2/;
    return $h;
}

# ------------------------------------------------------------------------ the group ----------
# Membership of the shared collections. The file is the source of truth for the reconciliation,
# so it is written BEFORE the share is opened and AFTER it is closed.
#
# The file ABSENT is not an empty group: it is the legacy mode, where `sync` shares with every
# account and revokes nobody, and its mere presence switches `sync` to strict, revoking whoever it
# does not list [HnUser.pm, shared_members: `open(...) or return undef`; verb_sync, `my $strict =
# defined $sh` then `next if $member{$u}` before unshare]. Creating it here with one login would
# take the share away from everyone else at the next `sync`: refused, the file is made by hand.
sub shared_absent {
    my ($f) = @_;
    return "group  $f absent: every account shares today (legacy mode); create it with the full"
         . " member list first, one login per line -- written with one login it would revoke the others\n";
}

# A file whose last line lacks its newline would glue the login appended to it: "alice" then
# "bob\n" reads "alicebob". The newline is added first.
sub group_add {
    my ($user) = @_;
    return ldap_group($user, 1) if $AUTH eq 'ldap';
    my $f = HnUser::shared_file();
    my $m = HnUser::shared_members();
    die shared_absent($f) unless defined $m;
    return if $m->{$user};
    my $nl = '';
    if (open(my $in, '<', $f)) {
        my $t = do { local $/; <$in> } // '';
        close $in;
        $nl = "\n" if length $t && substr($t, -1) ne "\n";
    }
    open(my $fh, '>>', $f) or do { warn "!! write $f: $!\n"; return; };
    print $fh "$nl$user\n";
    close $fh;
    print "group  $user added to $f\n";
}

sub group_del {
    my ($user) = @_;
    return ldap_group($user, 0) if $AUTH eq 'ldap';
    my $f = HnUser::shared_file();
    return unless -e $f;
    open(my $in, '<', $f) or return;
    my @all = <$in>;
    close $in;
    # Comments and blank lines survive: the file is hand-read as much as machine-read. Atomic
    # rewrite, so a crash mid-write cannot leave the share without its member list.
    my @keep = grep { (my $l = $_) =~ s/#.*//; $l =~ s/^\s+|\s+$//g; $l ne $user } @all;
    return if @keep == @all;
    open(my $out, '>', "$f.tmp") or do { warn "!! write $f.tmp: $!\n"; return; };
    print $out @keep;
    close $out;
    rename("$f.tmp", $f) or warn "!! rename $f.tmp: $!\n";
    print "group  $user removed from $f\n";
}

# Read first, then write the change alone: adding a memberUid already there is
# attributeOrValueExists (20), deleting one absent noSuchAttribute (16), both fatal to the modify
# [verifie:RFC 4511, Appendix A.2]. A member already in, or already out, is the state asked for:
# nothing is written and the verb goes on. memberUid matches caseExactIA5Match [verifie:openldap
# OPENLDAP_REL_ENG_2_6 servers/slapd/schema/nis.schema:93-96], hence eq.
sub ldap_group {
    my ($user, $join) = @_;
    my ($dn, $g) = ldap_group_read();
    my $in = grep { $_ eq $user } @{ $g->{memberuid} // [] };
    if ($join ? $in : !$in) {
        print "group  $user " . ($join ? 'already in' : 'not in') . " $dn\n";
        return;
    }
    my $op = $join ? 'add' : 'delete';
    ldap_modify("dn: $dn\nchangetype: modify\n$op: memberUid\nmemberUid: $user\n-\n");
    print "group  $user " . ($join ? 'added to' : 'removed from') . " $dn\n";
}

# The group of the shared collections: its DN and its entry, or the refusal naming what is
# missing. Read by ldap_group, and by mod before it writes anything.
sub ldap_group_read {
    my $c = ldap_conf();
    die "auth=ldap: /etc/hn.conf lacks group_dn\n"
        unless defined $c->{group_dn} && length $c->{group_dn};
    my $g = ldap_read_dn($c->{group_dn}, 'memberUid')
        or die "auth=ldap: group_dn $c->{group_dn} absent from the directory\n";
    return ($c->{group_dn}, $g);
}

# ----------------------------------------------------------------- the certificate -----------
# The S/MIME certificate of a person, in her entry: the standard way to say she signs. Two
# attributes of inetOrgPerson: userSMIMECertificate, a PKCS#7 'certificates only' holding the
# certificate and its chain, "preferred over the userCertificate attribute for S/MIME
# applications", and userCertificate, the DER certificate alone [verifie:RFC 2798, 2.8 and 2.3;
# inetorgperson.schema]. RFC 2798 carries both ';binary'; slapd does not: userCertificate has the
# Certificate syntax and REQUIRES the option (modify.c, "requires ;binary transfer"), while
# userSMIMECertificate has the Binary syntax 1.3.6.1.4.1.1466.115.121.1.5, for which the option is
# REFUSED with undefinedAttributeType (17) -- ad.c, 'option "binary" not supported with type';
# inetorgperson.schema says ';binary' transfer should NOT be used [verifie:git.openldap.org
# OPENLDAP_REL_ENG_2_6 servers/slapd/schema/inetorgperson.schema:119, schema_init.c:6231-6240,
# ad.c:240-243, modify.c:489-529]. Hence `userCertificate;binary` and plain `userSMIMECertificate`
# below, written, deleted and requested so.
#
# Readers on the fleet: none. filter-smime (smtp-in) checks signatures on entry and reads no
# directory; filter-smime-ldap is not built. The two attributes are kept for the publication RFC
# 2798 describes, to a client that looks a person up. Nothing checks their dates: an expired
# certificate stays published until `cert del`.
#
# Several certificates per person (a renewal overlaps the one it replaces, two clients two keys):
# one certificate = one value of each attribute, the DER of the leaf and a PKCS#7 of that leaf and
# its chain. Its identity is the sha256 of the leaf DER -- what `openssl x509 -fingerprint -sha256`
# prints, the digest of the DER encoding. A userSMIMECertificate value belongs to the leaf whose
# fingerprint is among the certificates it lists, wherever the leaf sits in it: the order inside
# a PKCS#7 is not relied on. A value of one attribute without its partner in the other is
# `unpaired`, shown and removable alone.
#
# openssl does the parsing, by argv list and never through a shell; its intermediate files sit in
# a 0700 directory File::Temp removes at exit (nothing secret: a certificate is public). The
# PKCS#7 is the degenerate SignedData of crl2pkcs7 -nocrl -certfile, leaf first in the input
# [verifie:man.openbsd.org/openssl.1, crl2pkcs7; RFC 2315, 9.1, degenerate case].

# openssl by list: (rc, stdout, stderr), each as bytes. stdout alone is the output -- a DER written
# there is the DER, and a warning openssl adds on stderr is never part of it; stderr goes to an
# anonymous temporary file, "+>" with undef as the name [verifie:perldoc.perl.org/functions/open],
# read after the exit. The caller names the reason in one line; what openssl said on stderr goes
# with it only when the call failed.
sub openssl_out {
    my (@args) = @_;
    open(my $err, '+>', undef) or die "openssl: stderr file: $!\n";
    my $pid = open(my $p, '-|');
    die "openssl: fork: $!\n" unless defined $pid;
    if ($pid == 0) {
        open(STDERR, '>&', $err) or exit 125;
        exec('openssl', @args) or exit 126;
    }
    binmode $p;
    local $/;
    my $out = <$p>;
    close $p;
    my $rc = $? >> 8;
    binmode $err;
    seek($err, 0, 0) or die "openssl: stderr file: $!\n";
    my $msg = <$err>;
    close $err;
    return ($rc, $out // '', $msg // '');
}

# openssl by list, DATA on its stdin, stdout as bytes: (rc, output). open2 so the DER never goes
# through a file the caller has to clean.
sub openssl_in {
    my ($data, @args) = @_;
    local $SIG{PIPE} = 'IGNORE';
    my $pid = open2(my $out, my $in, 'openssl', @args);
    binmode $in; binmode $out;
    print $in $data;
    close $in;
    local $/;
    my $got = <$out>;
    close $out;
    waitpid($pid, 0);
    return ($? >> 8, $got // '');
}

# The CERTIFICATE blocks of a PEM text, in order, each with its armour, line ends made LF (a PEM
# exported by a Windows mail client comes CRLF; openssl reads both); anything between the blocks is
# dropped (openssl writes the text form of a certificate above its PEM).
sub pem_blocks {
    my ($text) = @_;
    $text =~ s/\r\n/\n/g;
    return $text =~ /(-----BEGIN CERTIFICATE-----\n.*?\n-----END CERTIFICATE-----\n?)/gs;
}

# notAfter as openssl prints it, 'Oct 11 12:07:24 2027 GMT', to YYYY-MM-DD. -dateopt iso_8601 is
# not in LibreSSL's x509 [verifie:man.openbsd.org/openssl.1, x509], hence the parse.
my %MONTH = (Jan => 1, Feb => 2, Mar => 3, Apr => 4, May => 5, Jun => 6,
             Jul => 7, Aug => 8, Sep => 9, Oct => 10, Nov => 11, Dec => 12);
sub date_of {
    my ($s) = @_;
    return undef unless defined $s && $s =~ /^\s*(?:notAfter=)?\s*([A-Z][a-z]{2})\s+(\d+)\s+[\d:]+\s+(\d{4})/;
    return undef unless $MONTH{$1};
    return sprintf '%04d-%02d-%02d', $3, $MONTH{$1}, $2;
}

# ---- the DER, read here
# 2.5.29.17 subjectAltName, 2.5.29.37 extKeyUsage [verifie:RFC 5280, 4.2.1.6 and 4.2.1.12] and
# 1.3.6.1.5.5.7.3.4, as the content octets of an OBJECT IDENTIFIER [constate:2026-10-11,
# `openssl asn1parse -genstr OID:<oid>` under OpenSSL 3.6.4 and LibreSSL 3.3.6 writes 06 03 55 1d 11,
# 06 03 55 1d 25, 06 08 2b 06 01 05 05 07 03 04].
my $OID_SAN   = "\x55\x1d\x11";
my $OID_EKU   = "\x55\x1d\x25";
my $OID_EPROT = "\x2b\x06\x01\x05\x05\x07\x03\x04";
my $DER_BAD   = "certificate not readable as DER -- refused\n";

# One TLV at the head of $s: (tag, content, rest), () when the bytes are not one. Short and long
# form of the length, at most 4 octets of it; a tag number past 30 (low five bits all set) is
# never one of the fields read here [infere: X.690 8.1.2-8.1.3, not read here; false if a
# certificate openssl reads carries an indefinite length or a high tag number in these fields,
# which this reader then refuses as unreadable].
sub der_tlv {
    my ($s) = @_;
    return () if length($s) < 2;
    my ($tag, $len) = unpack('C C', $s);
    return () if ($tag & 0x1f) == 0x1f;
    my $off = 2;
    if ($len & 0x80) {
        my $n = $len & 0x7f;
        return () if $n < 1 || $n > 4 || length($s) < 2 + $n;
        $len = 0;
        $len = $len * 256 + ord(substr($s, $off++, 1)) for 1 .. $n;
    }
    return () if length($s) < $off + $len;
    return ($tag, substr($s, $off, $len), substr($s, $off + $len));
}

# The TLVs a constructed content holds, [tag, content] each, in order; dies when the bytes do not
# split exactly into TLVs.
sub der_items {
    my ($s) = @_;
    my @out;
    while (length $s) {
        my ($t, $c, $r) = der_tlv($s) or die $DER_BAD;
        push @out, [$t, $c];
        $s = $r;
    }
    return @out;
}

# The content of the one TLV $s holds, of tag $want; dies otherwise.
sub der_one {
    my ($s, $want) = @_;
    my ($t, $c, $r) = der_tlv($s) or die $DER_BAD;
    die $DER_BAD unless $t == $want && $r eq '';
    return $c;
}

# Certificate ::= SEQUENCE { tbsCertificate, signatureAlgorithm, signature }; TBSCertificate ::=
# SEQUENCE { [0] version OPTIONAL, serialNumber, signature, issuer, validity, subject,
# subjectPublicKeyInfo, [1] [2] OPTIONAL, [3] extensions OPTIONAL } [verifie:RFC 5280, 4.1].
# Returns the content of the subject Name and the extnValue of each extension by OID content. An
# extension present twice is a refusal: "MUST NOT include more than one instance of a particular
# extension" [verifie:RFC 5280, 4.2], and two readers could each take another one.
sub cert_der_fields {
    my ($der) = @_;
    my @c = der_items(der_one($der, 0x30));
    die $DER_BAD unless @c == 3 && $c[0][0] == 0x30;
    my @f = der_items($c[0][1]);
    shift @f if @f && $f[0][0] == 0xa0;
    die $DER_BAD unless @f >= 6 && $f[4][0] == 0x30;
    my %ext;
    for my $x (grep { $_->[0] == 0xa3 } @f[6 .. $#f]) {
        for my $e (der_items(der_one($x->[1], 0x30))) {
            die $DER_BAD unless $e->[0] == 0x30;
            my @p = der_items($e->[1]);
            die $DER_BAD unless @p >= 2 && $p[0][0] == 0x06 && $p[-1][0] == 0x04;
            die "certificate carrying the extension " . unpack('H*', $p[0][1]) . " (OID content, hex)"
              . " twice -- refused\n" if exists $ext{ $p[0][1] };
            $ext{ $p[0][1] } = $p[-1][1];
        }
    }
    return ($f[4][1], \%ext);
}

# The universal string types: UTF8String 12, NumericString 18, PrintableString 19, TeletexString
# 20, VideotexString 21, IA5String 22, GraphicString 25, VisibleString 26, GeneralString 27,
# UniversalString 28, BMPString 30 [verifie:openbsd/src lib/libcrypto/asn1/asn1.h 1.95:107-123].
my %DER_STRING = map { $_ => 1 } (12, 18, 19, 20, 21, 22, 25, 26, 27, 28, 30);

# Whether a string under $s, at any depth, holds a control character: a universal string type,
# and with $gn the implicit IA5String of a GeneralName, rfc822Name [1], dNSName [2],
# uniformResourceIdentifier [6] [verifie:RFC 5280, 4.2.1.6]. The characters are read per type,
# BMPString two octets each and UniversalString four, big-endian, as openssl reads them
# [verifie:lib/libcrypto/asn1/a_strex.c 1.38:205-220, do_buf]: an ASCII letter there carries 0x00
# octets. UTF-8 is read octet by octet: "US-ASCII octet values do not appear otherwise in a UTF-8
# encoded character stream" [verifie:RFC 3629, 1].
#
# A string in the constructed form is a refusal, before any reading: "For bitstring, octetstring
# and restricted character string types, the constructed form of encoding shall not be used"
# [verifie:ITU-T X.690 (02/2021), 10.2], and a certificate is signed over its DER [verifie:RFC
# 5280, 4.1]. openssl reads that form all the same, as BER allows, and prints its fragments joined:
# a fragment the check of a primitive string never sees then carries the forged line again
# [constate:2026-10-11, a subjectAltName [1] holding an OCTET STRING with "\n": `-email` prints the
# line under OpenSSL 3.6.4 and LibreSSL 3.3.6, OpenSSL 3 `verify -purpose smimesign` says OK]. The
# universal types so refused: BIT STRING 3, OCTET STRING 4 and the string types above, constructed
# (bit 0x20) at any depth -- inside otherName and directoryName too. In a GeneralName, under
# IMPLICIT TAGS, rfc822Name [1], dNSName [2] and uniformResourceIdentifier [6] are IA5String,
# iPAddress [7] an OCTET STRING [verifie:RFC 5280, A.2, PKIX1Implicit88]: 0xa1, 0xa2, 0xa6, 0xa7
# are those strings constructed, refused at the level of the GeneralName alone. otherName [0],
# x400Address [3], directoryName [4] and ediPartyName [5] are constructed by their own type and
# read on; inside them a [1] or [2] belongs to another type (partyName [1] of EDIPartyName,
# [verifie:RFC 5280, 4.2.1.6]). With $gn, $s is the extnValue of subjectAltName, one GeneralNames
# SEQUENCE: its items, depth 1, are the GeneralNames. cert_info refuses every GeneralName but
# rfc822Name before this reading (cert_san_allow); der_ctl still judges any GeneralNames alone.
my %DER_PRIM = map { $_ => 1 } (3, 4, keys %DER_STRING);
my %GN_PRIM  = map { $_ => 1 } (0xa1, 0xa2, 0xa6, 0xa7);
sub der_ctl {
    my ($s, $gn, $depth) = @_;
    $depth //= 0;
    for my $it (der_items($s)) {
        my ($t, $v) = @$it;
        die "certificate not DER: constructed string in " . ($gn ? 'subjectAltName' : 'the subject')
          . " -- refused\n"
            if ($t & 0xe0) == 0x20 && $DER_PRIM{$t & 0x1f} || $gn && $depth == 1 && $GN_PRIM{$t};
        if ($t & 0x20) { return 1 if der_ctl($v, $gn, $depth + 1); next; }
        next unless $DER_STRING{$t} || ($gn && ($t == 0x81 || $t == 0x82 || $t == 0x86));
        my @cp = $t == 30 ? unpack('n*', $v) : $t == 28 ? unpack('N*', $v) : unpack('C*', $v);
        return 1 if grep { $_ < 0x20 || $_ == 0x7f } @cp;
    }
    return 0;
}

# subjectAltName holds rfc822Name [1] entries and nothing else: any other GeneralName is a
# refusal, named by its tag [verifie:RFC 5280, 4.2.1.6, GeneralName ::= CHOICE, [0] to [8]], a tag
# past them `unknown`. An S/MIME certificate of a person of the fleet needs rfc822Name alone: cert
# add takes it on one rfc822Name that is an address of the entry, and reads nothing else of the
# extension. Logins and aliases keep to [a-z0-9@.-] (slug, canonical_alias), ASCII, and the
# SmtpUTF8Mailbox otherName "MUST NOT be used unless the local-part of the email address contains
# non-ASCII characters" [verifie:RFC 8398, 3]. A value openssl cannot decode is printed raw by
# -text: an otherName UPN 1.3.6.1.4.1.311.20.2.3 holding an OCTET STRING with newlines, a primitive
# string der_ctl does not read, prints the extension raw, forged lines and all [constate:2026-10-11,
# OpenSSL 3.6.4; LibreSSL 3.3.6 prints `othername:<unsupported>`]. An allowlist ends the class
# instead of chasing the types openssl prints. 0xa1, an rfc822Name in the constructed form DER
# forbids, passes here to der_ctl, which refuses it as such.
my %GN_TYPE = (0 => 'an otherName', 2 => 'a dNSName', 3 => 'an x400Address', 4 => 'a directoryName',
               5 => 'an ediPartyName', 6 => 'a uniformResourceIdentifier', 7 => 'an iPAddress',
               8 => 'a registeredID');
sub cert_san_allow {
    my ($ext) = @_;
    return unless defined $ext->{$OID_SAN};
    for my $gn (der_items(der_one($ext->{$OID_SAN}, 0x30))) {
        my $t = $gn->[0];
        next if $t == 0x81 || $t == 0xa1;
        my $type = ($t & 0xc0) == 0x80 && $GN_TYPE{$t & 0x1f} ? $GN_TYPE{$t & 0x1f}
                 : sprintf('an unknown (tag 0x%02x)', $t);
        die "subjectAltName holds $type entry: only rfc822Name is accepted -- refused\n";
    }
}

# The rfc822Name values of subjectAltName, as the DER holds them.
sub cert_san_emails {
    my ($ext) = @_;
    return () unless defined $ext->{$OID_SAN};
    return map { $_->[1] } grep { $_->[0] == 0x81 } der_items(der_one($ext->{$OID_SAN}, 0x30));
}

# 1 when extKeyUsage lists id-kp-emailProtection, 0 otherwise, the extension absent included. An
# element that is no OBJECT IDENTIFIER is a refusal: the syntax is "SEQUENCE SIZE (1..MAX) OF
# KeyPurposeId", "KeyPurposeId ::= OBJECT IDENTIFIER" [verifie:RFC 5280, 4.2.1.12], and openssl
# prints an extension it cannot decode raw, a UTF8String with newlines as lines of its own
# [constate:2026-10-11, OpenSSL 3.6.4 and LibreSSL 3.3.6].
sub cert_eku_smime {
    my ($ext) = @_;
    return 0 unless defined $ext->{$OID_EKU};
    my @kp = der_items(der_one($ext->{$OID_EKU}, 0x30));
    die "extendedKeyUsage holds an element that is no OBJECT IDENTIFIER -- refused\n"
        if !@kp || grep { $_->[0] != 0x06 } @kp;
    return (grep { $_->[1] eq $OID_EPROT } @kp) ? 1 : 0;
}

# What one PEM certificate says, read where its content cannot pass for structure.
#
# No text of openssl serves for a decision: each one prints the strings of a certificate raw.
# -text writes a subjectAltName rfc822Name as `email:%.*s`, its bytes as they are
# [verifie:openbsd/src lib/libcrypto/x509/x509_alt.c 1.20:288-291, GENERAL_NAME_print]; -email
# writes each address `%s\n` [verifie:usr.bin/openssl/x509.c 1.44:1081-1087]; asn1parse writes
# the content of a string with BIO_write [verifie:lib/libcrypto/asn1/asn1_par.c 1.35:211-224]. A
# newline inside a value then prints a line of its own: `subject=CN=Forged`, `notAfter=...`, an
# `X509v3 Extended Key Usage:` header with `E-mail Protection` under it [constate:2026-10-11,
# OpenSSL 3.6.4 and LibreSSL 3.3.6, a SAN rfc822Name holding "\n"]. The DER is what openssl itself
# reads: a length, never a delimiter, ends each value, so no byte inside one can end it early or
# start a field [infere: X.690 8.1, identifier, length, contents, not read here; false if a
# certificate field ended on a delimiter octet].
#
# Hence, from the DER, read here: a refusal when subjectAltName holds another GeneralName than
# rfc822Name (cert_san_allow), and when a string of the subject or of subjectAltName holds a
# control character (0x00-0x1f, 0x7f) -- a value that would print as more than itself is not one
# to publish -- or is encoded in the constructed form DER forbids (der_ctl); whether
# extendedKeyUsage carries id-kp-emailProtection 1.3.6.1.5.5.7.3.4
# [verifie:RFC 5280, 4.2.1.12]; the rfc822Name values of subjectAltName [verifie:RFC 5280,
# 4.2.1.6, rfc822Name [1] IA5String] -- not -email, which adds the emailAddress of the subject
# [verifie:lib/libcrypto/x509/x509_utl.c 1.29:639-648, 694-712, get_email], when the rule is an
# address of subjectAltName. From openssl, each in a run of its own once the control characters
# are refused: the CN, under -nameopt RFC2253, whose escapes dn_cn reads; notAfter, -enddate, a
# time openssl formats itself. LibreSSL titles the subject `subject= CN=...`, a space after the '='
# [verifie:usr.bin/openssl/x509.c, print_name "subject= "; OpenSSL 3.6 on the Mac writes none] --
# hence the \s*. A file openssl cannot read as a certificate is the one-line refusal.
sub cert_info {
    my ($file) = @_;
    my ($rc, $der) = openssl_out('x509', '-in', $file, '-outform', 'der');
    die "not a PEM certificate: $file\n" if $rc;
    my ($subject, $ext) = cert_der_fields($der);
    cert_san_allow($ext);
    my @where;
    push @where, 'the subject' if der_ctl($subject, 0);
    push @where, 'subjectAltName' if defined $ext->{$OID_SAN} && der_ctl($ext->{$OID_SAN}, 1);
    die "certificate holding a control character in " . join(' and ', @where) . " -- refused: such"
      . " a value prints as more than itself\n" if @where;
    return { cn => cert_cn($file), emails => [ cert_san_emails($ext) ], smime => cert_eku_smime($ext),
             notafter => cert_notafter($file) };
}

# The CN of the subject, from a run of its own under RFC 2253.
sub cert_cn {
    my ($file) = @_;
    my ($rc, $txt) = openssl_out('x509', '-in', $file, '-noout', '-nameopt', 'RFC2253', '-subject');
    die "not a PEM certificate: $file\n" if $rc;
    my ($subject) = $txt =~ /^subject=\s*([^\n]*)/m;
    return dn_cn($subject);
}

# notAfter as openssl prints it, from a run of its own.
sub cert_notafter {
    my ($file) = @_;
    my ($rc, $txt) = openssl_out('x509', '-in', $file, '-noout', '-enddate');
    die "not a PEM certificate: $file\n" if $rc;
    my ($d) = $txt =~ /^notAfter=([^\n]*)/m;
    return $d;
}

# The CN of an RFC 2253 name, '' without one. The string is cut on the ',' and '+' no backslash
# escapes -- RDNs and the AVAs of a multi-valued RDN -- and the value taken is the one whose type
# is CN, never a "CN=" that sits inside another value: `O=Evil\, CN=Fake,CN=Real` names Real
# [verifie:RFC 2253, 2.2 to 2.4 and 3, `pair = "\" ( special / "\" / QUOTATION / hexpair )`].
# The backslash before a special character goes; a \HH pair stays as written, so a control
# character openssl escaped never becomes one again in a line printed here.
sub dn_cn {
    my ($dn) = @_;
    for my $ava (($dn // '') =~ /((?:\\.|[^,+\\])+)/gs) {
        my ($type, $val) = $ava =~ /^\s*([^=]+?)\s*=(.*)\z/s or next;
        next unless lc $type eq 'cn';
        $val =~ s/\\([,=+<>#;"\\ ])/$1/g;
        return $val;
    }
    return '';
}

# A text of openssl made safe to print: every byte outside printable ASCII 0x20-0x7e, tab and
# newline shown as \xHH -- DEL 0x7f included. A certificate is anybody's data; a control character in it must not reach the terminal
# as one.
sub printable {
    my ($s) = @_;
    $s = '' unless defined $s;
    $s =~ s/([^\x20-\x7e\t\n])/sprintf('\\x%02X', ord $1)/ge;
    return $s;
}

# The entry read for the certificate verbs: the two attributes as the directory holds them (keys
# `usercertificate;binary` and `usersmimecertificate`), the addresses the certificate must name one
# of. An attribute requested with an option slapd refuses is not an error: it becomes an undefined
# attribute and is simply never returned [verifie:git.openldap.org OPENLDAP_REL_ENG_2_6
# servers/slapd/search.c:155-160], so `userSMIMECertificate;binary` here would hide the value.
sub ldap_cert_entry {
    my ($user) = @_;
    my $c = ldap_conf();
    my $e = ldap_entry($user, 'mail', 'mailLocalAddress', 'userCertificate;binary',
                       'userSMIMECertificate')
        or die "auth=ldap: no entry uid=$user under $c->{basedn}\n";
    return $e;
}

# The certificates a PKCS#7 lists, each as DER, in the order openssl prints them, none when openssl
# cannot read the value. -print_certs writes each one PEM, whose body is the base64 of the DER
# Certificate [verifie:RFC 7468, 2 and 5.1]: decoded here, not handed back to openssl.
sub p7_certs {
    my ($p7) = @_;
    my ($rc, $out) = openssl_in($p7, 'pkcs7', '-inform', 'der', '-print_certs');
    return () if $rc;
    return map { (my $b = $_) =~ s/-----(?:BEGIN|END) CERTIFICATE-----//g; decode_base64($b) }
           pem_blocks($out);
}

# The certificates an entry holds, one hash each: fp (sha256 hex of the leaf DER, lowercase), der
# (the userCertificate value, undef when unpaired), p7 (the userSMIMECertificate value, undef when
# unpaired), leaf (the DER openssl is shown). A userCertificate value takes the first
# userSMIMECertificate value not taken yet that lists its fingerprint. A userSMIMECertificate value
# left over is named by its first certificate, the leaf as crl2pkcs7 writes it, or by the sha256 of
# the value itself when openssl reads no certificate in it.
sub cert_held {
    my ($e) = @_;
    my @sm;
    for my $p7 (@{ $e->{usersmimecertificate} // [] }) {
        my @certs = p7_certs($p7);
        push @sm, { p7 => $p7, certs => \@certs, fps => [ map { sha256_hex($_) } @certs ] };
    }
    my @held;
    for my $der (@{ $e->{'usercertificate;binary'} // [] }) {
        my $fp = sha256_hex($der);
        my ($s) = grep { my $x = $_; !$x->{used} && grep { $_ eq $fp } @{ $x->{fps} } } @sm;
        $s->{used} = 1 if $s;
        push @held, { fp => $fp, der => $der, leaf => $der, p7 => $s ? $s->{p7} : undef };
    }
    for my $s (grep { !$_->{used} } @sm) {
        my $first = $s->{certs}[0];
        push @held, { fp => sha256_hex($first // $s->{p7}), der => undef, leaf => $first, p7 => $s->{p7} };
    }
    return @held;
}

# What the entry of a login holds, for show and list: () without an entry or a certificate.
sub ldap_cert_held {
    my ($user) = @_;
    my $e = ldap_entry($user, 'userCertificate;binary', 'userSMIMECertificate') or return ();
    return cert_held($e);
}

# The CERTIFICATE blocks of a file, () when it cannot be read.
sub pem_file_blocks {
    my ($f) = @_;
    open(my $fh, '<', $f) or return ();
    my $t = do { local $/; <$fh> };
    close $fh;
    return pem_blocks($t // '');
}

# The leaf verifies for S/MIME signing against the anchors, the chain of the file as untrusted
# intermediates. Anchors: the certificates of smime_cas, plus those of --ca for this add alone;
# none at all is a refusal, never an unchecked add. -CAfile, -untrusted and -purpose smimesign
# are options of LibreSSL's verify [verifie:man.openbsd.org/openssl.1, VERIFY]; its rc is 2 on
# a failed chain and `<file>: OK` is printed on success alone [verifie:openbsd/src
# usr.bin/openssl/verify.c:363, 392-398] -- both are required, the callback of verify continuing
# past some errors [verifie:verify.c:411-450, cb]. The reason a refusal names is the
# `error N at D depth lookup:` line of openssl, through printable().
# The anchors are those two sources and nothing else. Without -CApath, verify adds the default
# directory lookup, /etc/ssl/certs [verifie:openbsd/src usr.bin/openssl/verify.c 1.18:308-320,
# X509_LOOKUP_add_dir(lookup, NULL, X509_FILETYPE_DEFAULT); lib/libcrypto/x509/by_dir.c
# 1.49:122-127, X509_get_default_cert_dir(); x509_def.c:78-80; crypto_local.h:69-73], and OpenSSL 3
# reads SSL_CERT_DIR there too [constate:2026-10-11, OpenSSL 3.6.4 on the Mac] -- a CA of the
# system would sign for a person. Hence -CApath on an empty directory made here; -CAfile given,
# the default file is not loaded either [verifie:verify.c 1.18:297-306].
sub cert_verify {
    my ($dir, $leaf_f, $chain, $ca) = @_;
    my $cas = $CONF->{smime_cas} // '/etc/mail/smime-cas.pem';
    my @anchor = -r $cas ? pem_file_blocks($cas) : ();
    my @from = @anchor ? ($cas) : ();
    if (defined $ca) {
        my @extra = pem_file_blocks($ca);
        die "--ca $ca: no certificate readable there\n" unless @extra;
        push @anchor, @extra;
        push @from, $ca;
    }
    die "no trust anchor: $cas absent or without a certificate, and no --ca given --"
      . " the leaf cannot be verified\n" unless @anchor;
    my $anchor_f = "$dir/anchors.pem";
    open(my $af, '>', $anchor_f) or die "$anchor_f: $!\n";
    print $af @anchor;
    close $af;
    my @untrusted;
    if (@$chain) {
        my $u = "$dir/untrusted.pem";
        open(my $uf, '>', $u) or die "$u: $!\n";
        print $uf @$chain;
        close $uf;
        @untrusted = ('-untrusted', $u);
    }
    my $capath = "$dir/capath";
    -d $capath or mkdir($capath, 0700) or die "$capath: $!\n";
    my ($rc, $ok, $err) = openssl_out('verify', '-CAfile', $anchor_f, '-CApath', $capath, @untrusted,
                                      '-purpose', 'smimesign', $leaf_f);
    return if !$rc && $ok =~ /: OK$/m;
    my $out = $ok . $err;
    my ($why) = $out =~ /error \d+ at \d+ depth lookup:\s*([^\n]*)/;
    ($why) = $out =~ /verification failed:\s*([^\n]*)/ unless defined $why;
    $why = (split /\n/, $out)[-1] // "rc=$rc" unless defined $why && length $why;
    die printable("certificate does not verify for S/MIME signing against " . join(' + ', @from)
                . ": $why") . "\n";
}

# Bounds on the file of `cert add`, before anything is parsed: a leaf and its chain hold a few
# certificates of a few KiB each, and each block costs an openssl run. 64 KiB and 10 blocks leave
# room for any real chain and stop a file that is something else.
my $CERT_FILE_MAX   = 64 * 1024;
my $CERT_BLOCKS_MAX = 10;

# `cert add`: every check fatal with its reason, then ONE modify adding one value to each attribute
# -- the certificates already held stay as they are. The chain is what follows the leaf in the
# file, and nothing else: smime_cas serves the verification alone. Returns what the
# caller prints. Every message and value that carries what the certificate or openssl says goes
# through printable(), as in cert show: a byte past ASCII reaches the terminal as \xHH.
sub ldap_cert_add {
    my ($user, $file, $ca) = @_;
    my $e = ldap_cert_entry($user);
    open(my $fh, '<', $file) or die "$file: $!\n";
    # One byte past the bound read at most: a pipe or a device has no size to ask beforehand.
    defined read($fh, my $pem, $CERT_FILE_MAX + 1) or die "$file: $!\n";
    close $fh;
    die "$file: over the 64 KiB a certificate and its chain need -- refused\n"
        if length $pem > $CERT_FILE_MAX;
    my @blocks = pem_blocks($pem // '');
    die "not a PEM certificate: $file\n" unless @blocks;
    die "$file: " . scalar(@blocks) . " certificate blocks, over the $CERT_BLOCKS_MAX a leaf and its"
      . " chain need -- refused\n" if @blocks > $CERT_BLOCKS_MAX;
    my ($leaf, @chain) = @blocks;

    my $dir = tempdir(CLEANUP => 1);
    my $leaf_f = "$dir/leaf.pem";
    open(my $lf, '>', $leaf_f) or die "$leaf_f: $!\n";
    print $lf $leaf;
    close $lf;

    my $i = cert_info($leaf_f);
    die "certificate without the emailProtection extendedKeyUsage, not an S/MIME certificate\n"
        unless $i->{smime};
    my ($rc) = openssl_out('x509', '-in', $leaf_f, '-noout', '-checkend', '0');
    die printable("certificate expired (notAfter " . ($i->{notafter} // '?') . ")") . "\n" if $rc;
    # One subjectAltName address of the entry suffices; the others may name any mailbox.
    my %addr = map { lc $_ => 1 } (@{ $e->{mail} // [] }, @{ $e->{maillocaladdress} // [] });
    my ($email) = grep { $addr{lc $_} } @{ $i->{emails} };
    die printable("certificate names " . (@{ $i->{emails} } ? join(', ', @{ $i->{emails} }) : 'no email')
                . " in subjectAltName, none of them an address of $user (" . join(', ', sort keys %addr) . ")")
      . "\n" unless defined $email;

    my ($drc, $der, $derr) = openssl_out('x509', '-in', $leaf_f, '-outform', 'der');
    die printable("openssl x509 -outform der failed (rc=$drc): $derr") . "\n" if $drc;
    my $fp = sha256_hex($der);
    die "certificate already published on $user: sha256 $fp\n"
        if grep { $_->{fp} eq $fp } cert_held($e);
    cert_verify($dir, $leaf_f, \@chain, $ca);

    # The PKCS#7 carries the leaf and what the file gave after it, never the anchors of
    # smime_cas: that file holds roots a mail client trusts on its own, 91 certificates and
    # 138 600 bytes on the fleet [infra.git roles/mail_smtpd/files/smime-roots.pem, 2026-10-12],
    # which would land in a value of one person. A leaf given alone is published alone; its
    # intermediates, when it has any, come with it in the file.
    my $chain_f = "$dir/chain.pem";
    open(my $ch, '>', $chain_f) or die "$chain_f: $!\n";
    print $ch $leaf, @chain;
    close $ch;
    my ($prc, $p7, $perr) = openssl_out('crl2pkcs7', '-nocrl', '-certfile', $chain_f, '-outform', 'der');
    die printable("openssl crl2pkcs7 failed (rc=$prc): $perr") . "\n" if $prc;

    ldap_modify('dn: ' . ldap_dn($user) . "\nchangetype: modify\n"
              . "add: userCertificate;binary\n" . ldif_bin('userCertificate;binary', $der) . "-\n"
              . "add: userSMIMECertificate\n" . ldif_bin('userSMIMECertificate', $p7) . "-\n");
    return { cn => printable($i->{cn}), email => printable($email), expires => date_of($i->{notafter}) // '?',
             chain => 1 + scalar(@chain), fp => $fp };
}

# `cert del`: the certificate of that fingerprint -- colons and case ignored, exactly one match
# or a refusal naming those held -- or every one without it. ONE modify, which REPLACES each
# attribute touched with the values kept, as read, and DELETES an attribute left with none: named
# only when present, deleting an absent attribute being noSuchAttribute (16), fatal to the record
# [verifie:RFC 4511, 4.6 and Appendix A.2]. No delete of one value: userSMIMECertificate has no
# EQUALITY rule [verifie:openldap master servers/slapd/schema/inetorgperson.schema:120-123], and a
# value cannot be matched to be removed without one [infere: RFC 4511, 4.6, the values of a delete
# are matched by equality; false if slapd compares a Binary value byte for byte]. Spellings as read
# and written: `userCertificate;binary` (the Certificate syntax requires the option, a transfer
# option and not a tag [verifie:RFC 4522, 2]) and plain `userSMIMECertificate` (see the head of
# this section). Returns the fingerprints removed, none when nothing was held.
sub ldap_cert_del {
    my ($user, $want) = @_;
    my $e = ldap_cert_entry($user);
    my @held = cert_held($e);
    return () unless @held;
    my @gone = @held;
    if (defined $want) {
        (my $w = lc $want) =~ s/://g;
        die "'$want' is not a sha256: 64 hex digits expected, colons and case free\n"
            unless $w =~ /^[0-9a-f]{64}\z/;
        @gone = grep { $_->{fp} eq $w } @held;
        die "no single certificate of $user has the sha256 $want (held: "
          . join(', ', map { $_->{fp} } @held) . ")\n" unless @gone == 1;
    }
    my %g = map { ($_ => 1) } @gone;
    my @keep = grep { !$g{$_} } @held;
    my $ldif = 'dn: ' . ldap_dn($user) . "\nchangetype: modify\n";
    for my $at (['userCertificate;binary', 'der'], ['userSMIMECertificate', 'p7']) {
        my ($attr, $k) = @$at;
        next unless grep { defined $_->{$k} } @gone;
        my @v = map { $_->{$k} } grep { defined $_->{$k} } @keep;
        $ldif .= @v ? "replace: $attr\n" . join('', map { ldif_bin($attr, $_) } @v) . "-\n"
                    : "delete: $attr\n-\n";
    }
    ldap_modify($ldif);
    return map { $_->{fp} } @gone;
}

# The expiry of one DER certificate, YYYY-MM-DD, or undef.
sub der_enddate {
    my ($der) = @_;
    return undef unless defined $der && length $der;
    my ($rc, $out) = openssl_in($der, 'x509', '-inform', 'der', '-noout', '-enddate');
    return undef if $rc;
    return date_of($out);
}

# `cert show`: one block per certificate held, what openssl says of the leaf, subject through
# fingerprint, then `unpaired: <attribute>` for a value without its partner; sorted by expiry,
# nearest first. () when the entry holds none. -nameopt RFC2253 as in cert_info: without it
# LibreSSL's nmflag stays 0 = XN_FLAG_COMPAT and print_name takes the X509_NAME_oneline branch,
# `subject= /CN=...`; with it both flavours print `CN=...` behind the title [verifie:openbsd/src
# usr.bin/openssl/x509.c cfg.nmflag, apps.c print_name; lib/libcrypto/x509/x509.h
# XN_FLAG_COMPAT 0].
sub ldap_cert_show {
    my ($user) = @_;
    my @blocks;
    for my $c (ldap_cert_held($user)) {
        my ($out, $date) = ('', undef);
        if (defined $c->{leaf} && length $c->{leaf}) {
            # Three runs, so that each line says what it is. Under RFC2253 the names escape a
            # control character as \HH; -email prints the addresses of the subject and of
            # subjectAltName raw, one per line, and a newline inside one would print a line of
            # its own -- `subject=...` forged under the real one [constate:2026-10-11, OpenSSL
            # 3.6.4 and LibreSSL 3.3.6, a SAN rfc822Name holding "\n"]. Each line of that run is
            # labelled `email=`: a forged line reads as one more address, never as another field.
            my @txt;
            for my $opt (['-nameopt', 'RFC2253', '-subject', '-issuer'], ['-email'],
                         ['-enddate', '-fingerprint', '-sha256']) {
                my ($rc, $t) = openssl_in($c->{leaf}, 'x509', '-inform', 'der', '-noout', @$opt);
                die "openssl x509 -inform der failed (rc=$rc) on the certificate $c->{fp} of $user\n" if $rc;
                push @txt, $t;
            }
            $out = printable($txt[0] . join('', map { "email=$_\n" } grep { length } split /\n/, $txt[1])
                             . $txt[2]);
            ($date) = map { date_of($_) } $out =~ /^(notAfter=.*)$/m;
        } else {
            $out = "no certificate readable in the value, sha256 of the value $c->{fp}\n";
        }
        $out .= "unpaired: userCertificate;binary\n" unless defined $c->{p7};
        $out .= "unpaired: userSMIMECertificate\n" unless defined $c->{der};
        push @blocks, [ $date // '9999-99-99', $c->{fp}, $out ];
    }
    return map { $_->[2] } sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @blocks;
}

# The column of `list`: the nearest expiry, `/<n>` behind it when n >= 2 certificates are held,
# undef with none.
sub ldap_cert_enddate {
    my ($user) = @_;
    my @held = ldap_cert_held($user);
    return undef unless @held;
    my ($first) = sort { $a cmp $b } grep { defined } map { der_enddate($_->{leaf}) } @held;
    return ($first // '?') . (@held >= 2 ? '/' . scalar(@held) : '');
}

# ----------------------------------------------------------------------- the store ------------
sub store_is_cyrus { return $STORE eq 'cyrus'; }

sub imap_admin_pw {
    my $f = $CONF->{admin_pw} // '/etc/cyrus/cyradm.pw';
    open(my $fh, '<', $f) or die "read $f: $!\n";
    my $pw = <$fh>;
    close $fh;
    defined $pw or die "$f empty\n";
    $pw =~ s/\s+\z//;
    return $pw;
}

sub imap_admin {
    my $pw = imap_admin_pw();
    require Cyrus::IMAP::Admin;
    my $c = Cyrus::IMAP::Admin->new($IMAP_HOST, $IMAP_PORT)
        or die "imap admin connection to $IMAP_HOST:$IMAP_PORT failed\n";
    $c->authenticate(-user => $IMAP_ADMIN, -password => $pw, -mechanism => 'PLAIN')
        or die "auth $IMAP_ADMIN: " . ($c->error // '?') . "\n";
    return ($c, $pw);
}

# The mailbox of a person. Cyrus does NOT autocreate it for a DAV-only account (autocreate
# covers imap/pop/lmtp), and without an INBOX the collection autoprovision answers 503. Dovecot
# creates it at the first delivery, so there is nothing to do and nothing to report as failed.
sub store_create_box {
    my ($c, $user) = @_;
    unless (store_is_cyrus()) {
        print "store  $STORE: the mailbox of $user is created at delivery\n";
        return 1;
    }
    if ($c->create("user/$user")) { print "created  user/$user\n"; return 1; }
    my $e = $c->error // '?';
    # Already there after store_box_guard found nothing: made between the two, and not this
    # person's -- the same refusal, the account just created left for the operator to remove.
    die "create user/$user: $e -- a mailbox of that name appeared after the check; the account"
      . " $user exists, its mailbox is not hers: remove the account or the mailbox by hand\n"
        if $e =~ /already exists/i;
    die "create user/$user: $e\n";
}

# The mailboxes a login already has in the store, before any account carries it. Cyrus keeps
# user/<login> -- the mail, the sieve scripts, the ACLs that share it, the lists naming its
# address -- when the entry goes another way: luminary deletes the entry and nothing else. A new
# person on that login would open all of it. Refused before anything is written; the operator
# archives and deletes the old box on purpose, or takes another login. Same two patterns as
# store_purge_boxes: the INBOX, and what sits under it.
sub store_box_guard {
    my ($c, $user) = @_;
    my %seen;
    my @mb = grep { defined && length && !$seen{$_}++ }
             map  { ref($_) ? $_->[0] : $_ }
             map  { $c->listmailbox($_) } ("user/$user", "user/$user/*");
    return unless @mb;
    die "mailbox user/$user already in the store (" . scalar(@mb) . " mailbox(es)) and no account"
      . " carries $user: a new person would inherit its mail, sieve, shares and lists -- refused."
      . " Archive and delete it on purpose (cyradm as $IMAP_ADMIN), or choose another login\n";
}

# The mailboxes of a person, deleted deepest first: a parent cannot go while it still holds
# children. Exactly the INBOX and what sits under it, the two patterns of verb_add: in LIST,
# `*` matches the hierarchy delimiter too [verifie:RFC 3501, 6.3.8], so `user/jg*` would reach
# user/jgrosjean and everything below it.
sub store_purge_boxes {
    my ($c, $user) = @_;
    my %seen;
    my @mb = grep { defined && length && !$seen{$_}++ }
             map  { ref($_) ? $_->[0] : $_ }
             map  { $c->listmailbox($_) } ("user/$user", "user/$user/*");
    for my $name (sort { length($b) <=> length($a) } @mb) {
        $c->setacl($name, $IMAP_ADMIN, 'lrswipkxtecdan');
        if ($c->delete($name)) { print "del  $name\n"; }
        else { warn "!! del $name: " . ($c->error // '?') . "\n"; }
    }
}

# --------------------------------------------------------------- sieve, through managesieve ---
# sieve_get_handle takes the NAME of a function four times (a string, not a reference) and calls
# it with ($type, $prompt) [verifie:/usr/local/cyrus/bin/sieveshell, sub prompt]. One function
# answers the four. Admin impersonation: username = the target account, authname = _cyrusadm.
our ($SV_USER, $SV_AUTH, $SV_PW) = ('', '', '');
sub sv_prompt {
    my ($type) = @_;
    return $SV_USER if $type eq 'username';
    return $SV_AUTH if $type eq 'authname';
    return $SV_PW   if $type eq 'password';
    return '';
}

our ($SV_ACTIVE, %SV_HAVE);
sub sv_list_cb {
    my ($name, $isactive) = @_;
    $SV_HAVE{$name} = 1;
    $SV_ACTIVE = $name if $isactive;
}

sub _norm {
    my ($s) = @_;
    $s = '' unless defined $s;
    $s =~ s/\r\n/\n/g;
    $s =~ s/\A\s+|\s+\z//g;
    return $s;
}

# Returns (state, message), state being 'installed' / 'ok' / 'failed'. The remote script is
# compared with the local file and rewritten only when it differs, else the ansible task would
# report `changed` on every pass. Activation happens ONLY when no other script is active: a user
# who writes their own rules keeps them.
sub sieve_sync {
    my ($user, $want, $adminpw) = @_;
    local $SV_USER   = $user;
    local $SV_AUTH   = $IMAP_ADMIN;
    local $SV_PW     = $adminpw;
    local $SV_ACTIVE = undef;
    local %SV_HAVE   = ();

    my $o = sieve_get_handle($IMAP_HOST, 'sv_prompt', 'sv_prompt', 'sv_prompt', 'sv_prompt');
    return ('failed', 'managesieve connection failed') unless defined $o;

    my $ret = sieve_list($o, 'sv_list_cb');
    if ($ret != 0) {
        my $e = sieve_get_error($o) // '?';
        sieve_logout($o);
        return ('failed', "list: $e");
    }

    my $state = 'ok';
    my $remote = '';
    sieve_get($o, $SIEVE_NAME, $remote) if $SV_HAVE{$SIEVE_NAME};
    if (!$SV_HAVE{$SIEVE_NAME} || _norm($remote) ne _norm($want)) {
        if (sieve_put_file_withdest($o, $SIEVE_SRC, $SIEVE_NAME) != 0) {
            my $e = sieve_get_error($o) // '?';
            sieve_logout($o);
            return ('failed', "put: $e");
        }
        $state = 'installed';
    }
    if (!defined $SV_ACTIVE) {
        if (sieve_activate($o, $SIEVE_NAME) != 0) {
            my $e = sieve_get_error($o) // '?';
            sieve_logout($o);
            return ('failed', "activate: $e");
        }
        $state = 'installed';
    }
    sieve_logout($o);
    return ($state, '');
}

# The managesieve client of Cyrus, loaded where a verb needs it: the module comes with cyrus-imapd.
sub sieve_load {
    require Cyrus::SIEVE::managesieve;
    Cyrus::SIEVE::managesieve->import();
}

# `del --disable`: the active script of the person turned off. A redirect in it would keep
# forwarding the mail of an account disabled on purpose, a reset link of luminary included. hn-spam
# as this host writes it stays: it files, and `sync` would only put it back. Any other active
# script -- or hn-spam changed by its owner -- is deactivated, never deleted: SETACTIVE with an
# empty name leaves no script active [verifie:RFC 5804, 2.8; cyrus-imapd
# perl/sieve/scripts/sieveshell.pl, deactivate, sieve_activate($obj, "")]. `sync` then activates
# hn-spam, a person with no active script of her own.
# Returns (state, detail), state 'none', 'kept', 'deactivated' or 'failed'.
sub sieve_disable {
    my ($user, $adminpw) = @_;
    local $SV_USER   = $user;
    local $SV_AUTH   = $IMAP_ADMIN;
    local $SV_PW     = $adminpw;
    local $SV_ACTIVE = undef;
    local %SV_HAVE   = ();

    my $o = sieve_get_handle($IMAP_HOST, 'sv_prompt', 'sv_prompt', 'sv_prompt', 'sv_prompt');
    return ('failed', 'managesieve connection failed') unless defined $o;
    if (sieve_list($o, 'sv_list_cb') != 0) {
        my $e = sieve_get_error($o) // '?';
        sieve_logout($o);
        return ('failed', "list: $e");
    }
    unless (defined $SV_ACTIVE) {
        sieve_logout($o);
        return ('none', '');
    }
    my $was = $SV_ACTIVE;
    if ($was eq $SIEVE_NAME && -r $SIEVE_SRC) {
        my $want = do { local (@ARGV, $/) = ($SIEVE_SRC); <> };
        my $remote = '';
        sieve_get($o, $SIEVE_NAME, $remote);
        if (_norm($remote) eq _norm($want)) {
            sieve_logout($o);
            return ('kept', $was);
        }
    }
    if (sieve_activate($o, '') != 0) {
        my $e = sieve_get_error($o) // '?';
        sieve_logout($o);
        return ('failed', "deactivate $was: $e");
    }
    sieve_logout($o);
    return ('deactivated', $was);
}

# ------------------------------------------------------------------- the share ---------------
# Opening the shared collections to a person. The drive goes through cyradm ACLs (a davsharing
# POST answers 400 on it); the book and the calendar go through invite + accept, and the accept
# is only automatic while we hold the password -- at creation. Elsewhere the invite waits in the
# client of the person.
sub share_open {
    my ($c, $user, $pw) = @_;
    unless (store_is_cyrus()) {
        print "store  $STORE: no DAV collection to share\n";
        return;
    }
    my $pf = '<A:propfind xmlns:A="DAV:"><A:prop><A:resourcetype/></A:prop></A:propfind>';
    for my $coll (HnUser::collections($CONF)) {
        if ($coll->{kind} eq 'drive') {
            # home in RO (lr: list and enter), RW inside the collection itself.
            my $rh = $c->setacl($coll->{home_mailbox}, $user, 'lr');
            my $r  = $c->setacl($coll->{mailbox}, $user, 'lrswitedn');
            if (defined $rh && defined $r) { print "share  $coll->{name} (drive) home=lr coll=rw\n"; }
            else { warn "!! setacl $user [$coll->{name}]: " . ($c->error // '?') . "\n"; }
            next;
        }
        if (defined $pw) {
            HnUser::dav($CONF, method => 'PROPFIND',
                        url => HnUser::base($CONF) . "/dav/$coll->{dav}/user/$user/",
                        user => $user, pw => $pw, ctype => 'application/xml',
                        depth => 1, body => $pf);
        }
        my ($sc) = HnUser::share($CONF, $coll, $user, 'read-write');
        warn "!! invite not 204 ($sc) [$coll->{name}]\n" unless $sc eq '204';
        if (defined $pw) {
            my ($ac, $am) = HnUser::accept($CONF, $coll, $user, $pw);
            print "share  $coll->{name} ($coll->{kind}) invite=$sc $am\n";
            warn "!! accept not 2xx ($ac) [$coll->{name}]\n" unless $ac =~ /^2/;
        } else {
            print "share  $coll->{name} ($coll->{kind}) invite=$sc (accept in the client of $user)\n";
        }
    }
}

sub share_close {
    my ($c, $user) = @_;
    return unless store_is_cyrus();
    for my $coll (HnUser::collections($CONF)) {
        if ($coll->{kind} eq 'drive') {
            $c->deleteacl($coll->{home_mailbox}, $user);
            if ($c->deleteacl($coll->{mailbox}, $user)) { print "unshare $coll->{name} (drive)\n"; }
            else { warn "!! deleteacl $user [$coll->{name}]: " . ($c->error // '?') . "\n"; }
            next;
        }
        my ($uc) = HnUser::unshare($CONF, $coll, $user);
        if ($uc eq '204') { print "unshare $coll->{name} ($coll->{kind})\n"; }
        else { warn "!! unshare $user [$coll->{name}]: $uc (already gone?)\n"; }
    }
}

# ============================================================================ list ============
sub verb_list {
    my @acc = HnUser::accounts($CONF);
    # STATE: master.passwd under the system axes, the entries under `ldap` -- as root alone there,
    # '?' otherwise, as master.passwd unreadable gives.
    my @notes;
    my $state = $AUTH eq 'ldap' ? ($> == 0 ? ldap_states(\@notes) : undef) : locked_state();
    my $sh = HnUser::shared_members();
    # SMIME: the nearest expiry of the certificates the entry holds, `/<n>` behind it from two on,
    # '-' without one or under an axis that has nowhere to hold it. 13 = 'YYYY-MM-DD/nn'.
    printf "%-14s %-8s %-6s %-13s %-28s %s\n", 'LOGIN', 'STATE', 'SHARE', 'SMIME', 'NAME', 'ADDRESSES';
    for my $a (@acc) {
        my @addr = addresses_of($a->{user});
        my $smime = $AUTH eq 'ldap' ? ldap_cert_enddate($a->{user}) : undef;
        printf "%-14s %-8s %-6s %-13s %-28s %s\n",
            $a->{user},
            ($state ? ($state->{$a->{user}} // '?') : '?'),
            (defined $sh ? ($sh->{$a->{user}} ? 'yes' : 'no') : '-'),
            ($smime // '-'),
            substr($a->{gecos}, 0, 28),
            (@addr ? join(' ', @addr) : '-');
    }
    print "accounts : " . scalar(@acc) . " (auth=$AUTH store=$STORE)\n";
    warn "$_\n" for @notes;
    return 0;
}

# ============================================================================= add ============
# What a new login may not be, refused before anything is written. The login is a slug,
# [a-z0-9] alone: a '-' or a 'group:' prefix, which Cyrus reads too, cannot come out of it.
#   length    smtpd copies the AUTH login into char user[LOGIN_NAME_MAX], 32 with its NUL, and
#             hands that copy to auth_userokay [verifie:openbsd/src usr.sbin/smtpd/smtpd.c
#             1.364:1911-1925, parent_auth_user; sys/sys/syslimits.h:72]: past 31 bytes the login
#             tried is not the one typed. Under `ldap` login_ldap takes the address too,
#             (|(uid=%u)(mail=%u)) [infra.git host_vars/mail.yml, sys_login_ldap_filter], and
#             mail is <login>@<domain>: that form counts.
#   reserved  anyone, which a Cyrus ACL grants to every user [verifie:cyrus-imapd lib/auth_unix.c,
#             mymemberof]; anonymous, the identity of a session without one [same file,
#             auth_anonymous]; the shared pseudo-user of hn.conf (equipe), whose mailbox and
#             collections the person would take over.
#   address   <login>@<domain>, written as mail and mailLocalAddress, must reach nobody yet: an
#             alias, a list (a mailLocalAddress under ou=aliases) or a role address (the
#             mailLocalAddress of uid=admin [infra.git roles/mail_smtpd/tasks/smtpd.yml, Role
#             addresses]) already holding it would deliver to both. Under `ldap` the keys of the
#             rendered tables too, the roles while they still live there.
my $LOGIN_MAX = 31;
sub login_guard {
    my ($user) = @_;
    die "login $user: " . length($user) . " bytes, over the $LOGIN_MAX smtpd keeps of an AUTH"
      . " login -- choose a shorter one\n" if length $user > $LOGIN_MAX;
    my $d = $CONF->{domain};
    die "auth=ldap: no domain for the address of $user, set the key domain of /etc/hn.conf\n"
        if $AUTH eq 'ldap' && !(defined $d && length $d);
    die "login $user: $user\@$d is " . length("$user\@$d") . " bytes, over the $LOGIN_MAX smtpd"
      . " keeps of an AUTH login, and login_ldap accepts that form -- choose a shorter login\n"
        if $AUTH eq 'ldap' && defined $d && length $d && length("$user\@$d") > $LOGIN_MAX;
    my %reserved = map { $_ => 1 } grep { defined && length } ('anyone', 'anonymous', $CONF->{equipe});
    die "login $user is reserved -- refused (anyone and anonymous: identifiers of the Cyrus ACLs;"
      . " equipe of /etc/hn.conf: the shared user)\n" if $reserved{$user};
    my $h = alias_holder($user, $user);
    die "login $user: the address " . qualify_alias($user) . " already reaches $h -- refused\n"
        if defined $h;
    if ($AUTH eq 'ldap') {
        my $f = alias_table_key($user);
        die "login $user: a key of $f already -- refused\n" if defined $f;
    }
}

# The first rendered table holding $key as a key, folded to lowercase as aliases(5) does
# [verifie:man.openbsd.org/aliases.5], undef when none does.
sub alias_table_key {
    my ($key) = @_;
    for my $f (@ALIASES) {
        open(my $fh, '<', $f) or next;
        while (my $l = <$fh>) {
            next if $l =~ /^\s*(#|$)/;
            my ($k) = split /:/, $l, 2;
            $k =~ s/^\s+|\s+$//g;
            next unless lc $k eq lc $key;
            close $fh;
            return $f;
        }
        close $fh;
    }
    return undef;
}

sub verb_add {
    need_root();
    unsupported('account creation') unless auth_is_system() || $AUTH eq 'ldap';
    my $o = opts(login => 1, given => 1, family => 1, alias => 1);

    my $given  = $o->{given}  // ask('Given name(s) (compound ones separated by -)');
    die "empty given name\n" unless length $given;
    my $family = $o->{family} // ask('Family name');
    die "empty family name\n" unless length $family;

    my $user = slug($o->{login} // ask('Login', suggest_login($given, $family)));
    die "empty or invalid login\n" unless length $user;
    # The reserved names first: a system account may carry one (anonymous, on a build host).
    login_guard($user);
    # Both sources are asked, whatever the axis: under `ldap` the directory is the one that
    # counts, and a system account of the same name is a leftover the home would collide with.
    die "user '$user' already exists in the directory (" . ldap_dn($user) . ")\n"
        if $AUTH eq 'ldap' && ldap_entry($user, 'uid');
    die "user '$user' already exists\n" if getpwnam($user);

    # The aliases and the membership are settled BEFORE anything is created: an alias held by
    # someone else, or a member file absent, stops the verb while there is still nothing to undo.
    # Given by hand, an alias held elsewhere is refused: the operator named it. Derived from the
    # names, it is skipped with one warning: two people of the same names derive the same alias,
    # and the second one is still a person to create -- a human gives her another address.
    my %seen = ($user => 1);
    my @explicit = grep { length && !$seen{$_}++ } map { canonical_alias($_) } split_list($o->{alias});
    alias_guard($user, \@explicit);
    my @alias = @explicit;
    my $derived = derived_alias($given, $family);
    my $shape = length $derived ? alias_shape_error($derived) : undef;
    if (length $derived && !$seen{$derived}++) {
        my $holder = defined $shape ? undef : alias_holder($user, $derived);
        if (defined $shape) {
            warn "!! alias $derived of $user derived from the names: $shape -- not added\n";
        } elsif (defined $holder) {
            warn "!! alias $derived of $user already reaches $holder -- not added\n";
        } else {
            unshift @alias, $derived;
        }
    }

    # The store, settled before anything is written too: the admin refusing, or a mailbox that
    # outlived a person on this login, stops the verb while nothing has been created.
    my ($c) = store_is_cyrus() ? imap_admin() : (undef);
    store_box_guard($c, $user) if store_is_cyrus();

    my $pw = ask_secret("Password for $user");

    # The membership decides the share, and the file is written first: it is what the
    # reconciliation of `sync` reads, so an interruption between the two leaves a state `sync`
    # can finish rather than one it would undo. The share is made of Cyrus DAV collections;
    # under another store there is nothing to join, so neither the question nor the file.
    my $join = !store_is_cyrus()          ? 0
             : exists $o->{'no-share'}    ? 0
             : exists $o->{share}         ? 1
             : (ask('Join the shared calendar, book and drive? [y/N]', 'N') =~ /^\s*[yo]/i ? 1 : 0);
    die shared_absent(HnUser::shared_file())
        if $join && $AUTH ne 'ldap' && !defined HnUser::shared_members();

    # The gecos holds the family name FIRST: `<family> <given>` is the convention of the fleet
    # for a system account, and it is what lets a later reading derive the alias -- and check
    # the login -- from the account alone.
    my $gecos = "$family $given";

    if ($AUTH eq 'ldap') {
        # The entry alone: no home on disk, the store does not read one and accounts() wants
        # the attribute, not the directory.
        my $r = ldap_account_add($user, $given, $family, $pw);
        print "created  account $user ($gecos) uid=$r->{uid} gid=$r->{gid} in the directory\n";
        print "group  $user " . ($r->{joined} ? 'added to' : 'already in') . " $r->{group_dn}\n";
    } else {
        my $base = HnUser::home_base();
        my $shell = $CONF->{shell} // '/bin/ksh';
        my $rc = system('useradd', '-m', '-d', "$base/$user", '-s', $shell,
                        '-c', $gecos, '-p', encrypt_pw($pw), $user);
        die "useradd failed (rc=$rc)\n" if $rc;
        print "created  account $user ($gecos)\n";
    }

    store_create_box($c, $user);

    if ($join) {
        group_add($user);
        share_open($c, $user, $pw);
    } else {
        print "share  none for $user" . (store_is_cyrus() ? '' : " (store=$STORE)") . "\n";
    }

    if (store_is_cyrus()) {
        # The INBOX and what sits under it: `user/<u>/*` alone leaves the INBOX out, and the
        # defaultacl of imapd.conf does not reach a mailbox created through the admin, so the
        # first `sync` would report `+1 added` on every account this verb created.
        my ($ap, $dp) = (0, 0);
        for my $pat ("user/$user", "user/$user/*") {
            my ($a, $d) = HnUser::reconcile_post_acl($c, $pat);
            $ap += $a; $dp += $d;
        }
        print "ACL post : +$ap added, -$dp removed\n" if $ap || $dp;
    }

    alias_apply($user, \@alias, []);
    return 0;
}

# ============================================================================= mod ============
sub verb_mod {
    need_root();
    my $o = opts(alias => 1);
    my $user = shift @ARGV // ask('Login');
    die "empty login\n" unless length $user;
    my $a = HnUser::account($user, $CONF)
        or die "unknown account '$user' (or outside " . HnUser::home_base() . ")\n";
    print "target: $user ($a->{gecos})\n";

    # +a adds, -a removes, a bare name adds: the sign is what a reader expects here, and its
    # absence is the common case. The leading sign is syntax, not part of the alias: it goes
    # before the token is examined, or `--alias +jg` would be refused for a '+' it does not carry.
    # Read and checked first: an alias held by someone else stops the verb before any change.
    my (@add, @del);
    for my $t (split_list($o->{alias})) {
        if    ($t =~ /^-(.+)\z/) { push @del, canonical_alias($1, 1); }
        elsif ($t =~ /^\+?(.+)\z/) { push @add, canonical_alias($1); }
    }
    alias_guard($user, \@add);
    # The address a removal names is qualified now: under `ldap` without a domain it is a refusal,
    # which must come before the password changes, not after.
    qualify_alias($_) for @del;
    # The address of the identity stays: under `ldap` smtpd routes <login>@<domain> through
    # mailLocalAddress alone, the alias_filter of its people table, and takes from that same
    # attribute the senders a login may use [infra.git
    # roles/mail_smtpd/templates/virtual/etc_mail_ldap-people.conf.j2, alias_filter,
    # mailaddrmap_attributes]. Taken out, mail to the person bounces and, where smtpd checks the
    # senders, her own address stops being one, while `mail` still shows it.
    if ($AUTH eq 'ldap') {
        my $id = lc qualify_alias($user);
        for my $t (@del) {
            die "alias $t: the address of the identity of $user -- refused, it is what reaches"
              . " her\n" if lc qualify_alias($t) eq $id;
        }
    }

    # The share, settled before any write too: a member file absent (the legacy mode, see
    # shared_absent), a group_dn the directory lacks, a store that refuses the admin -- each one
    # stops the verb while nothing has changed, never after the password has.
    my $share = $o->{share} || $o->{'no-share'};
    my $c;
    if ($share && store_is_cyrus()) {
        die shared_absent(HnUser::shared_file())
            if $o->{share} && $AUTH ne 'ldap' && !defined HnUser::shared_members();
        ldap_group_read() if $AUTH eq 'ldap';
        ($c) = imap_admin();
    }

    my $touched = 0;

    if ($o->{password} || $o->{enable}) {
        secret_set($user, ask_secret("New password for $user"));
        print "secret  $user set\n";
        $touched++;
    }
    if ($o->{disable}) {
        secret_lock($user);
        print "locked  $user (the mailbox keeps receiving: LMTP does not authenticate)\n";
        $touched++;
    }

    if ($share) {
        if (store_is_cyrus()) {
            if ($o->{share}) { group_add($user); share_open($c, $user, undef); }
            else             { share_close($c, $user); group_del($user); }
        } else {
            print "share  store=$STORE: no collection to share, nothing changed\n";
        }
        $touched++;
    }

    if (@add || @del) { alias_apply($user, \@add, \@del); $touched++; }

    print "nothing to do (no option given)\n" unless $touched;
    return 0;
}

# ============================================================================= del ============
sub purge_refused { return "del --purge refused under auth=ldap: use --disable\n"; }

sub verb_del {
    need_root();
    my $o = opts();
    # Under `ldap` a purge would delete what the directory still describes: the mailbox and the
    # shares go, the entry stays, and the person keeps authenticating to nothing. Refused before
    # any prompt and any read; deleting the entry belongs to a cycle not written yet.
    die purge_refused() if $AUTH eq 'ldap' && $o->{purge} && !$o->{'purge-system'};
    my $user = shift @ARGV // ask('Login');
    die "empty login\n" unless length $user;
    # The guard rail is the account source itself: a login outside it -- _cyrusadm, equipe, a
    # daemon -- is not one accounts() returns, so it cannot be reached from here at all.
    #
    # ORPHAN: a login the source does not hold, but which the machine still carries with a home
    # under home_base. Under auth=ldap that is a person the migration never imported, and the one
    # verb meant to retire what it left behind could not reach it -- refusing to clean up after an
    # incomplete migration is the one thing this verb exists for. Only --purge-system applies:
    # disable locks a secret the source owns, purge deletes a mailbox and shares that are not
    # there. The extra confirmation below is because nothing else vouches for the login: on the
    # normal path the directory does.
    my $a = HnUser::account($user, $CONF);
    my $orphan = 0;
    unless ($a) {
        $a = HnUser::system_account($user, $CONF);
        $orphan = 1 if $a;
    }
    $a or die "unknown account '$user' (or outside " . HnUser::home_base() . ") -- refusing\n";
    print "target: $user ($a->{gecos}) home=$a->{home}\n";
    print "  system account only: no entry in the account source, so no mailbox and no share\n"
        if $orphan;

    my $mode = $o->{'purge-system'} ? 'purge-system' : $o->{purge} ? 'purge' : $o->{disable} ? 'disable' : '';
    unless ($mode) {
        my $ans = ask($orphan
            ? 'Action: [3] purge-system (system account + home only) is the only one that applies'
            : 'Action: [1] disable (reversible)  [2] purge (final'
                       . ($AUTH eq 'ldap' ? ', refused under auth=ldap' : '') . ')  '
                       . '[3] purge-system (system account + home only, LDAP/store untouched)');
        $mode = $ans eq '1' ? 'disable' : $ans eq '2' ? 'purge' : $ans eq '3' ? 'purge-system' : '';
        die "invalid action (1, 2 or 3 expected)\n" unless $mode;
        die purge_refused() if $AUTH eq 'ldap' && $mode eq 'purge';
    }
    if ($orphan) {
        die "'$user' is not in the account source: only --purge-system applies\n"
            unless $mode eq 'purge-system';
        my $ok = ask("'$user' exists in master.passwd alone. Archive its home and drop the "
                     . "system account? [Y/n]", 'Y');
        die "aborted\n" unless $ok =~ /^[Yy]/;
    }

    if ($mode eq 'disable') {
        secret_lock($user);
        print "locked  $user (IMAP, SMTP and DAV auth refused)\n";
        print "  the mailbox keeps receiving: LMTP delivery does not authenticate\n";
        # Under `ldap` every userPassword value went, the device secrets with the password: the
        # way back is a new password, and `secret add` again for each device.
        print $AUTH eq 'ldap'
            ? "  the entry stays; back: hn-user mod $user --password (then secret add per device)\n"
            : "  back: hn-user mod $user --enable\n";
        my $rc = 0;
        # Out of the administrators of luminary too: a password given back later must not give the
        # account manager back with it. After the lock, which is what disables: a refusal here is
        # said and turns the rc, the lock stays.
        if ($AUTH eq 'ldap') {
            eval { ldap_admin($user, 0); 1 }
                or do { warn "!! admin of $user: $@"; $rc = 1; };
        }
        if (store_is_cyrus()) {
            sieve_load();
            my ($st, $what) = sieve_disable($user, imap_admin_pw());
            if    ($st eq 'deactivated') { print "sieve  $what of $user deactivated, kept on the server\n"; }
            elsif ($st eq 'kept')        { print "sieve  $what of $user left active: the one this host writes\n"; }
            elsif ($st eq 'none')        { print "sieve  no active script on $user\n"; }
            else {
                warn "!! sieve of $user: $what -- an active script may still forward its mail;"
                   . " deactivate it by hand (sieveshell, deactivate)\n";
                $rc = 1;
            }
        }
        alias_report($user);
        return $rc;
    }

    print "\n*** FINAL DELETION of '$user'"
          . ($mode eq 'purge-system' ? " (system account + home only, LDAP/store untouched)" : "")
          . " ***\n";
    # du by list, never through a shell: the home is a value read from the account source.
    my $sz = '';
    if (open(my $du, '-|', 'du', '-sh', '--', $a->{home})) {
        $sz = <$du> // '';
        close $du;
    }
    $sz =~ s/\s.*//s;
    print "  home : $a->{home} ($sz)\n" if length $sz;
    my $confirm = ask("Confirm by retyping the login ($user)");
    die "confirmation KO (\"$confirm\" != \"$user\") -> aborting\n" unless $confirm eq $user;

    # Archive BEFORE anything is removed: it is the only way back, and a tar that fails must
    # stop the verb while everything is still there.
    # The archive holds the mail and the files of a person: the directory 0700, the archive 0600,
    # never readable by another account. umask 077 for the whole block, so tar creates it 0600
    # from the start, then chmod for an archive dir that already existed with another mode.
    my ($tar, $rc);
    my $umask = umask 077;
    eval {
        make_path($ARCHIVE, { mode => 0700, error => \my $mkerr });
        die "mkdir $ARCHIVE failed\n" if @$mkerr || !-d $ARCHIVE;
        chmod 0700, $ARCHIVE or die "chmod 0700 $ARCHIVE: $!\n";
        my @lt = localtime;
        $tar = sprintf '%s/%s-%04d%02d%02d.tar.gz', $ARCHIVE, $user, $lt[5] + 1900, $lt[4] + 1, $lt[3];
        die "archive $tar already exists -> aborting (never overwrite one)\n" if -e $tar;
        print "archiving -> $tar ...\n";
        # From the parent of the home as it IS, not from home_base joined to the login:
        # accounts() only promises the home sits somewhere under home_base.
        # The name as './<name>': OpenBSD tar reads an operand `-C` or `-I` as a positional flag
        # even after `--`, which getopt consumes before the operand loop [verifie:openbsd/src
        # bin/pax/options.c 1.115:746-747, getoldopt; 965-966, argv past optind; 1085-1089 and
        # 1121-1126, strcmp(*argv, "-I"), strcmp(*argv, "-C"); bin/pax/getoldopt.c 1.9:36-42,
        # getopt on a leading '-'; man.openbsd.org/tar.1, -C and -I "a positional argument"].
        # _ldap_accounts already refuses such a home; the masterpasswd branch checks none.
        my ($hdir, $hname) = ($a->{home} =~ m{^(.*)/([^/]+)/?\z});
        $rc = system('tar', '-czf', $tar, '-C', $hdir, "./$hname");
        chmod 0600, $tar if -e $tar;
        1;
    } or do { my $err = $@; umask $umask; die $err; };
    umask $umask;
    die "tar failed (rc=$rc) -> aborting BEFORE any deletion\n" if $rc;
    my $bytes = -s $tar // 0;
    die "archive empty or missing ($bytes bytes) -> aborting\n" if $bytes < 1024;
    printf "archive ok (%d bytes)\n", $bytes;

    # purge-system: the post-LDAP-migration case, an account whose identity, mailbox and shares
    # already live in the directory and the store -- only the now-unused system account and its
    # home are being retired. Skip every LDAP and Cyrus call: group_del() dies without a
    # configured group_dn, and even fixed it would touch the directory entry this verb must not.
    if ($mode ne 'purge-system') {
        my ($c) = store_is_cyrus() ? imap_admin() : (undef);
        share_close($c, $user);
        group_del($user);
        store_purge_boxes($c, $user) if store_is_cyrus();
    }

    $rc = system('userdel', '-r', $user);
    die "userdel failed (rc=$rc) -> mailboxes already gone; home to clean by hand\n" if $rc;
    print "userdel -r $user : ok\n";
    print "\nOK: $user deleted. Archive: $tar\n\n";
    alias_report($user);
    return 0;
}

# What still points at a login. Under `ldap` the attributes go with the entry, so a deleted account
# takes its addresses with it; under the other axes the table is a file of its own and the keys
# outlive the account -- they must be removed by name, or they bounce at the first delivery.
sub alias_report {
    my ($user) = @_;
    my @a = addresses_of($user);
    unless (@a) { print "alias : nothing points at '$user'\n"; return; }
    print "alias : these still reach '$user'\n";
    print "    $_\n" for @a;
    print '  they stay in ' . ($CONF->{aliases_file} // '/etc/mail/aliases_user')
        . " until a mod --alias takes them out\n"
        unless $AUTH eq 'ldap';
}

# ============================================================================ sync ============
# Reconciles the store with the accounts. Idempotent, and the only verb ansible runs: its action
# lines start with a verb, the summaries with a noun and a colon, which is what lets the task
# tell a change from a report.
sub verb_sync {
    need_root();
    my $o = opts();
    my @acc = HnUser::accounts($CONF);
    my @users = map { $_->{user} } @acc;

    # Derived aliases, BEFORE the store branch: the convention belongs to the person, not to the
    # mailbox, and dovecot carries the same people.
    #
    # The write reaches the provider without this script knowing it. `sync` runs on a host that
    # carries a CONSUMER, whose olcUpdateRef refers every write away; the chain overlay of that
    # consumer chases the referral under the cn=chain identity and the write lands where it
    # belongs [roles/dbe_ldap/templates/config.ldif.j2]. What the script binds with stays the
    # local ldapi socket. Without that overlay ldapmodify answers `Referral (10)` and the pass
    # stops the play -- measured on mail 2026-09-15, uid=obouvyer.
    #
    # ADDITION ONLY. jg, mehdi and the other short forms are exceptions the convention does not
    # know [TODO.md], and they answer today -- a removal here would take them out on the first
    # run, silently, for every account at once.
    #
    # The accounts whose source gives no given/family are skipped rather than guessed: under
    # `masterpasswd` the gecos holds the two as one string with no symbol to cut on, and a wrong
    # cut writes an address nobody chose. That axis therefore reconciles nothing here, which is
    # the decision of the plan -- its accounts are the ones chantier 10 removes.
    #
    # One read per account, one write per account that lacks its alias: addresses_of() already
    # costs a search under `ldap`, and sparing it would mean a second reader of the subtree beside
    # the one the whole script goes through.
    my $aliased = 0;
    for my $a (@acc) {
        my ($given, $family) = ($a->{given}, $a->{family});
        next unless defined $given && length $given && defined $family && length $family;
        my $want = derived_alias($given, $family);
        next unless length $want && $want ne $a->{user};
        my $why = alias_shape_error($want);
        if (defined $why) {
            warn "!! alias $want of $a->{user} derived from the names: $why -- not added\n";
            next;
        }
        my %have = map { lc $_ => 1 } addresses_of($a->{user});
        next if $have{lc qualify_alias($want)};
        # Two people of the same names derive the same alias: the first one keeps it, the other
        # is named on stderr each pass until a human gives one of them another address.
        my $holder = alias_holder($a->{user}, $want);
        if (defined $holder) {
            warn "!! alias $want of $a->{user} already reaches $holder -- not added\n";
            next;
        }
        alias_apply($a->{user}, [$want], []);
        $aliased++;
    }
    print "alias : $aliased added\n";

    unless (store_is_cyrus()) {
        print "store  $STORE: mailboxes autocreated, no ACL and no DAV to reconcile\n";
        print "accounts : " . scalar(@users) . "\n";
        return 0;
    }

    my ($c, $adminpw) = imap_admin();
    my $failed = 0;

    # Cyrus runs unixhierarchysep: yes -> "/" separator. The INBOX is "user/<u>"; a "." there
    # would be a literal dot, giving an ordinary folder instead of an INBOX, and the DAV
    # autoprovision would answer 503.
    my %have;
    for my $m ($c->listmailbox('user/*')) {
        my $name = ref($m) ? $m->[0] : $m;
        $have{$name} = 1 if defined $name && length $name;
    }
    my ($created, $skipped) = (0, 0);
    for my $u (@users) {
        if ($have{"user/$u"}) { $skipped++; next; }
        if ($c->create("user/$u")) { print "created  user/$u\n"; $created++; }
        else { warn "FAILED   user/$u: " . ($c->error // '?') . "\n"; $failed++; }
    }
    print "INBOX : $created created, $skipped already present\n";

    # After the mailboxes: managesieve refuses an account without one. A missing file is a
    # partial deployment, not an error -- the next pass catches up.
    if (-r $SIEVE_SRC) {
        sieve_load();
        my ($inst, $ok, $ko) = (0, 0, 0);
        my $want = do { local (@ARGV, $/) = ($SIEVE_SRC); <> };
        for my $u (@users) {
            my ($st, $msg) = sieve_sync($u, $want, $adminpw);
            if    ($st eq 'installed') { print "sieve  $SIEVE_NAME -> $u\n"; $inst++; }
            elsif ($st eq 'ok') { $ok++; }
            else { warn "FAILED   sieve $u: $msg\n"; $ko++; $failed++; }
        }
        print "sieve : $inst installed, $ok up to date, $ko failed\n";
    } else {
        print "sieve : $SIEVE_SRC missing -> skipped\n";
    }

    my $equipe = $CONF->{equipe};
    my ($ap, $dp) = HnUser::reconcile_post_acl($c, 'user/*', $equipe, $CONF->{mailbox});
    print "ACL post : +$ap added, -$dp removed\n";

    my $ac = HnUser::reconcile_cua_acl($c, $CONF->{domain}, $equipe, $CONF->{mailbox});
    print "ACL cua  : $ac updated\n";

    if ($CONF->{mailbox}) {
        my ($smc, $sma) = HnUser::ensure_shared_mailbox($c, $CONF);
        print "shared mailbox '$CONF->{mailbox}' : created=$smc, ACL updated=$sma\n";
    }

    # Book and calendar invites. The member file present means strict -- only its logins are
    # invited and everyone else is revoked; absent means every account, with no revocation.
    # Creating that file is what switches one to the other. The drive is reconciled by
    # hn-cyrus-equipe-init, share() answering 400 on it.
    my $sh = HnUser::shared_members();
    my $strict = defined $sh;
    my %member = $strict ? %$sh : map { $_ => 1 } @users;
    my ($invited, $revoked) = (0, 0);
    for my $coll (grep { $_->{kind} ne 'drive' } HnUser::collections($CONF)) {
        my ($pc, $status) = HnUser::invite_status($CONF, $coll);
        if ($pc !~ /^2/) {
            warn "!! invite status unreadable ($pc) [$coll->{name}] -> skipped\n";
            next;
        }
        for my $u (@users) {
            next unless $member{$u};
            my $st = $status->{$u};
            my $do = !defined $st                          ? 'invite'
                   : ($st eq 'noresponse' && $o->{reinvite}) ? 'resend'
                   :                                           '';
            next unless $do;
            my ($sc) = HnUser::share($CONF, $coll, $u, 'read-write');
            if ($sc eq '204') { print "$do $coll->{name} -> $u\n"; $invited++; }
            else { warn "FAILED   invite $u [$coll->{name}]: $sc\n"; $failed++; }
        }
        next unless $strict;
        for my $u (sort keys %$status) {
            next if $member{$u};
            my ($uc) = HnUser::unshare($CONF, $coll, $u);
            if ($uc eq '204') { print "revoked $coll->{name} -> $u\n"; $revoked++; }
            else { warn "!! unshare $u [$coll->{name}]: $uc\n"; }
        }
    }
    print "invites : $invited sent, $revoked revoked"
        . ($o->{reinvite} ? ' (with resend)' : '') . "\n";

    # A mailbox name carrying an '@' is a ghost account. Cyrus keeps ANY domain written into a
    # userid, trimming only the one matching defaultdomain [verifie:cyrus-imapd imap/global.c,
    # canonify_userid], so a client set up with the wrong domain opens a namespace of its own
    # and nothing says a word. A legitimate name never holds one, which makes the test exact.
    my @ghosts = grep { /\@/ } map { ref($_) ? $_->[0] : $_ } $c->listmailbox('user/*');
    if (@ghosts) {
        warn "FAILED   mailbox outside the default domain: $_\n" for @ghosts;
        $failed += scalar @ghosts;
    }
    print 'domains : ' . scalar(@ghosts) . " outside the default domain\n";

    return $failed ? 1 : 0;
}

# ========================================================================== secret ============
# One password per device, under `ldap` alone: the other axes hold ONE hash per account
# (master.passwd, the credentials file) and have nowhere to put a second. Root for the three
# actions: `list` reads the userPassword values through the local socket, which slapd grants to
# the peercred of root alone [roles/dbe_ldap/templates/config.ldif.j2, olcAccess on
# userPassword]. The login must be a person of accounts(): a daemon or the probe account never
# carries a device.
sub verb_secret {
    unsupported('device secrets') unless $AUTH eq 'ldap';
    need_root();
    my $o = opts();
    my $action = shift @ARGV // '';
    die "usage: hn-user secret add|del|list <login> [<device>]\n"
        unless $action eq 'add' || $action eq 'del' || $action eq 'list';
    my $user = shift @ARGV // ask('Login');
    die "empty login\n" unless length $user;
    my $a = HnUser::account($user, $CONF)
        or die "unknown account '$user' (or outside " . HnUser::home_base() . ")\n";

    if ($action eq 'list') {
        my @d = device_list($user);
        print "$_->[0]  $_->[1]" . ($_->[2] ? '' : '  (value gone, registration alone)') . "\n" for @d;
        print "devices : " . scalar(@d) . " on $user ($a->{gecos})\n";
        warn "$_\n" for unclaimed_note($user, ldap_secrets($user));
        return 0;
    }

    my $device = shift @ARGV // ask('Device');
    die "device '$device' is not a name: [a-z0-9][a-z0-9-]* expected\n"
        unless $device =~ /^[a-z0-9][a-z0-9-]*\z/;
    if ($action eq 'add') {
        my $secret = device_add($user, $device);
        print "secret for $user on $device: $secret\n";
        print "  shown this once: it is stored hashed and cannot be read back; secret del and"
            . " add again to replace it\n";
    } else {
        device_del($user, $device);
        print "secret  removed $device from $user\n";
    }
    return 0;
}

# ============================================================================ admin ===========
# The administrators of luminary, under `ldap` alone: the other axes have no directory group.
# Root for both actions, the write going through the local socket as the peercred of root. The
# login must be a person of accounts(): memberUid names a login, and one nobody holds would grant
# the account manager to whoever is created under it next.
sub verb_admin {
    unsupported('luminary administrators') unless $AUTH eq 'ldap';
    need_root();
    my $o = opts();
    my $action = shift @ARGV // '';
    die "usage: hn-user admin add|del <login>\n" unless $action eq 'add' || $action eq 'del';
    my $user = shift @ARGV // ask('Login');
    die "empty login\n" unless length $user;
    HnUser::account($user, $CONF)
        or die "unknown account '$user' (or outside " . HnUser::home_base() . ")\n";
    ldap_admin($user, $action eq 'add' ? 1 : 0);
    return 0;
}

# ============================================================================ cert ============
# The S/MIME certificates of a person, under `ldap` alone: the other axes have no entry to hold
# them. Root for add and del (the write goes through the local socket as the peercred of root);
# show reads public values and runs as anyone. The login must be a person of accounts().
sub verb_cert {
    unsupported('S/MIME certificates') unless $AUTH eq 'ldap';
    my $o = opts(ca => 1);
    my $action = shift @ARGV // '';
    die "usage: hn-user cert add|del|show <login> [<file.pem> [--ca <ca.pem>]|<sha256>]\n"
        unless $action eq 'add' || $action eq 'del' || $action eq 'show';
    need_root() unless $action eq 'show';
    my $user = shift @ARGV // ask('Login');
    die "empty login\n" unless length $user;
    my $a = HnUser::account($user, $CONF)
        or die "unknown account '$user' (or outside " . HnUser::home_base() . ")\n";

    if ($action eq 'show') {
        my @blocks = ldap_cert_show($user);
        unless (@blocks) { print "cert  none on $user\n"; return 0; }
        print "cert  $user ($a->{gecos})\n";
        print join("\n", map { join('', map { "  $_\n" } grep { length } split /\n/, $_) } @blocks);
        return 0;
    }
    if ($action eq 'del') {
        my @gone = ldap_cert_del($user, shift @ARGV);
        print @gone ? join('', map { "cert  removed from $user: $_\n" } @gone)
                    : "cert  none on $user, nothing to delete\n";
        return 0;
    }
    my $file = shift @ARGV // ask('Certificate file (PEM, chain after the leaf)');
    die "empty file name\n" unless length $file;
    my $r = ldap_cert_add($user, $file, $o->{ca});
    print cert_added_line($user, $r);
    return 0;
}

# The line of `cert add`. The CN is named only when it says something the address does not: a
# CN that is the address itself (Actalis issues them so) would name it twice.
sub cert_added_line {
    my ($user, $r) = @_;
    my $who = (!length $r->{cn} || lc $r->{cn} eq lc $r->{email})
            ? $r->{email} : "$r->{cn}, $r->{email}";
    return "cert  added on $user: $who, expires $r->{expires}, "
         . "$r->{chain} certificate(s) in the chain, sha256 $r->{fp}\n";
}

# ============================================================================ main ============
my %VERB = (list => \&verb_list, add => \&verb_add, mod => \&verb_mod,
            del => \&verb_del, sync => \&verb_sync, secret => \&verb_secret, cert => \&verb_cert,
            admin => \&verb_admin);
die "unknown verb '$verb' (list add mod del sync secret cert admin)\n" unless $VERB{$verb};
exit $VERB{$verb}->();
