#!/usr/bin/perl
#
# dupload - utility to upload Debian packages
#
# Copyright © 1996, 1997 Heiko Schlittermann
# Copyright © 1999 Stephane Bortzmeyer
# Copyright © 1999, 2002, 2003 Josip Rodin <joy-packages@debian.org>
# Copyright © 2005, 2006, 2008, 2011 Frank Lichtenheld <djpig@debian.org>
# Copyright © 2017-2025 Guillem Jover <guillem@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 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, see <https://www.gnu.org/licenses/>.
#
# see dupload(1) for help.

use strict;
use warnings;
use feature qw(state);

use IO::Handle;
use IO::Socket;
use List::Util qw(any uniq);
use Cwd;
use Getopt::Long;
use Dpkg::Path qw(find_command);
use File::Basename;
use File::Copy;
use Net::FTP;
use HTTP::Tiny;

#
# More or less configurable constants.
#

my $version = '2.x';
my $progname = basename($0);
my $user = $ENV{DUPLOAD_USER} || getlogin || getpwuid($<) || $ENV{LOGNAME} || $ENV{USER};
my $myhost = $ENV{DUPLOAD_HOST} || qx(hostname --fqdn);
chomp $myhost;
my $cwd = getcwd();

my @hook_types = qw(host changes sourcepackage package file deb);

# For somewhat more verbose output from the ftp module.
my $debug = 0;
# Do it, even when already done.
my $force = 0;
# Keep going, even if checksum errors.
my $keep = 0;
# Do not talk too much.
my $quiet = 0;
# If do-nothing.
my $dry;
my $mailonly;

# The configuration files that have been loaded.
my @configfiles_loaded;
# Specifies an alternative configuration file to read.
my $configfile = undef;

# Target host.
my $host = undef;
# Transfer method.
my $method = 'ftp';
# Whether the method used uploads in batches.
my $batchmode = 0;
# Login name.
my $login;
# Password.
my $passwd;
# Password fetching command.
my $passwd_cmd;
# Extra options for rsync or scp.
my @options;
# Keyrings for OpenPGP verification.
my @keyrings;

my $mta = '/usr/sbin/sendmail';

# Method specific variables.
my $ssh_target;
my @ssh_options;
my @scp_options;
my $http_uri = q{};

#
# Global variables
#

# The files we will have to read from.
my @changes;
# The packages we skipped.
my @skipped;
# The files we installed (for postupload processing).
my @all_the_files;
# The packages we installed (for postupload processing).
my @all_the_debs;
# All binary packages we installed (for postupload processing).
my %all_packages;

# Variables per host.
my $fqdn;
my $ftp;
my $http;
my $dinstall_runs;
my $passive;
my $nostats;
my $nomail;
my $archive;
my $noarchive;
my %preupload;
my %postupload;
my %skip_hook;
my $incoming;
my $queuedir;
my $distallowlist;
my $distblocklist;
my $mail;
my $visiblename;
my $visibleuser;
my $fullname;
my $dochmode;
my $filemode;

# Variables per job.
my %files;
my %package;
my %version;
my %arch;
my %dir;
my %changes;
my %log;
my %announce;
my %extra;

# Some tests on constants.
$user or fatal('Who am I? (cannot get user identity)');
$myhost or fatal('Who am I? (cannot get hostname)');
$cwd or fatal('Where am I? (cannot get current directory)');

#
# Main
#

$config::default_host = undef;
$config::no_parentheses_to_fullname = undef;
$config::mta = undef;
$config::postupload = undef;
$config::preupload = undef;

configure('/etc/dupload.conf', $ENV{HOME} && "$ENV{HOME}/.dupload.conf");

our $opt_Version;
our $opt_configfile;
our $opt_debug;
our $opt_force;
our $opt_help;
our $opt_keep;
our $opt_mailonly;
our $opt_mta;
our $opt_no;
our $opt_nostats;
our $opt_noarchive;
our $opt_nomail;
our $opt_print;
our $opt_quiet;
our $opt_to;
our $opt_version;
our @opt_skip_hooks;

$Getopt::Long::ignorecase = 0;
GetOptions qw(
    configfile=s
    debug:i
    force
    help
    keep
    mailonly
    mta=s
    no
    noarchive
    nomail
    nostats
    print
    quiet
    skip-hooks=s@
    to=s
    version
    Version
) or fatal('Bad options');

$configfile = $opt_configfile;
configure($configfile) if defined $configfile;
if (@configfiles_loaded == 0) {
    fatal('No configuration files');
}

$dry = defined $opt_no;
$mailonly = defined $opt_mailonly;
$dry = 1 if $mailonly;
$debug = $opt_debug || $debug;
$keep = $opt_keep || $keep;
$host = $opt_to || $config::default_host;
$mta = $opt_mta || $config::mta || $mta;
my $skip_hooks;
$skip_hooks = join ',', @opt_skip_hooks if @opt_skip_hooks;
%skip_hook = map {
    $_ => 1
} split /,/, $skip_hooks // $ENV{DUPLOAD_SKIP_HOOKS} // q{};
$force = $opt_force || $force;
$nomail = $opt_nomail || 0;
$nostats = $opt_nostats || 0;
$quiet = $opt_quiet;

# Only info or version?
if ($opt_print) {
    info($opt_to);
    exit 0;
}
if ($opt_Version or $opt_version) {
    p("$progname version: $version\n");
    exit 0;
}

if ($opt_help) {
    p(
"Usage: $progname [<options>...] [<changes-file|directory>...]\n" .
"\n" .
"Options:\n" .
"  -t, --to <nickname>      Upload to <nickname>'s host.\n" .
"  -f, --force              Upload even if a previous upload is present.\n" .
"  -k, --keep               Keep going, ignore packages with wrong checksums\n" .
"      --no                 Dry run.\n" .
"      --nostats            Suppress download statistics.\n" .
"      --nomail             Suppress mail announcement for this run.\n" .
"      --mailonly           Dry run, except that mail announcement is sent.\n" .
"      --mta <pathname>     Use <pathname> as the sendmail compatible MTA.\n" .
"      --noarchive          Mark the mail announcement to not be archived.\n" .
"      --skip-hooks <hooks> Skip the comma-separated list of hooks.\n" .
"  -p, --print              Print the configuration file.\n" .
"  -c, --configfile <file>  Use <file> as the configuration file.\n" .
"  -q, --quiet              Enable quiet mode.\n" .
"  -d, --debug [<level>]    Enable debug output from ftp, scp, scpb methods.\n" .
"      --help               Print this help message.\n" .
"  -V, --Version            Print program version.\n"
    );
    exit 0;
}

unless (-x $mta) {
    $nomail = 1;
    w("mail options disabled, cannot run '$mta': $!\n");
}

# Get the configuration for that host global, job independent information.

$host or fatal('Need host to upload to. (See --to option or the default_host configuration variable)');

{
    my $nick = $config::cfg{$host} or fatal("Unknown host $host");
    $method = $nick->{method} || $method;
    if (defined $nick->{options} && ref $nick->{options} eq 'ARRAY') {
        @options = @{$nick->{options}};
    } elsif (defined $nick->{options}) {
        # XXX: Deprecated in the future.
        # w("'options' defined as a scalar is deprecated; use an arrayref\n");
        @options = split ' ', $nick->{options};
    }
    $fqdn = $nick->{fqdn};
    $fqdn = $myhost if $method eq 'copy';
    $incoming = $nick->{incoming} or fatal('No incoming directory');
    $queuedir = $nick->{queuedir};
    if (defined $nick->{keyrings} && ref $nick->{keyrings} eq 'ARRAY') {
        @keyrings = @{$nick->{keyrings}};
    }
    $distallowlist = $nick->{distallowlist};
    $distblocklist = $nick->{distblocklist};

    $mail = $nick->{mail} // [];
    foreach my $mail (@{$mail}) {
        fatal("No mail 'match' for $nick") unless length $mail->{match};
        fatal("No mail 'to' for $nick") unless length $mail->{to};
    }

    # Catch obsolete keys.
    if (defined $nick->{distwhitelist}) {
        fatal('distwhitelist is obsolete; use distallowlist instead');
    }
    if (defined $nick->{distblacklist}) {
        fatal('distblacklist is obsolete; use distblocklist instead');
    }
    foreach my $key (qw(mailto mailtx cc)) {
        if (defined $nick->{$key}) {
            fatal("$key key is obsolete; use mail instead");
        }
    }

    $dinstall_runs = $nick->{dinstall_runs};
    $passive = $nick->{passive};
    $dochmode = !exists $nick->{filemode} && defined $nick->{filemode};
    $filemode = ($nick->{filemode} // 0644) & 07777;

    if ($passive and ($method ne 'ftp')) {
        fatal("Passive mode is only for FTP ($host)");
    }
    if (not $fqdn) {
        fatal("Nothing known about host $host");
    }
    if (defined $nick->{archive}) {
        $archive = $nick->{archive};
    } else {
        $archive = 1;
    }

    foreach my $category (@hook_types) {
        my $preupload_hooks;
        if (defined $nick->{preupload}{$category}) {
            $preupload_hooks = $nick->{preupload}{$category};
        } else {
            $preupload_hooks = $config::preupload{$category};
        }
        if (ref $preupload_hooks ne 'ARRAY') {
            fatal("preupload hook $category is not an array");
        }
        push @{$preupload{$category}}, @{$preupload_hooks};

        my $postupload_hooks;
        if (defined $nick->{postupload}{$category}) {
            $postupload_hooks = $nick->{postupload}{$category};
        } else {
            $postupload_hooks = $config::postupload{$category};
        }
        if (ref $postupload_hooks ne 'ARRAY') {
            fatal("postupload hook $category is not an array");
        }
        push @{$postupload{$category}}, @{$postupload_hooks};
    }

    if (any { $method eq $_ } qw(scpb rsync)) {
        $batchmode = 1;
    }

    if ($method eq 'ftp') {
        $login = $nick->{login} || 'anonymous';

        # Do not accept passwords in configuration file, except for anonymous
        # logins.
        if ($login =~ /^anonymous|ftp$/) {
            $passwd = "$user\@$myhost";
            $passwd = $nick->{password} if $nick->{password};
        } else {
            undef $passwd;
        }
    }
    if ($method eq 'https' and not HTTP::Tiny::can_ssl()) {
        fatal('Method https requested but missing IO::Socket::SSL module');
    }
    if ($method eq 'http' or $method eq 'https') {
        eval {
            require URI;
            require URI::Escape;
            1;
        } or do {
            fatal('HTTP auth in use but missing URI and/or URI::Escape modules');
        };
        URI->import();
        URI::Escape->import();

        $login = $nick->{login};

        # Do not accept passwords in configuration file.
        if (defined $nick->{password}) {
            fatal('password not allowed in configuration; ' .
                  'use a passwordcmd or type it on the prompt');
        }
        undef $passwd;

        $incoming =~ s{^/*}{}g;
        $incoming =~ s{/*$}{}g;

        $http_uri = URI->new("$method://$fqdn/$incoming");
    }
    if ($method eq 'scp' or $method eq 'scpb' or $method eq 'rsync') {
        $login = $nick->{login};
        $ssh_target = "$login\@" if defined $login;
        $ssh_target .= "$fqdn:$incoming";
        push @ssh_options, qw(-x);
        push @ssh_options, ('-l', $login) if defined $login;
        push @ssh_options, qw(-v) x $debug if $debug;
        push @scp_options, qw(-q) if $quiet;
        push @scp_options, qw(-v) x $debug if $debug;
        push @scp_options, @options;
    }

    $passwd_cmd = $nick->{passwordcmd};

    $visibleuser = $nick->{visibleuser} || $user;
    chomp $visibleuser;
    $visiblename = $nick->{visiblename} || '';
    chomp $visiblename;
    $fullname = $nick->{fullname} || '';
}

# Command-line options have precedence over configuration files:

if (scalar @{$mail} == 0) {
    p("dupload note: no announcement will be sent.\n");
}

$noarchive = $opt_noarchive || (!$archive);

#
# Get the changes file names.
#

# Use current dir if no args.
@ARGV or push @ARGV, '.';

foreach my $pathname (@ARGV) {
    stat $pathname;

    if (! -r _) {
        fatal("Cannot read $pathname: $!");
    }
    if (-f _) {
        if ($pathname !~ /\.changes$/) {
            w("no .changes extension: $pathname\n");
        }
        unshift @changes, $pathname;
        next;
    }
    if (-d _) {
        my @f = glob "$pathname/*.changes";
        if (@f == 0) {
            w("no changes file in dir $pathname\n");
        }
        unshift @changes, @f;
        next;
    }
}

@changes or fatal('No changes file, so nothing to do');

preupload_hook('host', [ $host ]);

# Preupload code for changes files.
foreach my $change (@changes) {
    preupload_hook('changes', [ $change ]);
}

p("Uploading ($method) to $fqdn:$incoming");
p("\nand moving to $fqdn:$queuedir") if $queuedir;
p("\n");

*STDOUT->autoflush();

# Parse the changes files and update some hashes, indexed by the jobname:
#  %job - the files to be uploaded
#  %log - the logfile name
#  %dir - where the files are located
#  %announce -

PACKAGE: foreach my $change (@changes) {
    my $dir = dirname($change);
    my $cf = basename($change);
    my $job = basename($cf, '.changes');
    my ($package, $version, $arch) = (split /_/, $job, 3);
    my ($upstream, $debian) = (split /-/, $version, 2);
    my $log = "$job.upload";

    my (@files, @done, @extra);
    my (%mailto, %fields);

    chdir $dir or fatal("Cannot change directory to $dir: $!");

    $dir{$job} = $dir;
    $changes{$job} = $cf;
    $package{$job} = $package;
    $version{$job} = $version;

    # Preupload code for source package.
    preupload_hook('sourcepackage', [ basename($package), $version ]);

    p("[ Preparing job $job from $cf");

    # Scan the log file (iff any) for the files we have already put to the
    # host and the announcements already done.
    if (-f $log) {
        open my $fh_log, '<', $log or fatal("Cannot open $log: $!");
        while (my $entry = <$fh_log>) {
            chomp $entry;

            if ($entry =~ /^u .*\s(?:${host}|${fqdn})\s/) {
                push @done, $entry;
            } elsif ($entry =~ /^a /) {
                push @done, $entry;
            } elsif ($entry =~ /\s(?:${host}|${fqdn})\s/) {
                push @done, "u $entry";
            }
            next;
        }
        close $fh_log;
    }

    # If the dinstall_runs variable is set, we do not want the announcement
    # emails, because dinstall will attend to that.
    $nomail = 1 if $dinstall_runs;

    # Scan the changes file for architecture, distribution code and the files
    # avoid duplicate mail addressees.
    open my $fh_changes, '<', $cf or fatal("Cannot open $cf: $!");
    my ($field);
    while (<$fh_changes>) {
        chomp;
        if (/^changes:\s*/i) {
            $fields{changes}++;
            $field = undef;
            next;
        }
        if (/^architecture:\s+/i) {
            chomp($arch{$job} = "$'");
            $field = undef;
            next;
        }
        if (/^distribution:\s+/i) {
            foreach my $dist (split ' ', $') {
                foreach my $mail (@{$mail}) {
                    if ($dist =~ m/$mail->{match}/) {
                        $mailto{$mail->{to}} = $mail;
                    }
                }
                if ((defined $distblocklist and $dist =~ m/$distblocklist/) or
                    (defined $distallowlist and $dist !~ m/$distallowlist/)) {
                    fatal("distribution '$dist' not allowed");
                }
            }
            $field = undef;
            next;
        }
        if (/^(files|checksums-(?:sha1|sha256)):\s*$/i) {
            $field = lc $1;
            push @{$fields{$field}}, $' if $';
            next;
        }
        if (/^\s+/ and $field) {
            push @{$fields{$field}}, $' if $';
            next;
        };
        if (/^[\w.-]+:/) {
            $field = undef;
        }
    }
    foreach my $k (sort keys %mailto) {
        unless ($nomail) {
            p("\n  announce ($cf) to $k");
            if (any { /^a .*\s${k}\s/ } @done) {
                p(' already done');
            } else {
                $announce{$job}{$k} = $mailto{$k};
                p(' will be sent');
            }
        }
    }

    # Search for extra announcement files.
    if (announce_is_sent($job)) {
        my @announce_names = (
            "${package}",
            "${package}_${upstream}",
            defined $debian ? "${package}_${upstream}-${debian}" : (),
        );
        foreach my $announce_filename (@announce_names) {
            $announce_filename .= '.announce';
            if (-r $announce_filename) {
                push @extra, $announce_filename;
            }
        }
        if (@extra) {
            p(", as well as\n  ", join ', ', @extra);
            $extra{$job} = [ @extra ];
        }
    }

    my %checksums;
    foreach my $alg (qw(sha1 sha256)) {
        foreach (@{$fields{"checksums-$alg"}}) {
            chomp;
            my ($chksum, $size, $file) = split;

            $checksums{$file}{$alg} = $chksum;
            if (exists $checksums{$file}{size}
                and $checksums{$file}{size} != $size) {
                fatal("Size mismatch for file $file in digest $alg: $size != $checksums{$file}{size}");
            }
            $checksums{$file}{size} = $size;
        }
    }
    foreach (@{$fields{files}}) {
        chomp;
        my ($chksum, $size, undef, undef, $file) = split;

        $checksums{$file}{md5} = $chksum;
        if (exists $checksums{$file}{size}
            and $checksums{$file}{size} != $size) {
            fatal("Size mismatch for file $file in digest md5: $size != $checksums{$file}{size}");
        }
        $checksums{$file}{size} = $size;
    }
    close $fh_changes;
    unless (%checksums && $fields{changes}) {
        p(": not a changes file ]\n");
        next PACKAGE;
    }

    # Test the md5sums.
    foreach my $file (sort keys %checksums) {
        my $size = -s $file;

        p("\n $file");
        if ($checksums{$file}{size} != $size) {
            $keep or fatal("Size mismatch for $file on disk: $size != $checksums{$file}{size}");
            w("Size mismatch for $file, skipping $job\n");
            push @skipped, $cf;
            next PACKAGE;
        }
        p(', size ok');

        foreach my $alg (qw(md5 sha1 sha256)) {
            next unless $checksums{$file}{$alg};

            my $checksum;
            if (-r $file) {
                my $output = qx(${alg}sum $file);
                $checksum = (split q{ }, $output)[0];
            } else {
                print ": $!";
                $checksum = q{};
            }

            if ($checksums{$file}{$alg} ne $checksum) {
                my $algsum = uc($alg) . 'sum';
                $keep or fatal("$algsum mismatch for $file");
                w("$algsum mismatch for $file, skipping $job\n");
                push @skipped, $cf;
                next PACKAGE;
            }
            p(", ${alg}sum ok");
        }
        if (!$force && @done && any { /^u \Q${file}\E/ } @done) {
            p(", already done for $host");
        } else {
            push @files, $file;
        }
        next;
    }

    # The changes file itself.
    p("\n $cf ok");
    if (!$force && @done && any { /^u \Q${cf}\E/ } @done) {
        p(", already done for $host");
    } else {
        push @files, $cf;
    }

    if (@files) {
        $log{$job} = $log;
        $files{$job} = [ @files ];
    } else {
        $log{$job} = $log;
        announce_if_necessary($job);

        if (!$dry) {
            log_job($log{$job}, "s $changes{$job} $fqdn");
        } else {
            p("\n+ log successful upload\n");
        }
    }
    p(" ]\n");

    # Preupload code for all files and for '.deb'.
    foreach my $file (@files) {
        push @all_the_files, $file;

        preupload_hook('file', [ $file ]);

        if ($file =~ /\.deb$/) {
            push @all_the_debs, $file;
            my ($binary_package, $version, $garbage) = split /_/, $file;

            $binary_package = basename($binary_package);
            $all_packages{$binary_package} = $version;

            preupload_hook('package', [ $binary_package, $version ]);
            preupload_hook('deb', [ $file ]);
        }
    }
} continue {
    chdir $cwd or fatal("Cannot change directory back to $cwd: $!");
}

chdir $cwd or fatal("Cannot change directory to $cwd: $!");

if (@skipped) {
    w("skipped: @skipped\n");
}
if (not %files) {
    p("Nothing to upload\n");
    exit 0;
}

if ($method eq 'ftp') {
    if (!$dry) {
        $passwd = getpass() unless defined $passwd;
    } else {
        p("+ getpass()\n");
    }
    p("Uploading (ftp) to $host ($fqdn)\n");
    if (!$dry) {
        $ftp = ftp_open($fqdn, $login, $passwd);
        $ftp->cwd($incoming);
    } else {
        p("+ ftp_open($fqdn, $login, $passwd)\n");
        p("+ ftp::cwd($incoming\n");
    }
} elsif ($method eq 'http' || $method eq 'https') {
    if (defined $login and not defined $passwd) {
        if (!$dry) {
            $passwd = getpass();

            my $http_user = uri_escape_utf8($login);
            my $http_pass = uri_escape_utf8($passwd);
            $http_uri->userinfo("$http_user:$http_pass");
        } else {
            p("+ getpass()\n");
        }
    }

    p("Uploading ($method) to $host ($fqdn)\n");
    if (!$dry) {
        $http = HTTP::Tiny->new(
            agent => "dupload/$version",
            verify_SSL => 1,
        );
    } else {
        p("+ http_open()\n");
    }
} elsif ($method eq 'scp' || $method eq 'scpb') {
    p("Uploading ($method) to $host ($fqdn)\n");
} elsif ($method eq 'rsync') {
    p("Uploading (rsync) to $host ($fqdn)\n");
} elsif ($method eq 'copy') {
    p("Uploading (copy) to $host ($fqdn)\n");
} else {
    fatal("Unknown upload method ($method)");
}

JOB: foreach my $job (sort keys %files) {
    my @files = @{$files{$job}};
    my $mode;
    my @copiedfiles;

    my ($package, $version, $arch) = (split /_/, $job, 3);
    my ($upstream, $debian) = (split /-/, $version, 2);

    $incoming =~ s/_package_/$package/g;
    $incoming =~ s/_version_/$version/g;
    $incoming =~ s/_arch_/$arch/g;
    $incoming =~ s/_upstream_/$upstream/g;
    $incoming =~ s/_debian_/$debian/g;

    chdir $dir{$job} or fatal("Cannot change directory to $dir{$job}: $!");

    p("[ Uploading job $job");
    if (@files == 0) {
        p("\n nothing to do ]");
        next;
    }

    # For scpb and rsync only. A priori, the mode is right for every file.
    my $wrong_mode = 0;

    foreach my $file (@files) {
        my $size = -s $file;
        my $t;

        p(sprintf "\n $file %0.1f kB", $size / 1024);
        $t = time;

        if ($method eq 'ftp') {
            unless ($dry) {
                unless ($ftp->put($file, $file)) {
                    my $result = $ftp->message();
                    $ftp->delete($file);
                    fatal("Cannot upload $file: $result");
                }
            } else {
                p("\n+ ftp::put($file)");
            }
        } elsif ($method eq 'http' or $method eq 'https') {
            unless ($dry) {
                my $res = http_upload($http_uri, $file);
                unless ($res->{success}) {
                    $http->delete("$http_uri/$file");
                    fatal("Cannot upload $file: $res->{reason}");
                }
            } else {
                p("\n+ http::put($file)");
            }
        } elsif ($method eq 'scp') {
            $mode = (stat $file)[2] & 07777;
            method_run([ 'scp', '-p', @scp_options, $file, $ssh_target ]);

            # Small optimization.
            if ($dochmode && $mode != $filemode) {
                method_run([ 'ssh', @ssh_options, $fqdn,
                    'chmod', $filemode, "$incoming/$file" ]);
            }
        } elsif ($method eq 'scpb' or $method eq 'rsync') {
            push @copiedfiles, $file;
            $mode = (stat $file)[2] & 07777;
            # Small optimization.
            if ($dochmode && $mode != $filemode) {
                $wrong_mode = 1;
            }
        } elsif ($method eq 'copy') {
            $mode = (stat $file)[2] & 07777;

            unless ($dry) {
                copy($file, $incoming)
                    or fatal("Cannot copy $file to $incoming: $!");
                # Small optimization.
                if ($dochmode && $mode != $filemode) {
                    chmod $filemode, "$incoming/$file"
                        or fatal("Cannot change mode $filemode for $incoming/$file: $!");
                }
            } else {
                p("\n+ copy $file $incoming");
                if ($dochmode && $mode != $filemode) {
                    p("\n+ chmod $filemode $incoming/$file");
                }
            }
        }

        if ($dry or $batchmode) {
            $t = 1;
        } else {
            $t = time - $t;
        }

        if ($batchmode) {
            p(', uploading');
        }

        if ($queuedir) {
            p(', renaming');
            if ($method eq 'ftp') {
                unless ($dry) {
                    if (!$ftp->rename($file, "$queuedir/$file")) {
                        my $result = $ftp->message();
                        $ftp->delete($file);
                        fatal("Cannot rename $file -> $queuedir/$file: $result");
                    }
                } else {
                    p("\n+ ftp::rename($file, $queuedir/$file)");
                }
            } elsif ($method eq 'scp') {
                method_run([ 'ssh', @ssh_options, $fqdn,
                    'mv', "$incoming/$file", "$queuedir/$file" ]);
            } elsif ($method eq 'copy') {
                unless ($dry) {
                    move("$incoming/$file", "$queuedir/$file")
                        or fatal("Cannot move $file from $incoming to $queuedir: $!");
                } else {
                    p("\n+ move $incoming/$file $queuedir/$file");
                }
            }
        }

        unless ($batchmode) {
            p(', ok');

            # The batch methods do not produce the $t statistic.
            p(sprintf " (${t} s, %.2f kB/s)", $size / 1024 / ($t || 1))
                unless $nostats;

            unless ($dry) {
                log_job($log{$job}, "u $file $fqdn");
            } else {
                p("\n+ log to $log{$job}\n");
            }
        }
    }

    # And now the batch mode uploads.
    my $subcmd;

    if ($method eq 'scpb') {
        $subcmd .= "chmod $filemode @copiedfiles;" if $wrong_mode;

        p("\n");
        method_run([ 'scp', @scp_options, @copiedfiles, $ssh_target ],
            cleanup => sub { unlink $log{$job} },
        );
    } elsif ($method eq 'rsync') {
        my @rsync_opts;

        push @rsync_opts, qw(--partial);
        push @rsync_opts, qw(-Lxtze ssh);
        push @rsync_opts, '-v' if not $quiet;
        push @rsync_opts, "--chmod=F$filemode" if $wrong_mode;
        push @rsync_opts, @options;

        p("\n");
        method_run([ 'rsync', @rsync_opts, @copiedfiles, $ssh_target ],
            cleanup => sub { unlink $log{$job} },
        );
    }

    if ($batchmode) {
        if (defined $queuedir and length $queuedir > 0) {
            $subcmd .= "mv @copiedfiles $queuedir;";
        }
        if (defined $subcmd) {
            method_run([ 'ssh', @ssh_options, $fqdn,
                "cd $incoming;$subcmd" ]);
        }

        unless ($dry) {
            log_job($log{$job}, map { "u $_ $fqdn" } @copiedfiles);
        } else {
            p("\n+ log to $log{$job}\n");
        }
    }

    announce_if_necessary($job);
    unless ($dry) {
        log_job($log{$job}, "s $changes{$job} $fqdn");
    } else {
        p("\n+ log successful upload\n");
    }
    p(" ]\n");
} continue {
    chdir $cwd or fatal("Cannot change directory back to $cwd: $!");
}

chdir $cwd or fatal("Cannot change directory to $cwd: $!");

if ($method eq 'ftp') {
    unless ($dry) {
        $ftp->close();
    } else {
        p("\n+ ftp::close\n");
    }
}

# Postupload code for changes files.
unless ($dry) {
    foreach my $change (@changes) {
        my $job = basename($change, '.changes');

        postupload_hook('changes', [ $change ]);

        my $package = $package{$job};
        my $version = $version{$job};
        postupload_hook('sourcepackage', [ basename($package), $version ]);
    }

    foreach my $file (@all_the_files) {
        postupload_hook('file', [ $file ]);
    }

    foreach my $file (@all_the_debs) {
        postupload_hook('deb', [ $file ]);
    }

    foreach my $package (sort keys %all_packages) {
        postupload_hook('package', [ $package, $all_packages{$package} ]);
    }
}

postupload_hook('host', [ $host ]);

@skipped and w("skipped: @skipped\n");

exit 0;

### SUBS

sub announce_is_sent
{
    my $job = shift;

    return 0 if not $announce{$job} or $nomail;
    return 1;
}

# Prepare and possibly send the mail announcement.
sub announce_if_necessary
{
    my ($job) = @_;

    return if not announce_is_sent($job);

    my @to = sort keys %{$announce{$job}};
    my @cc = uniq sort map {
        $_->{cc}
    } grep {
        length $_->{cc}
    } values %{$announce{$job}};

    my $to = join q{, }, @to;
    my $cc = join q{, }, @cc;

    my @mta_cmd = ($mta, '-f');
    if ($visiblename) {
        push @mta_cmd, "$visibleuser\@$visiblename";
    } else {
        push @mta_cmd, $visibleuser;
    }
    if ($fullname) {
        push @mta_cmd, '-F';
        if ($config::no_parentheses_to_fullname) {
            push @mta_cmd, $fullname;
        } else {
            push @mta_cmd, "($fullname)";
        }
    }
    push @mta_cmd, @to;

    my $msg = "\n announcing to $to";
    if ($cc) {
        push @mta_cmd, $cc;
        $msg .= " and $cc";
    }
    p($msg);

    my $fh_mail;
    if (not $dry or $mailonly) {
        open $fh_mail, '|-', @mta_cmd or fatal("Cannot pipe to $mta $!");
    } else {
        p("\n+ announce to $to using command '@mta_cmd'\n");
        open $fh_mail, '>&', *STDOUT or fatal('Cannot redirect to stdout');
    }

    print { $fh_mail } <<"MAIL";
X-dupload: $version
To: $to
MAIL
    $cc and print { $fh_mail } <<"MAIL";
Cc: $cc
MAIL
    $noarchive and print { $fh_mail } <<'MAIL';
X-No-Archive: yes
MAIL

    print { $fh_mail } <<"MAIL";
Subject: Uploaded $package{$job} $version{$job} ($arch{$job}) to $host

MAIL

    my $line;

    foreach my $announce (@{$extra{$job}}) {
        my $fh_announce;
        if (not open $fh_announce, '<', $announce) {
            w("Cannot open extra announce $announce: $!\n");
            next;
        }
        p(" ($announce");
        while ($line = <$fh_announce>) {
            print { $fh_mail } $line;
        }
        close $fh_announce;
        p(' ok)');
    }

    open my $fh_changes, '<', $changes{$job} or fatal("Cannot open $changes{$job} $!");
    while ($line = <$fh_changes>) {
        print { $fh_mail } $line;
    }
    close $fh_changes;

    close $fh_mail;
    if ($?) {
        p(', failed');
    } else {
        p(', ok');
    }

    if (!$dry) {
        log_job($log{$job}, "a $changes{$job} @to");
    } else {
        p("\n+ log announcement\n");
    }

    return;
}

# Open the FTP connection.
sub ftp_open
{
    my ($remote, $user, $pass) = @_;
    my %ftp_opts;

    if ($user =~ /@/ or $passive) {
        # It may seems complicated, but it is to be sure that the environment
        # variable FTP_PASSIVE works (which needs no Passive argument).
        $ftp_opts{Passive} = 1;
        p("+ FTP passive mode selected\n");
    }

    my $ftp = Net::FTP->new($remote, %ftp_opts);
    if (!$ftp) {
        fatal($@);
    }
    $ftp->debug($debug);

    $ftp->login($user, $pass)
        or fatal("Login as $user failed");
    $ftp->type('I')
        or fatal('Cannot set binary type');
    # Set the socket keep-alive for the control connection to avoid it being
    # closed during long data transfers on the data connection.
    $ftp->setsockopt(SOL_SOCKET, SO_KEEPALIVE, 1);

    return $ftp;
}

sub http_upload
{
    my ($uri, $file) = @_;

    open my $fh, '<', $file or fatal("cannot open file $file");

    my $http_content_feeder = sub {
        my $buf;
        my $rc = read $fh, $buf, 4096;
        fatal("Cannot read  $file: $!") unless defined $rc;
        return if $rc == 0;
        return $buf;
    };

    my $res = $http->put("$uri/$file", {
        headers => {
            'content-length' => (stat $fh)[7],
        },
        content => $http_content_feeder,
    });

    close $fh;

    return $res;
}

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

    printf "%-14s: %s\n", $field, $value // '';

    return;
}

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

    printf "%-30s: %s\n", $field, $value // '';

    return;
}

sub info_hooks
{
    my ($name, $host, $global) = @_;

    foreach my $hook_type (@hook_types) {
        my $hooks = $host->{$hook_type} // $global->{$hook_type};
        if (ref $hooks ne 'ARRAY') {
            fatal("$name $hook_type is not an array");
        }
        foreach my $hook (@{$hooks}) {
            info_hook_field("hook $name $hook_type", $hook, 30);
        }
    }

    return;
}

# Display known host information.
sub info
{
    my ($host) = @_;

    foreach my $nick ($host || sort keys %config::cfg) {
        my $r = $config::cfg{$nick};

        info_field('nick name', $nick);
        info_field('real name', $r->{fqdn});
        info_field('method', $r->{method} // 'ftp');
        info_field('login', $r->{login});
        info_field('incoming', $r->{incoming});
        info_field('queuedir', $r->{queuedir});
        foreach my $keyring (@{$r->{keyrings}}) {
            info_field('keyrings', $keyring);
        }
        info_field('dist allowlist', $r->{distallowlist});
        info_field('dist blocklist', $r->{distblocklist});
        foreach my $mail (@{$r->{mail}}) {
            info_field("mail to ($mail->{match})", $mail->{to});
            info_field("mail cc ($mail->{match})", $mail->{cc});
        }
        info_field('passive FTP', $r->{passive});
        info_field('dinstall runs', $r->{dinstall_runs});
        info_field('archive mail', $r->{archive});
        info_hooks('preupload', $r->{preupload}, \%config::preupload);
        info_hooks('postupload', $r->{postupload}, \%config::postupload);
        print "\n";
    }

    return;
}

# Read the dupload configuration files.
sub configure
{
    my @conffiles = @_;

    my @read = ();
    foreach my $file (@conffiles) {
        stat $file;

        -r _ or next;
        -s _ or next;
        do $file or fatal("$@");
        push @configfiles_loaded, $file;
    }

    return;
}

sub getpass_cmd
{
    if (not defined $passwd_cmd) {
        state $tool = find_command('secret-tool');

        if (length $tool) {
            $passwd_cmd = "secret-tool lookup host $fqdn user $login service dupload";
        }
    }
    return unless length $passwd_cmd;

    my $pass = qx($passwd_cmd);
    chomp $pass;
    if ($?) {
        w("cannot fetch password for $login\@$fqdn from '$passwd_cmd': $?\n");
        return;
    } elsif (length $pass == 0) {
        w("unknown password for $login\@$fqdn from '$passwd_cmd'\n");
        return;
    }

    return $pass;
}

sub getpass_prompt
{
    system 'stty -echo cbreak </dev/tty';
    $? and fatal('stty');
    print "\a${login}\@${fqdn}'s $method account password: ";
    my $pass = <STDIN>;
    chomp $pass;
    print "\n";
    system 'stty echo -cbreak </dev/tty';
    $? and fatal('stty');
    return $pass;
}

# Fetch or prompt for the login password.
sub getpass
{
    return getpass_cmd() // getpass_prompt();
}

{

my $nl;

# Print to STDOUT if !$quiet.
sub p
{
    return if $quiet;
    $nl = $_[-1] =~ /\n$/;
    print { *STDOUT } @_;
    return;
}

# Warn to STDOUT if !$quiet, or to STDERR if $quiet.
sub w
{
    if ($quiet) {
        print { *STDERR } "$progname: warning: ", @_;
    } else {
        $nl = $_[-1] =~ /\n$/;
        unshift @_, "$progname: warning: ";
        unshift @_, "\n" if !$nl;
        print { *STDOUT } @_;
    }
    return;
}

}

# Log events for a job, by appending the localtime and a new line to each
# passed line to log.
sub log_job
{
    my ($logfile, @logdata) = @_;

    my $fh;
    if (not open $fh, '>>', $logfile) {
        w("cannot open logfile $logfile: $!\n");
        return;
    }
    foreach my $line (@logdata) {
        my $timestamp = $ENV{DUPLOAD_LOG_TIMESTAMP} || localtime;
        print { $fh } "$line $timestamp\n";
    }
    close $fh;

    return;
}

# Emit a fatal error and die.
sub fatal
{
    print { *STDERR } "\n";
    die "$progname: error: @_\n";
}

sub method_run
{
    my ($command, %opts) = @_;

    unless ($dry) {
        system { $command->[0] } @{$command};
        if (exists $opts{cleanup}) {
            $opts{cleanup}->();
        }
        fatal("@{$command} failed") if $?;
    } else {
        p("\n+ @{$command}");
    }

    return;
}

sub can_skip_hook
{
    my $hook = shift;

    my @cmd = split ' ', $hook;
    my $cmd_name = basename($cmd[0]);
    if (exists $skip_hook{$cmd[0]} or exists $skip_hook{$cmd_name}) {
        return 1;
    }

    return 0;
}

sub run_hook
{
    my ($name, $command, $args) = @_;
    my (@args) = @{$args};
    my ($result);

    foreach my $i (1 .. @args) {
        my $arg = $args[$i - 1] // q{};

        # Substitute %1 by the first argument, etc.
        $command =~ s/\%$i/$arg/g;
    }

    local $ENV{DUPLOAD_HOOK} = $name;
    local $ENV{DUPLOAD_HOST} = $host;
    local $ENV{DUPLOAD_METHOD} = $method;
    local $ENV{DUPLOAD_FQDN} = $fqdn;
    local $ENV{DUPLOAD_LOGIN} = $login;
    local $ENV{DUPLOAD_INCOMING} = $incoming;
    local $ENV{DUPLOAD_QUEUEDIR} = $queuedir;
    local $ENV{DUPLOAD_SSH_OPTIONS} = "@options";
    local $ENV{DUPLOAD_FTP_PASSIVE} = $passive;
    local $ENV{DUPLOAD_KEYRINGS} = "@keyrings";

    system "$command";
    $result = $? >> 8;
    return !$result;
}

sub preupload_hook
{
    my ($name, $args) = @_;

    return if scalar @{$preupload{$name}} == 0;

    foreach my $hook (@{$preupload{$name}}) {
        if (can_skip_hook($hook)) {
            w("skipping pre-upload $name hook $hook\n");
            next;
        }

        if (not run_hook($name, $hook, $args)) {
            fatal("Pre-upload \'$hook\' failed for @{$args}");
        }
    }

    return;
}

sub postupload_hook
{
    my ($name, $args) = @_;

    return if scalar @{$postupload{$name}} == 0;

    foreach my $hook (@{$postupload{$name}}) {
        if (can_skip_hook($hook)) {
            w("skipping post-upload $name hook $hook\n");
            next;
        }

        if (not run_hook($name, $hook, $args)) {
            fatal("Post-upload \'$hook\' failed for @{$args}");
        }
    }

    return;
}

# vim:set sts=4 sw=4 et:
