#!/usr/bin/perl -w

=head1 NAME

dh_installs6 - install s6-rc unit files

=cut

use strict;
use warnings;
use Debian::Debhelper::Dh_Lib;
use File::Find;
use Cwd qw(getcwd abs_path);

our $VERSION = DH_BUILTIN_VERSION;

=head1 SYNOPSIS

B<dh_installs6> [S<I<debhelper options>>]

=head1 DESCRIPTION

B<dh_installs6> is a debhelper program that is responsible for
installing package maintainer supplied s6-rc unit folders.

Generates F<postinst>, F<prerm> and F<postrm> code blocks that make the
units known to s6-rc and start, restart or stop them when the package is
installed, upgraded or removed. These snippets are added to the maintainer
scripts by L<dh_installdeb(1)>.

To enable this addon in your source package use B<Build-Depends: dh-sequence-s6>
or set `--with s6` in your debian/rules file.

=head1 UNITS

Every unit folder is installed into F<usr/lib/s6-rc/sources/> and completed
as follows. A file the folder already contains is kept as it is.

=over 4

=item Activation

Every oneshot and longrun gets the file F<flag-recommended>: B<s6-rc-repo-sync>
adds a new unit with it to the prescription C<active>, the equivalent of
C<WantedBy=multi-user.target>. B<.noenable> omits it.

=item Default edge

Every oneshot and longrun gets F<dependencies.d/basic.target>, the
equivalent of C<DefaultDependencies=yes>. B<.no-default-dependencies> omits it.

=item Ordering package

A package whose units name a target (F<*.target>) or a compatibility alias
of the ordering package in an edge, a bundle or a hint, the default edge
included, gets B<s6-order> in B<${misc:Depends}>: without the ordering
package such an edge names nothing, and the s6-rc repository is unusable.
The aliases are ifupdown-wait-online, systemd-modules-load,
systemd-remount-fs, systemd-sysctl, systemd-tmpfiles-setup, systemd-udevd,
systemd-udev-settle and systemd-udev-trigger.

=item Time limits

Every oneshot and longrun gets F<timeout-up> and F<timeout-down> of 90000
milliseconds. A longrun gets F<timeout-kill> 1000 milliseconds below
F<timeout-down>, so a process that ignores its down signal is killed before
s6-rc gives up on the stop. Below 2000 milliseconds, the derived limits are
half of the s6-rc limit. A value of 0 means no limit and derives none.

=item Success wrapper

The F<up> of a oneshot runs in F</usr/libexec/svctl/hull> (from
B<s6-policy-common>), which records a failure under F</run/svctl/failed/>.
A oneshot with entries in F<wanted-by.d> and none in F<required-by.d> is
soft: the wrapper reports success, so the target it is wanted by comes up
anyway. Every other oneshot is hard (B<-h>): the failure is recorded and
passed on to s6-rc. The wrapper ends the program with its own limit (B<-T>)
1000 milliseconds below F<timeout-up>, so the failure is recorded before
s6-rc gives up.

The F<down> of a oneshot runs in the soft wrapper with a limit 1000
milliseconds below F<timeout-down>; a failed or hanging F<down> is recorded,
and the stop of the units below it goes on.

An empty F<up> or F<down>, or one that already starts with the wrapper, is
left as it is. Using the wrapper adds B<s6-policy-common> to
B<${misc:Depends}>.

=item Readiness

A longrun with B<.notify> (C<Type=notify>) runs under
B<s6-notify-fd-from-socket -t> I<timeout-up>: its F<run> moves to
F<data/notify-run>, and the new F<run> starts it under the converter.
F<notification-fd> is set to 3 unless the folder has one. This adds
B<s6 (E<gt>= 2.15.0.0)> to B<${misc:Depends}>. Other readiness protocols
are written by the package: F<notification-fd> for a daemon that writes
to a descriptor, B<s6-notifyoncheck> in F<run> for polling.

=item Hint directories

F<wanted-by.d/>I<target>, F<required-by.d/>I<target>, F<before.d/>I<unit>
and F<after.d/>I<unit> hold empty files and are installed as they are.
B<s6-rc-compile> ignores them; B<svctl daemon-reload> turns them into edges
(C<WantedBy=>, C<RequiredBy=>, C<Before=>, C<After=>). A unit that hooks
into F<basic.target> or a target below it needs
B<.no-default-dependencies>, otherwise the edges form a cycle; so does a
unit in F<early-boot.target>, the first step of the boot, which would
otherwise wait for F<basic.target>.

=item Pipelines

A producer and its logger share B<.noenable> and
B<.no-default-dependencies>: a hint in one unit of a pipeline applies to all
of its units.

=back

=head1 FILES

=over 4

=item F<debian/I<package>.s6-rc/*/>

If any of those folders exists, they are installed into
F<usr/lib/s6-rc/sources/> in the package build directory.

=item F<debian/I<package>.s6-rc/*/.noenable>

Do not add the unit to the prescription C<active> (no F<flag-recommended>).

B<Note> that this option also affects whether the services are
started/restarted. If a service is enabled or was running it will be
started/restarted. Use file B<.norestart> to mitigate that.

=item F<debian/I<package>.s6-rc/*/.norestart>

Do not restart the service after upgrades or start after initial installation.

B<Note> that this option does not affect whether the services are
enabled. Please remember to also use file B<.noenable> if the services
should not be enabled.

=item F<debian/I<package>.s6-rc/*/.no-default-dependencies>

Do not add F<dependencies.d/basic.target>.

=item F<debian/I<package>.s6-rc/*/.notify>

The daemon in F<run> reports readiness over C<NOTIFY_SOCKET> (C<Type=notify>).

=back

The hint files are removed from the package.

=head1 MAINTAINER SCRIPTS

Inside a dpkg run B<svctl> asks F</usr/sbin/policy-rc.d> before it starts,
stops, restarts or reloads a unit, and before a structural change goes live.

=over 4

=item F<postinst>

C<svctl daemon-reload || true>. Then, for the units without B<.norestart>
and with their states taken before any action: on upgrade one
C<svctl restart> of the running units, one C<svctl start> of the enabled
units that do not run; on the first installation only the start. A unit that
depends within the package on a oneshot of this list is not named in the
restart: restarting the oneshot restarts its running dependents. Errors of
B<svctl> are ignored, the package stays configured.

=item F<prerm>

On remove: C<svctl stop> for each unit, errors ignored. Targets and their
members refuse a manual stop; B<svctl daemon-reload> in F<postrm> stops them.

=item F<postrm>

On remove and purge: C<svctl daemon-reload || true>. Not on upgrade: the
replaced files still lie beside the new ones as F<*.dpkg-tmp>; the
F<postinst> of the new package reloads.

=back

Log units (F<consumer-for>) follow their producer and are not named in the
maintainer scripts; bundles are not started or restarted, their members are
units of their own.

=head1 NOTES

This command is not idempotent. L<dh_prep(1)> should be called between
invocations of this command (with the same arguments). Otherwise, it
may cause multiple instances of the same text to be added to maintainer
scripts.

=cut

init(options => {});

my $HULL = '/usr/libexec/svctl/hull';
my $HULL_DEPENDS = ['s6-policy-common', '>= 2.0.0'];
my $NOTIFY = '/usr/bin/s6-notify-fd-from-socket';
my $NOTIFY_DEPENDS = ['s6', '>= 2.15.0.0'];
my $DEFAULT_TIMEOUT = 90000;
my $DEFAULT_EDGE = 'basic.target';
# a member of these targets must not have the default edge: basic.target
# depends on all but early-boot.target, which rc.init starts first, without
# a limit
my @EARLY_TARGETS = qw(basic.target sysinit.target local-fs.target
	local-fs-pre.target swap.target cryptsetup.target cryptsetup-pre.target
	early-boot.target);
# compatibility aliases of the ordering package
my @ORDER_ALIASES = qw(ifupdown-wait-online systemd-modules-load systemd-remount-fs
	systemd-sysctl systemd-tmpfiles-setup systemd-udevd systemd-udev-settle
	systemd-udev-trigger);
my $ORDER_DEPENDS = 's6-order';
my @HINT_DIRS = qw(wanted-by.d required-by.d before.d after.d);
my @HINT_FILES = qw(.noenable .norestart .no-default-dependencies .notify);

sub quote {
	# Add single quotes around the argument.
	return '\'' . $_[0] . '\'';
}

sub uniq {
	my %seen;
	return grep { !$seen{$_}++ } @_;
}

sub read_file {
	my ($path) = @_;
	open(my $fd, '<', $path) or error("open($path): $!");
	local $/;
	my $content = <$fd>;
	close($fd);
	return $content // '';
}

sub write_file {
	my ($path, $content, $mode) = @_;
	verbose_print("[META] write $path");
	return if $dh{NO_ACT};
	open(my $fd, '>', $path) or error("open($path): $!");
	print {$fd} $content;
	close($fd) or error("close($path): $!");
	chmod($mode // 0644, $path) or error("chmod($path): $!");
}

sub first_line {
	my ($path) = @_;
	my $content = read_file($path);
	$content =~ s/\n.*//s;
	return $content;
}

sub entries {
	my ($dir) = @_;
	return () unless -d $dir;
	opendir(my $dh, $dir) or error("opendir($dir): $!");
	my @names = sort grep { !/^\.\.?$/ } readdir($dh);
	closedir($dh);
	return @names;
}

sub read_timeout {
	my ($unitdir, $name) = @_;
	my $path = "$unitdir/$name";
	if (! -e $path) {
		write_file($path, "$DEFAULT_TIMEOUT\n");
		return $DEFAULT_TIMEOUT;
	}
	my $value = read_file($path);
	error("$path: not a number of milliseconds") unless $value =~ /^\s*(\d+)\s*$/;
	return $1;
}

sub inner_limit {
	# the limit of the wrapper or of timeout-kill, below the s6-rc limit
	my ($timeout) = @_;
	my $margin = $timeout >= 2000 ? 1000 : int($timeout / 2);
	return $timeout - $margin;
}

sub is_empty_script {
	# no command: only blank lines and execline comments
	my ($content) = @_;
	return $content !~ /^[ \t]*[^#\s]/m;
}

sub wrap_script {
	# prefix an execline command line with the success wrapper
	my ($path, $unit, $hard, $limit) = @_;
	return 0 unless -e $path;
	my $content = read_file($path);
	return 0 if is_empty_script($content);
	return 1 if $content =~ /^\s*\Q$HULL\E\s/;
	error("unit name '$unit' cannot be passed to the wrapper in $path")
		unless $unit =~ /^[A-Za-z0-9_.:@+-]+$/;
	my @cmd = ($HULL);
	push @cmd, '-h' if $hard;
	push @cmd, '-T', $limit if $limit > 0;
	push @cmd, $unit;
	write_file($path, join(' ', @cmd) . "\n" . $content);
	return 1;
}

sub add_default_edge {
	my ($unitdir) = @_;
	if (! -d "$unitdir/dependencies.d" && -f "$unitdir/dependencies") {
		# deprecated list format: s6-rc-compile reads it only without dependencies.d
		my $content = read_file("$unitdir/dependencies");
		return if $content =~ /^\s*\Q$DEFAULT_EDGE\E$/m;
		$content .= "\n" if length($content) && $content !~ /\n$/;
		write_file("$unitdir/dependencies", "$content$DEFAULT_EDGE\n");
		return;
	}
	install_dir("$unitdir/dependencies.d");
	write_file("$unitdir/dependencies.d/$DEFAULT_EDGE", '') unless -e "$unitdir/dependencies.d/$DEFAULT_EDGE";
}

sub wrap_notify {
	my ($unitdir, $timeout_up) = @_;
	error("$unitdir: .notify needs a run file") unless -f "$unitdir/run";
	error("$unitdir: data/notify-run exists already") if -e "$unitdir/data/notify-run";
	install_dir("$unitdir/data");
	doit('mv', "$unitdir/run", "$unitdir/data/notify-run");
	write_file("$unitdir/run", "#!/usr/bin/execlineb -P\n$NOTIFY -t $timeout_up ./data/notify-run\n", 0755);
	write_file("$unitdir/notification-fd", "3\n") unless -e "$unitdir/notification-fd";
}

# A target or alias name: the ordering package provides it
sub is_order_name {
	my ($name) = @_;
	return $name =~ /\.target$/ || grep { $_ eq $name } @ORDER_ALIASES;
}

# Names a unit refers to: edges, bundle contents and hints
sub referenced_names {
	my ($unitdir) = @_;
	my @names = dependencies($unitdir);
	push @names, entries("$unitdir/contents.d");
	push @names, entries("$unitdir/$_") for @HINT_DIRS;
	return @names;
}

# Direct dependencies of a unit (dependencies.d, or the deprecated list file)
sub dependencies {
	my ($unitdir) = @_;
	return entries("$unitdir/dependencies.d") if -d "$unitdir/dependencies.d";
	return () unless -f "$unitdir/dependencies";
	return grep { length && !/^#/ } map { s/^\s+//r } split(/\n/, read_file("$unitdir/dependencies"));
}

# The units of the list that do not depend, within the package, on a oneshot
# of the list: restarting such a oneshot restarts its running dependents
sub restart_roots {
	my ($sourcesdir, $type, @list) = @_;
	my %inlist = map { $_ => 1 } @list;
	my @roots;
	for my $unit (@list) {
		my (%seen, @todo);
		@todo = dependencies("$sourcesdir/$unit");
		my $covered = 0;
		while (defined(my $dep = shift @todo)) {
			next if $seen{$dep}++ || ! -d "$sourcesdir/$dep";
			if ($inlist{$dep} && ($type->{$dep} // '') eq 'oneshot') {
				$covered = 1;
				last;
			}
			push @todo, dependencies("$sourcesdir/$dep");
		}
		push @roots, $unit unless $covered;
	}
	return @roots;
}

# Pipelines (producer-for/consumer-for) as groups of unit names
sub pipeline_groups {
	my ($sourcesdir, @units) = @_;
	my %group = map { $_ => $_ } @units;
	my $find;
	$find = sub { my $u = shift; return $group{$u} eq $u ? $u : ($group{$u} = $find->($group{$u})); };
	for my $unit (@units) {
		next unless -f "$sourcesdir/$unit/producer-for";
		my $consumer = first_line("$sourcesdir/$unit/producer-for");
		$consumer =~ s/^\s+|\s+$//g;
		next unless exists $group{$consumer};
		$group{$find->($unit)} = $find->($consumer);
	}
	return map { $_ => $find->($_) } @units;
}

# Install package maintainer supplied unit folders
foreach my $package (@{$dh{DOPACKAGES}}) {
	my $tmpdir = tmpdir($package);

	# Install all unit folders in the debian/ directory in the
	# form $package.s6-rc/$name.
	my $basedir = "debian/$package.s6-rc";
	my $targetdir = "$tmpdir/usr/lib/s6-rc/sources";

	next unless -d $basedir;

	install_dir($targetdir);
	foreach my $namepath (glob("$basedir/*")) {
		doit("cp", '--reflink=auto', "-r", "-a", $namepath, $targetdir);
	}
}

# Complete the units, then add postinst, prerm, and postrm code blocks to
# handle start and stop of services when the package is installed, upgraded
# or removed.
foreach my $package (@{$dh{DOPACKAGES}}) {
	my $tmpdir = tmpdir($package);
	my $sourcesdir = "$tmpdir/usr/lib/s6-rc/sources";
	my (@service_units, @restart_units, %type, %hint, %group, %noenable, %nodefault);
	my ($uses_hull, $uses_notify) = (0, 0);

	my @units = grep { !/^\./ && -d "$sourcesdir/$_" } entries($sourcesdir);
	next unless @units;

	for my $unit (@units) {
		my $unitdir = "$sourcesdir/$unit";
		error("$unitdir: no type file") unless -f "$unitdir/type";
		$type{$unit} = first_line("$unitdir/type");
		$hint{$unit}{$_} = -e "$unitdir/$_" ? 1 : 0 for @HINT_FILES;
		for my $dir (@HINT_DIRS) {
			next unless -e "$unitdir/$dir";
			error("$unitdir/$dir: not a directory") unless -d "$unitdir/$dir";
			for my $name (entries("$unitdir/$dir")) {
				error("$unitdir/$dir/$name: hints are empty files")
					unless -f "$unitdir/$dir/$name" && -z _;
			}
		}
	}

	%group = pipeline_groups($sourcesdir, @units);
	for my $unit (@units) {
		$noenable{$group{$unit}} = 1 if $hint{$unit}{'.noenable'};
		$nodefault{$group{$unit}} = 1 if $hint{$unit}{'.no-default-dependencies'};
	}

	for my $unit (@units) {
		my $unitdir = "$sourcesdir/$unit";
		my $type = $type{$unit};
		my $atomic = $type eq 'oneshot' || $type eq 'longrun';

		push @service_units, $unit unless -f "$unitdir/consumer-for"; # only service units (not log units)
		push @restart_units, $unit unless -f "$unitdir/consumer-for" || $hint{$unit}{'.norestart'} || $type eq 'bundle';

		error("$unitdir: .notify needs a longrun") if $hint{$unit}{'.notify'} && $type ne 'longrun';
		next unless $atomic;

		if ($noenable{$group{$unit}}) {
			error("$unitdir: flag-recommended contradicts .noenable") if -e "$unitdir/flag-recommended";
		} elsif (! -e "$unitdir/flag-recommended") {
			write_file("$unitdir/flag-recommended", '');
		}

		if (!$nodefault{$group{$unit}}) {
			for my $dir (qw(wanted-by.d required-by.d before.d)) {
				for my $target (grep { -e "$unitdir/$dir/$_" } @EARLY_TARGETS) {
					error("$unitdir/$dir/$target: a unit in $target needs .no-default-dependencies");
				}
			}
			add_default_edge($unitdir);
		}

		my $timeout_up = read_timeout($unitdir, 'timeout-up');
		my $timeout_down = read_timeout($unitdir, 'timeout-down');

		if ($type eq 'longrun') {
			if (! -e "$unitdir/timeout-kill" && $timeout_down > 0) {
				write_file("$unitdir/timeout-kill", inner_limit($timeout_down) . "\n");
			}
			if ($hint{$unit}{'.notify'}) {
				wrap_notify($unitdir, $timeout_up);
				$uses_notify = 1;
			}
		} else {
			my $soft = entries("$unitdir/wanted-by.d") && !entries("$unitdir/required-by.d");
			$uses_hull |= wrap_script("$unitdir/up", $unit, !$soft, $timeout_up > 0 ? inner_limit($timeout_up) : 0);
			$uses_hull |= wrap_script("$unitdir/down", $unit, 0, $timeout_down > 0 ? inner_limit($timeout_down) : 0);
		}
	}

	for my $unit (@units) {
		for my $file (@HINT_FILES) {
			doit("rm", "-f", "$sourcesdir/$unit/$file") if $hint{$unit}{$file};
		}
	}

	addsubstvar($package, 'misc:Depends', $ORDER_DEPENDS)
		if grep { is_order_name($_) } map { referenced_names("$sourcesdir/$_") } @units;
	addsubstvar($package, 'misc:Depends', @$HULL_DEPENDS) if $uses_hull;
	addsubstvar($package, 'misc:Depends', @$NOTIFY_DEPENDS) if $uses_notify;

	for my $unit (@service_units) {
		error("unit name '$unit' cannot be used in the maintainer scripts")
			unless $unit =~ /^[A-Za-z0-9_.:@+-]+$/;
	}
	@service_units = uniq sort @service_units;
	@restart_units = uniq sort @restart_units;
	my @restart_roots = restart_roots($sourcesdir, \%type, @restart_units);

	# quote to be used in autoscript template
	@service_units = map { quote($_) } @service_units;
	@restart_units = map { quote($_) } @restart_units;
	@restart_roots = map { quote($_) } @restart_roots;

	autoscript($package, 'postinst', 'postinst-s6-reload');
	autoscript($package, 'postrm', 'postrm-s6-reload');

	if (@service_units) {
		autoscript($package, 'prerm', 'prerm-s6-stop', { 'UNITFILES' => join(' ', @service_units) })
	}

	if (@restart_units) {
		autoscript($package, 'postinst', 'postinst-s6-restart', { 'UNITFILES' => join(' ', @restart_units), 'RESTARTUNITS' => join(' ', @restart_roots) });
	}
}

=head1 SEE ALSO

L<debhelper(7)>, L<svctl(8)>

=head1 AUTHORS

info@automatic-server.com

=cut
