# systemd -- lintian check script -*- perl -*-
#
# Copyright (C) 2013 Michael Stapelberg
# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
# Copyright (C) 2021 Felix Lechner
#
# based on the apache2 checks file by:
# Copyright (C) 2012 Arno Toell
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, you can find it on the World Wide
# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

package Lintian::Check::Systemd;

use v5.20;
use warnings;
use utf8;

use Const::Fast;
use Data::Validate::URI qw(is_uri);
use List::Compare;
use List::SomeUtils qw(any none);
use Text::ParseWords qw(shellwords);

use Moo;
use namespace::clean;

with 'Lintian::Check';

const my $EMPTY => q{};

# "Usual" targets for WantedBy
const my @WANTEDBY_WHITELIST => qw{
  default.target
  graphical.target
  multi-user.target
  network-online.target
  sleep.target
  sysinit.target
};

# init scripts that do not need a service file
has PROVIDED_BY_SYSTEMD => (
    is => 'rw',
    lazy => 1,
    default =>sub {
        my ($self) = @_;

        return $self->data->load('systemd/init-whitelist');
    }
);

# array of names provided by the service files.
# This includes Alias= directives, so after parsing
# NetworkManager.service, it will contain NetworkManager and
# network-manager.
has service_names => (is => 'rw', default => sub { [] });

has timer_files => (is => 'rw', default => sub { [] });

has init_files_by_service_name => (is => 'rw', default => sub { {} });
has cron_scripts => (is => 'rw', default => sub { [] });

has is_rcs_script_by_name => (is => 'rw', default => sub { {} });

sub visit_installed_files {
    my ($self, $item) = @_;

    if ($item->name =~ m{/systemd/system/.*\.service$}) {

        $self->check_systemd_service_file($item);

        my $service_name = $item->basename;
        $service_name =~ s/@?\.service$//;

        push(@{$self->service_names}, $service_name);

        my @aliases
          = $self->extract_service_file_values($item, 'Install', 'Alias');

        for my $alias (@aliases) {

            $self->pointed_hint('systemd-service-alias-without-extension',
                $item->pointer)
              if $alias !~ m/\.service$/;

            # maybe issue a tag for duplicates?

            $alias =~ s{ [.]service $}{}x;
            push(@{$self->service_names}, $alias);
        }
    }

    push(@{$self->timer_files}, $item)
      if $item->name =~ m{^(?:usr/)?lib/systemd/system/[^\/]+\.timer$};

    push(@{$self->cron_scripts}, $item)
      if $item->dirname =~ m{^ etc/cron[.][^\/]+ / $}x;

    if (
        $item->dirname eq 'etc/init.d/'
        && !$item->is_dir
        && (none { $item->basename eq $_} qw{README skeleton rc rcS})
        && $self->processable->name ne 'initscripts'
        && $item->link ne 'lib/init/upstart-job'
    ) {

        unless ($item->is_file) {

            $self->pointed_hint('init-script-is-not-a-file', $item->pointer);
            return;
        }

        # sysv generator drops the .sh suffix
        my $service_name = $item->basename;
        $service_name =~ s{ [.]sh $}{}x;

        $self->init_files_by_service_name->{$service_name} //= [];
        push(@{$self->init_files_by_service_name->{$service_name}}, $item);

        $self->is_rcs_script_by_name->{$item->name}
          = $self->check_init_script($item);
    }

    if ($item->name =~ m{ /systemd/system/ .*[.]socket $}x) {

        my @values
          = $self->extract_service_file_values($item,'Socket','ListenStream');

        $self->pointed_hint('systemd-service-file-refers-to-var-run',
            $item->pointer, 'ListenStream', $_)
          for grep { m{^/var/run/} } @values;
    }

    return;
}

sub installable {
    my ($self) = @_;

    my $lc = List::Compare->new([keys %{$self->init_files_by_service_name}],
        $self->service_names);

    my @missing_service_names = $lc->get_Lonly;

    for my $service_name (@missing_service_names) {

        next
          if $self->PROVIDED_BY_SYSTEMD->recognizes($service_name);

        my @init_files
          = @{$self->init_files_by_service_name->{$service_name} // []};

        for my $init_file (@init_files) {

            # rcS scripts are particularly bad; always tag
            $self->pointed_hint(
                'missing-systemd-service-for-init.d-rcS-script',
                $init_file->pointer, $service_name)
              if $self->is_rcs_script_by_name->{$init_file->name};

            $self->pointed_hint('omitted-systemd-service-for-init.d-script',
                $init_file->pointer, $service_name)
              if @{$self->service_names}
              && !$self->is_rcs_script_by_name->{$init_file->name};

            $self->pointed_hint('missing-systemd-service-for-init.d-script',
                $init_file->pointer, $service_name)
              if !@{$self->service_names}
              && !$self->is_rcs_script_by_name->{$init_file->name};
        }
    }

    if (!@{$self->timer_files}) {

        $self->pointed_hint('missing-systemd-timer-for-cron-script',
            $_->pointer)
          for @{$self->cron_scripts};
    }

    return;
}

# Verify that each init script includes /lib/lsb/init-functions,
# because that is where the systemd diversion happens.
sub check_init_script {
    my ($self, $item) = @_;

    my $lsb_source_seen;
    my $is_rcs_script = 0;

    my @lines = split(/\n/, $item->decoded_utf8);

    my $position = 1;
    for my $line (@lines) {

        # trim left
        $line =~ s/^\s+//;

        $lsb_source_seen = 1
          if $position == 1
          && $line
          =~ m{\A [#]! \s* (?:/usr/bin/env)? \s* (?:/usr)?/lib/init/init-d-script}xsm;

        $is_rcs_script = 1
          if $line =~ m{#.*Default-Start:.*S};

        next
          if $line =~ /^#/;

        $lsb_source_seen = 1
          if $line
          =~ m{(?:\.|source)\s+(?:/usr)?/lib/(?:lsb/init-functions|init/init-d-script)};

    } continue {
        ++$position;
    }

    $self->pointed_hint('init.d-script-does-not-source-init-functions',
        $item->pointer)
      unless $lsb_source_seen;

    return $is_rcs_script;
}

sub check_systemd_service_file {
    my ($self, $item) = @_;

    # ambivalent about /lib or /usr/lib
    $self->pointed_hint('systemd-service-in-odd-location', $item->pointer)
      if $item =~ m{^etc/systemd/system/};

    unless ($item->is_open_ok
        || ($item->is_symlink && $item->link eq '/dev/null')) {

        $self->pointed_hint('service-file-is-not-a-file', $item->pointer);
        return 0;
    }

    my @values = $self->extract_service_file_values($item, 'Unit', 'After');
    my @obsolete = grep { /^(?:syslog|dbus)\.target$/ } @values;

    $self->pointed_hint('systemd-service-file-refers-to-obsolete-target',
        $item->pointer, $_)
      for @obsolete;

    $self->pointed_hint('systemd-service-file-refers-to-obsolete-bindto',
        $item->pointer)
      if $self->extract_service_file_values($item, 'Unit', 'BindTo');

    for my $key (
        qw(ExecStart ExecStartPre ExecStartPost ExecReload ExecStop ExecStopPost)
    ) {
        $self->pointed_hint('systemd-service-file-wraps-init-script',
            $item->pointer, $key)
          if any { m{^/etc/init\.d/} }
          $self->extract_service_file_values($item, 'Service', $key);
    }

    unless ($item->link eq '/dev/null') {

        my @wanted_by
          = $self->extract_service_file_values($item, 'Install', 'WantedBy');
        my $is_oneshot = any { $_ eq 'oneshot' }
          $self->extract_service_file_values($item, 'Service', 'Type');

        # We are a "standalone" service file if we have no .path or .timer
        # equivalent.
        my $is_standalone = 1;
        if ($item =~ m{^(usr/)?lib/systemd/system/([^/]*?)@?\.service$}) {

            my ($usr, $service) = ($1 // $EMPTY, $2);

            $is_standalone = 0
              if $self->processable->installed->resolve_path(
                "${usr}lib/systemd/system/${service}.path")
              || $self->processable->installed->resolve_path(
                "${usr}lib/systemd/system/${service}.timer");
        }

        for my $target (@wanted_by) {

            $self->pointed_hint(
                'systemd-service-file-refers-to-unusual-wantedby-target',
                $item->pointer, $target)
              unless (any { $target eq $_ } @WANTEDBY_WHITELIST)
              || $self->processable->name eq 'systemd';
        }

        my @documentation
          = $self->extract_service_file_values($item, 'Unit','Documentation');

        $self->pointed_hint('systemd-service-file-missing-documentation-key',
            $item->pointer)
          unless @documentation;

        for my $documentation (@documentation) {

            my @uris = split(m{\s+}, $documentation);

            my @invalid = grep { !is_uri($_) } @uris;

            $self->pointed_hint('invalid-systemd-documentation',
                $item->pointer, $_)
              for @invalid;
        }

        my @kill_modes
          = $self->extract_service_file_values($item, 'Service','KillMode');

        for my $kill_mode (@kill_modes) {

            # trim both ends
            $kill_mode =~ s/^\s+|\s+$//g;

            $self->pointed_hint('kill-mode-none',$item->pointer, $_)
              if $kill_mode eq 'none';
        }

        if (   !@wanted_by
            && !$is_oneshot
            && $is_standalone
            && $item =~ m{^(?:usr/)?lib/systemd/[^\/]+/[^\/]+\.service$}
            && $item !~ m{@\.service$}) {

            $self->pointed_hint('systemd-service-file-missing-install-key',
                $item->pointer)
              unless $self->extract_service_file_values($item, 'Install',
                'RequiredBy')
              || $self->extract_service_file_values($item, 'Install', 'Also');
        }

        my @pidfile
          = $self->extract_service_file_values($item,'Service','PIDFile');
        for my $x (@pidfile) {
            $self->pointed_hint('systemd-service-file-refers-to-var-run',
                $item->pointer, 'PIDFile', $x)
              if $x =~ m{^/var/run/};
        }

        if (
            $self->extract_service_file_values(
                $item, 'Unit', 'DefaultDependencies', 1
            )
        ) {
            my @before
              = $self->extract_service_file_values($item, 'Unit','Before');
            my @conflicts
              = $self->extract_service_file_values($item, 'Unit','Conflicts');

            $self->pointed_hint('systemd-service-file-shutdown-problems',
                $item->pointer)
              if (none { $_ eq 'shutdown.target' } @before)
              && (any { $_ eq 'shutdown.target' } @conflicts);
        }

        my %bad_users = (
            'User' => 'nobody',
            'Group' => 'nogroup',
        );

        for my $key (keys %bad_users) {

            my $value = $bad_users{$key};

            $self->pointed_hint('systemd-service-file-uses-nobody-or-nogroup',
                $item->pointer, "$key=$value")
              if any { $_ eq $value }
              $self->extract_service_file_values($item, 'Service',$key);
        }

        for my $key (qw(StandardError StandardOutput)) {
            for my $value (qw(syslog syslog-console)) {

                $self->pointed_hint(
                    'systemd-service-file-uses-deprecated-syslog-facility',
                    $item->pointer, "$key=$value")
                  if any { $_ eq $value }
                  $self->extract_service_file_values($item, 'Service',$key);
            }
        }
    }

    return 1;
}

sub service_file_lines {
    my ($item) = @_;

    my @output;

    return @output
      if $item->is_symlink and $item->link eq '/dev/null';

    my @lines = split(/\n/, $item->decoded_utf8);
    my $continuation = $EMPTY;

    my $position = 1;
    for my $line (@lines) {

        $line = $continuation . $line;
        $continuation = $EMPTY;

        if ($line =~ s/\\$/ /) {
            $continuation = $line;
            next;
        }

        # trim right
        $line =~ s/\s+$//;

        next
          unless length $line;

        next
          if $line =~ /^[#;\n]/;

        push(@output, $line);
    }

    return @output;
}

# Extracts the values of a specific Key from a .service file
sub extract_service_file_values {
    my ($self, $item, $extract_section, $extract_key) = @_;

    return ()
      unless length $extract_section && length $extract_key;

    my @values;
    my $section;

    my @lines = service_file_lines($item);
    for my $line (@lines) {
        # section header
        if ($line =~ /^\[([^\]]+)\]$/) {
            $section = $1;
            next;
        }

        if (!defined($section)) {
            # Assignment outside of section. Ignoring.
            next;
        }

        my ($key, $value) = ($line =~ m{^(.*)\s*=\s*(.*)$});
        if (   defined($key)
            && $section eq $extract_section
            && $key eq $extract_key) {

            if (length $value) {
                push(@values, shellwords($value));

            } else {
                # Empty assignment resets the list
                @values = ();
            }
        }
    }

    return @values;
}

1;

# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
