#!/usr/bin/perl

# Copyright © 2022 Felix Lechner <felix.lechner@lease-up.com>
#
# based on a shell script by the same name
#     Arjan Oosting <arjan@debian.org>
#
# 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 3 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, see <http://www.gnu.org/licenses/>.

use v5.20;
use warnings;
use utf8;

use Const::Fast;
use File::Basename;
use Getopt::Long ();
use IPC::Run3;
use List::SomeUtils qw(any uniq);
use Path::Tiny;
use Unicode::UTF8 qw(encode_utf8);

use Debian::Debhelper::Buildsystem::Haskell::Recipes qw(
  run_quiet
  run
  installable_type
  source_hc
  find_config_for_ghc
  ghc_pkg_command
  load_ghc_database
  hashed_id_to_virtual_installable
);

const my $EMPTY => q{};
const my $SPACE => q{ };
const my $COMMA => q{,};
const my $PLUS => q{+};

const my $NEWLINE => qq{\n};
const my $NULL => qq{\0};

const my $WAIT_STATUS_SHIFT => 8;

my $program_name = basename($0);

my @excludes;

my %options = (
    'exclude|X=s' => \@excludes,
    'help|h' => \&show_help,
);

Getopt::Long::Configure('gnu_getopt', 'pass_through');
Getopt::Long::GetOptions(%options)
  or die encode_utf8("error parsing options\n");

my @args_bytes = grep { /^-/ } @ARGV;
my @ghc_configs = grep { !/^-/ } @ARGV;

die encode_utf8("Installed package description file $_ can not be found")
  for grep { !-e } @ghc_configs;

$ENV{DH_EXCLUDES} = join($SPACE, @excludes);

die encode_utf8('grep-dctrl is missing')
  unless system('command -v grep-dctrl > /dev/null') == 0;

my $haskell_compiler = source_hc() || $ENV{DEB_DEFAULT_COMPILER};
my $haskell_ghc_pkg = ghc_pkg_command();

my @extra_depends
  = get_extra_depends($haskell_compiler, $haskell_ghc_pkg,
    $ENV{DEB_GHC_DATABASE});

my $package_list = run('dh_listpackages', @args_bytes);
chomp $package_list;

my @installables = split($SPACE, $package_list);
for my $installable (@installables) {

    my $substvars_path = "debian/$installable.substvars";

    replace_line($substvars_path, 'haskell:Extra-Depends',
        join($COMMA . $SPACE, @extra_depends));

    my $type = installable_type($installable);

    my @depends;
    my @recommends;
    my @suggests;

    if (any { $haskell_compiler eq $_ } qw{ghc ghcjs}) {

        if (any { $type eq $_ } qw{dev prof}) {

            @ghc_configs = find_config_for_ghc($installable)
              unless @ghc_configs;

            die encode_utf8(
'dh_haskell_depends - no installed package description files found'
            )unless @ghc_configs;

            my @hashed_ids
              = cabal_depends($haskell_ghc_pkg, $ENV{DEB_GHC_DATABASE},
                @ghc_configs);

            my @ghc_depends;
            for my $hashed_id (@hashed_ids) {

                # look in normal database
                my $prerequisite
                  =hashed_id_to_virtual_installable($haskell_compiler,
                    $hashed_id, $type, $haskell_ghc_pkg, '--global');

      # as a transition measure, check if dpkg knows about this virtual package
                next
                  unless system(
                    "dpkg-query --show $prerequisite > /dev/null 2> /dev/null")
                  == 0;

                if (!length $prerequisite) {

                    my $installable
                      = providing_package_for_ghc($haskell_compiler,
                        $hashed_id, $type);

                    if (!length $installable) {

                        warn encode_utf8(
"WARNING: No Debian package provides the hashed Hackage id $hashed_id."
                        );
                        next;
                    }

                    my $version
                      = run(qw{dpkg-query --showformat=${Version} --show},
                        $installable);

                    if (!length $version) {

                        warn encode_utf8(
"WARNING: No Debian version available for installable $installable."
                        );
                        next;
                    }

                    my $next_upstream_version = $version;
                    $next_upstream_version =~ s{ - [^-]* $}{}x;
                    $next_upstream_version .= $PLUS;

                    $prerequisite
                      ="$installable (>= $version), $installable (<< $next_upstream_version)";
                }

                push(@ghc_depends, $prerequisite);
            }

            if ($type eq 'dev') {

                push(@depends, @ghc_depends);

                my $prof = $installable;
                $prof =~ s{ - [^-]+ $}{-prof}x;

                my $doc = $installable;
                $doc =~ s{ - [^-]+ $}{-doc}x;

                push(@suggests, $doc)
                  if system(qw{grep-dctrl --quiet --field=Package},
                    $doc, 'debian/control') == 0;

                push(@suggests, $prof)
                  if system(qw{grep-dctrl --quiet --field=Package},
                    $prof, 'debian/control') == 0;
            }

            if ($type eq 'prof') {

                my $dev = $installable;
                $dev =~ s{ - [^-]+ $}{-dev}x;

                push(@depends, "$dev (=\${binary:Version})");
                push(@depends, @ghc_depends);
            }
        }

        if ($type eq 'doc') {

            my $haddock_version = qx{haddock --interface-version};
            chomp $haddock_version;

            push(@depends, "haddock-interface-$haddock_version");

            say encode_utf8(
"Finding all links in the documentation in installable $installable."
            );
            my @links =split(
                m{\n}x,
                run_quiet(
                    'find', "debian/$installable",
                    qw{-name *.html -exec hxwls -r \{\} ;}
                ));

            my @files;
            for my $link (@links) {

                # filter out fragment, too
                next
                  unless $link =~ m{^ file:// ([^#]*) }x;

                my $file = $1;
                push(@files, $file);
            }

            my @absolute = uniq +grep { m{^ / }x } @files;

            # already in UTF-8
            my $input_bytes = $EMPTY;
            $input_bytes .= $_ . $NULL for @absolute;

            my $stdout_bytes;
            my $stderr_bytes;

            my @combined = qw{xargs --null --no-run-if-empty dpkg --search};
            run3(\@combined, \$input_bytes, \$stdout_bytes, \$stderr_bytes);

            my $exitcode = $?;
            my $status = ($exitcode >> $WAIT_STATUS_SHIFT);

            # already in UTF-8
            warn encode_utf8("Non-zero exit code $exitcode.")
              . $NEWLINE
              . $stderr_bytes
              if $exitcode;

            my @lines = split(m{\n}, $stdout_bytes);

            my @prerequisites;
            for my $line (@lines) {

                my ($origin) = split(m{:}, $line, 2);
                next
                  unless length $origin;

                push(@prerequisites, $origin);
            }

            push(@recommends, @prerequisites);

            my $dev = $installable;
            $dev =~ s{ - [^-]+ $}{-dev}x;

            push(@recommends, $dev)
              if system(qw{grep-dctrl --quiet --field=Package},
                $dev, 'debian/control') == 0;
        }
    }

    if ($haskell_compiler eq 'hugs') {

        my $version= run(qw{dpkg-query --showformat=${Version} --show hugs});
        my $upstream_version = $version;
        $upstream_version =~ s{ - [^-]* $}{}x;

        push(@depends, "hugs (>= $upstream_version)");
    }

    local $ENV{LC_ALL} = 'C.UTF-8';

    replace_line($substvars_path, 'haskell:Depends',
        join($COMMA . $SPACE, (sort +uniq @depends)));
    replace_line($substvars_path, 'haskell:Recommends',
        join($COMMA . $SPACE, (sort +uniq @recommends)));
    replace_line($substvars_path, 'haskell:Suggests',
        join($COMMA . $SPACE, (sort +uniq @suggests)));
}

exit;

sub cabal_depends {
    my ($ghc_pkg, $tmp_db, @configs) = @_;

    # fix sort order
    local $ENV{LC_ALL} = 'C.UTF-8';

    load_ghc_database($ghc_pkg, $tmp_db, @configs);

    my @prerequisites;
    for my $config (@configs) {

        my $name = path($config)->basename(qr{ [.]conf $}x);
        my $depends
          = run($ghc_pkg, '--package-db', $tmp_db, qw{--simple-output field},
            $name, 'depends');
        push(@prerequisites, split($SPACE, $depends // $EMPTY));
    }

    my @have = sort +uniq @prerequisites;
    my @exclude_patterns = split($SPACE, $ENV{DH_EXCLUDES} // $EMPTY);

    # not sure this complies with Debhelper expectations
    # excluded installables matching the patterns with or without version
    # the versions should probably be dropped by the caller
    s{ - [0-9] [.0-9a-zA-Z]* $}{}x for @exclude_patterns;

    my @retained;
    for my $prerequisite (@have) {

        next
          if any { $prerequisite =~ m{\Q$_\E} } @exclude_patterns;

        push(@retained, $prerequisite);
    }

    return @retained;
}

sub providing_package_for_ghc {
    my ($compiler, $hashed_id, $type) = @_;

    my $extension = $EMPTY;
    $extension = '_p'
      if $type eq 'prof';

    my $ghc_version= run(qw{dpkg-query --showformat=${Version} --show ghc});

    my $directory_line= ghc_pkg_field($compiler, $hashed_id, 'library-dirs');
    my (undef, $directory_list) = split(m{ \s* : \s* }x, $directory_line, 2);
    my @library_dirs = split(m{ \s* , \s* }x, $directory_list);

    my $library_line = ghc_pkg_field($compiler, $hashed_id, 'hs-libraries');
    my (undef, $library_list) = split(m{ \s* : \s* }x, $library_line, 2);
    my @libraries = split(m{ \s* , \s* }x, $library_list);

    # look only at the first one
    my $library = $libraries[0];

    for my $directory (@library_dirs) {

        my $library_path = "$directory/lib$library$extension.a";
        next
          unless -e $library_path;

        my $line = run(qw{dpkg-query --search}, $library_path);
        my ($installable) = split(m{ \s* : \s* }x, $line, 2);

        return $installable;
    }

    return ();
}

sub get_extra_depends {
    my ($compiler, $ghc_pkg, $tmp_db) = @_;

    local $ENV{LC_ALL} = 'C.UTF-8';

    $ENV{DEB_SETUP_BIN_NAME} //= 'debian/hlibrary.setup';

    my $output = run($ENV{DEB_SETUP_BIN_NAME},
        'register', "--builddir=dist-$compiler",
        qw{--gen-pkg-config --verbose=verbose+nowrap});

    my @prerequisites;

    if ($output
        =~ m{^Creating \s package \s registration \s file: \s+ (\S+) $}mx) {

        my $pkg_config = $1;

        my @hackages = cabal_depends($ghc_pkg, $tmp_db, $pkg_config);

        run(qw{rm -f}, $pkg_config);

        for my $hackage (@hackages) {

            next
              unless $hackage =~ m{^ ([^-]+) - ([0-9.]+) - [0-9a-f]{32} $}x;

            my $name = $1;
            my $version = $2;

            my $extra_packages_file
              = "/usr/lib/haskell-packages/extra-packages/$name-$version";

            push(@prerequisites,
                split(m{ \s* , \s* }x, path($extra_packages_file)->slurp_utf8))
              if -e $extra_packages_file;
        }

    } else {
        warn encode_utf8(
"$program_name: Skipping extra depends; cannot find package registration file (probablu not a library."
        );
    }

    return @prerequisites;
}

sub ghc_pkg_field {
    my ($compiler, $hashed_id, $field) = @_;

    my $output= run("$compiler-pkg", qw{--global field}, $hashed_id, $field);

    # may not process multi-line fields correctly
    my ($value) = split($NEWLINE, $output, 2);

    return ($value // $EMPTY);
}

sub replace_line {
    my ($path, $field, $value) = @_;

    path($path)->touch;

    my @lines = grep { !m{^ $field = }x } path($path)->lines_utf8;

    push(@lines, "$field=$value" . $NEWLINE);

    path($path)->spew_utf8(@lines);

    return;
}

sub show_help {
    my $message =<<"EOT";
Usage: $program_name [options] cabal-file ...

Options:
    -X, --exclude INSTALLABLE    exclude INSTALLABLE from processing
EOT

    print encode_utf8($message);

    exit;
}

=head1 NAME

dh_haskell_depends - calculates Haskell dependencies on Cabalized libraries

=head1 SYNOPSIS

B<dh_haskell_depends> [S<I<debhelper options>>]
[B<-X>I<package>]
[B<--exclude=>I<package>]
[S<I<file>> ...]

=head1 DESCRIPTION

dh_haskell_depends is a debhelper program that helps with calculating dependencies
for building Haskell libraries.

It automates building libraries for the different supported Haskell systems in
Debian.

This script writes the debian/$package.substvars file, including in it the
haskell:Depends, haskell:Recommends, haskell:Suggests and haskell:Extra-Depends
variable.  So, to use this package, include in the Depends: field in debian/control
${haskell:Depends}, and do the same for Recommends, Suggests and Extra-Depends.

=head1 BUGS

hugs and ghc are the only supported targets at the moment.  Cabal does
not yet support nhc98.

=head1 SEE ALSO

L<dh_haskell_provides(1)>
L<dh_haskell_shlibdeps(1)>
L<debhelper(7)>

=head1 AUTHOR

John Goerzen <jgoerzen@complete.org>

Based on ideas in dh_python by Josselin Mouette <joss@debian.org>

=cut

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