X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=145fa9bb044be29d383f8849f7766ff0a72f2eab;hb=193cfa37a544a2c44f9252b83da54ca1af01c01f;hp=f0a9ead7e5a1c08db52ad693bbfe2c3aafddc2cd;hpb=14032a211e887f6d69408ba15f4c948f0b1c2e1d;p=dgit.git diff --git a/dgit b/dgit index f0a9ead7..145fa9bb 100755 --- a/dgit +++ b/dgit @@ -2,8 +2,9 @@ # dgit # Integration between git and Debian-style archives # -# Copyright (C)2013-2018 Ian Jackson -# Copyright (C)2017-2018 Sean Whitton +# Copyright (C)2013-2019 Ian Jackson +# Copyright (C)2017-2019 Sean Whitton +# Copyright (C)2019 Matthew Vernon / Genome Research Limited # # 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 @@ -29,12 +30,13 @@ setup_sigwarn(); use IO::Handle; use Data::Dumper; -use LWP::UserAgent; +use WWW::Curl::Easy; use Dpkg::Control::Hash; use File::Path; use File::Spec; use File::Temp qw(tempdir); use File::Basename; +use File::Copy (); use Dpkg::Version; use Dpkg::Compression; use Dpkg::Compression::Process; @@ -45,6 +47,7 @@ use Digest::SHA; use Digest::MD5; use List::MoreUtils qw(pairwise); use Text::Glob qw(match_glob); +use Text::CSV; use Fcntl qw(:DEFAULT :flock); use Carp; @@ -53,7 +56,9 @@ use Debian::Dgit; our $our_version = 'UNRELEASED'; ###substituted### our $absurdity = undef; ###substituted### -our @rpushprotovsn_support = qw(4 5); # 5 drops tag format specification +$SIG{INT} = 'DEFAULT'; # work around #932841 + +our @rpushprotovsn_support = qw(6 5 4); # Reverse order! our $protovsn; our $cmd; @@ -82,7 +87,7 @@ our $quilt_mode; our $quilt_upstream_commitish; our $quilt_upstream_commitish_used; our $quilt_upstream_commitish_message; -our $quilt_options_re = 'gbp|dpm|baredebian(?:\+tarball)?'; +our $quilt_options_re = 'gbp|dpm|baredebian(?:\+tarball|\+git)?'; our $quilt_modes_re = "linear|smash|auto|nofix|nocheck|unapplied|$quilt_options_re"; our $splitview_mode; our $splitview_modes_re = qr{auto|always|never}; @@ -98,13 +103,13 @@ our %forceopts = map { $_=>0 } qw(unrepresentable unsupported-source-format dsc-changes-mismatch changes-origs-exactly uploading-binaries uploading-source-only + reusing-version import-gitapply-absurd import-gitapply-no-absurd import-dsc-with-dgit-field); our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)"); -our $suite_re = '[-+.0-9a-z]+'; our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )? | (?: git | git-ff ) (?: ,always )? | check (?: ,ignores )? @@ -117,7 +122,6 @@ our $rewritemap = 'dgit-rewrite/map'; our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git); -our (@git) = qw(git); our (@dget) = qw(dget); our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L)); our (@dput) = qw(dput); @@ -300,6 +304,10 @@ sub deliberately_not_fast_forward () { sub quiltmode_splitting () { $quilt_mode =~ m/gbp|dpm|unapplied|baredebian/; } +sub format_quiltmode_splitting ($) { + my ($format) = @_; + return madformat_wantfixup($format) && quiltmode_splitting(); +} sub do_split_brain () { !!($do_split_brain // confess) } @@ -469,6 +477,7 @@ sub branch_is_gdr ($) { # > param head DGIT-VIEW-HEAD # > param csuite SUITE # > param tagformat new # $protovsn == 4 +# > param splitbrain 0|1 # $protovsn >= 6 # > param maint-view MAINT-VIEW-HEAD # # > param buildinfo-filename P_V_X.buildinfo # zero or more times @@ -633,20 +642,6 @@ sub progress { our $ua; -sub url_get { - if (!$ua) { - $ua = LWP::UserAgent->new(); - $ua->env_proxy; - } - my $what = $_[$#_]; - progress "downloading $what..."; - my $r = $ua->get(@_) or confess "$!"; - return undef if $r->code == 404; - $r->is_success or fail f_ "failed to fetch %s: %s", - $what, $r->status_line; - return $r->decoded_content(charset => 'none'); -} - our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn); sub act_local () { return $dryrun_level <= 1; } @@ -779,6 +774,12 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/', 'dgit-distro.ubuntu.git-check' => 'false', 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu', + 'dgit-distro.ubuntucloud.git-check' => 'false', + 'dgit-distro.ubuntucloud.nominal-distro' => 'ubuntu', + 'dgit-distro.ubuntucloud.archive-query' => 'aptget:', + 'dgit-distro.ubuntucloud.mirror' => 'http://ubuntu-cloud.archive.canonical.com/ubuntu', + 'dgit-distro.ubuntucloud.aptget-suite-map' => 's#^([^-]+):([^:]+)$#${1}-updates/$2#; s#^(.+)-(.+):(.+)#$1-$2/$3#;', + 'dgit-distro.ubuntucloud.aptget-suite-rmap' => 's#/(.+)$#-$1#', 'dgit-distro.test-dummy.ssh' => "$td/ssh", 'dgit-distro.test-dummy.username' => "alice", 'dgit-distro.test-dummy.git-check' => "ssh-cmd", @@ -869,6 +870,22 @@ sub access_basedistro__noalias () { return $kl->{$k}; } } + foreach my $csvf () { + my $csv_distro = + $csvf =~ m{/(\w+)\.csv$} ? $1 : do { + printdebug "skipping $csvf\n"; + next; + }; + my $csv = Text::CSV->new({ binary => 1, auto_diag => 2 }) or die; + my $fh = new IO::File $csvf, "<:encoding(utf8)" + or die "open $csvf: $!"; + while (my $cols = $csv->getline($fh)) { + next unless $cols->[2] eq $isuite; + return $csv_distro; + } + die "$csvf $!" if $fh->error; + close $fh; + } return cfg("dgit.default.distro"); } } @@ -973,9 +990,8 @@ sub notpushing () { parseopts_late_defaults(); } -sub determine_whether_split_brain () { - my ($format,) = get_source_format(); - +sub determine_whether_split_brain ($) { + my ($format) = @_; { local $access_forpush; default_from_access_cfg(\$splitview_mode, 'split-view', 'auto', @@ -985,7 +1001,7 @@ sub determine_whether_split_brain () { printdebug "format $format, quilt mode $quilt_mode\n"; - if (madformat_wantfixup($format) && quiltmode_splitting()) { + if (format_quiltmode_splitting $format) { $splitview_mode ne 'never' or fail f_ "dgit: quilt mode \`%s' (for format \`%s')". " implies split view, but split-view set to \`%s'", @@ -993,8 +1009,6 @@ sub determine_whether_split_brain () { $do_split_brain = 1; } $do_split_brain //= 0; - - return ($format); } sub supplementary_message ($) { @@ -1183,56 +1197,75 @@ sub cfg_apply_map ($$$) { $$varref = $_; } -#---------- `ftpmasterapi' archive query method (nascent) ---------- +sub url_fetch ($;@) { + my ($url, %xopts) = @_; + # Ok404 => 1 means give undef for 404 + # AccessBase => 'archive-query' (eg) + # CurlOpts => { key => value } -sub archive_api_query_cmd ($) { - my ($subpath) = @_; - my @cmd = (@curl, qw(-sS)); - my $url = access_cfg('archive-query-url'); - if ($url =~ m#^https://([-.0-9a-z]+)/#) { - my $host = $1; - my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //''; - foreach my $key (split /\:/, $keys) { - $key =~ s/\%HOST\%/$host/g; - if (!stat $key) { - fail "for $url: stat $key: $!" unless $!==ENOENT; - next; - } - fail f_ "config requested specific TLS key but do not know". - " how to get curl to use exactly that EE key (%s)", - $key; -# push @cmd, "--cacert", $key, "--capath", "/dev/enoent"; -# # Sadly the above line does not work because of changes -# # to gnutls. The real fix for #790093 may involve -# # new curl options. - last; + my $curl = WWW::Curl::Easy->new; + my $setopt = sub { + my ($k,$v) = @_; + my $x = $curl->setopt($k, $v); + confess "$k $v ".$curl->strerror($x)." ?" if $x; + }; + + my $response_body = ''; + $setopt->(CURLOPT_FOLLOWLOCATION, 1); + $setopt->(CURLOPT_REDIR_PROTOCOLS, CURLPROTO_HTTPS|CURLPROTO_HTTP); + $setopt->(CURLOPT_URL, $url); + $setopt->(CURLOPT_NOSIGNAL, 1); + $setopt->(CURLOPT_WRITEDATA, \$response_body); + + my $xcurlopts = $xopts{CurlOpts} // { }; + keys %$xcurlopts; + while (my ($k,$v) = each %$xcurlopts) { $setopt->($k,$v); } + + if ($xopts{AccessBase} && $url =~ m#^https://([-.0-9a-z]+)/#) { + foreach my $k ("$xopts{AccessBase}-tls-key", + "$xopts{AccessBase}-tls-curl-ca-args") { + fail "config option $k is obsolete and no longer supported" + if defined access_cfg($k, 'RETURN-UNDEF'); } - # Fixing #790093 properly will involve providing a value - # for this on clients. - my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF'); - push @cmd, split / /, $kargs if defined $kargs; } - push @cmd, $url.$subpath; - return @cmd; + + printdebug "query: fetching $url...\n"; + + local $SIG{PIPE} = 'IGNORE'; + + my $x = $curl->perform(); + fail f_ "fetch of %s failed (%s): %s", + $url, $curl->strerror($x), $curl->errbuf + if $x; + + my $code = $curl->getinfo(CURLINFO_HTTP_CODE); + if ($code eq '404' && $xopts{Ok404}) { return undef; } + + fail f_ "fetch of %s gave HTTP code %s", $url, $code + unless $url =~ m#^file://# or $code =~ m/^2/; + + confess unless defined $response_body; + return $response_body; +} + +#---------- `ftpmasterapi' archive query method (nascent) ---------- + +sub api_query_raw ($;$) { + my ($subpath, $ok404) = @_; + my $url = access_cfg('archive-query-url'); + $url .= $subpath; + return url_fetch $url, + Ok404 => $ok404, + AccessBase => 'archive-query'; } sub api_query ($$;$) { - use JSON; my ($data, $subpath, $ok404) = @_; + use JSON; badcfg __ "ftpmasterapi archive query method takes no data part" if length $data; - my @cmd = archive_api_query_cmd($subpath); - my $url = $cmd[$#cmd]; - push @cmd, qw(-w %{http_code}); - my $json = cmdoutput @cmd; - unless ($json =~ s/\d+\d+\d$//) { - failedcmd_report_cmd undef, @cmd; - fail __ "curl failed to print 3-digit HTTP code"; - } - my $code = $&; - return undef if $code eq '404' && $ok404; - fail f_ "fetch of %s gave HTTP code %s", $url, $code - unless $url =~ m#^file://# or $code =~ m/^2/; + my $json = api_query_raw $subpath, $ok404; + return undef unless defined $json; return decode_json($json); } @@ -1434,11 +1467,11 @@ sub canonicalise_suite_aptget { my $val = $release->{$name}; if (defined $val) { printdebug "release file $name: $val\n"; + cfg_apply_map(\$val, 'suite rmap', + access_cfg('aptget-suite-rmap', 'RETURN-UNDEF')); $val =~ m/^$suite_re$/o or fail f_ "Release file (%s) specifies intolerable %s", $aptget_releasefile, $name; - cfg_apply_map(\$val, 'suite rmap', - access_cfg('aptget-suite-rmap', 'RETURN-UNDEF')); return $val } } @@ -1723,7 +1756,7 @@ sub get_archive_dsc () { foreach my $vinfo (@vsns) { my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo; $dscurl = $vsn_dscurl; - $dscdata = url_get($dscurl); + $dscdata = url_fetch($dscurl, Ok404 => 1 ); if (!$dscdata) { $skew_warning_vsn = $vsn if !defined $skew_warning_vsn; next; @@ -1777,22 +1810,13 @@ sub check_for_git () { my $suffix = access_cfg('git-check-suffix','git-suffix', 'RETURN-UNDEF') // '.git'; my $url = "$prefix/$package$suffix"; - my @cmd = (@curl, qw(-sS -I), $url); - my $result = cmdoutput @cmd; - $result =~ s/^\S+ 200 .*\n\r?\n//; - # curl -sS -I with https_proxy prints - # HTTP/1.0 200 Connection established - $result =~ m/^\S+ (404|200) /s or - fail +(__ "unexpected results from git check query - "). - Dumper($prefix, $result); - my $code = $1; - if ($code eq '404') { - return 0; - } elsif ($code eq '200') { - return 1; - } else { - die; - } + my $result = url_fetch $url, + CurlOpts => { CURLOPT_NOBODY() => 1 }, + Ok404 => 1, + AccessBase => 'git-check'; + $result = defined $result; + printdebug "dgit-repos check_for_git => $result.\n"; + return $result; } elsif ($how eq 'true') { return 1; } elsif ($how eq 'false') { @@ -1827,7 +1851,7 @@ sub prep_ud () { } sub mktree_in_ud_here () { - playtree_setup $gitcfgs{local}; + playtree_setup(); } sub git_write_tree () { @@ -2011,7 +2035,7 @@ sub test_source_only_changes ($) { foreach my $l (split /\n/, getfield $changes, 'Files') { $l =~ m/\S+$/ or next; # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages - unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) { + unless ($& =~ m/(?:\.dsc|\.diff\.gz|$tarball_f_ext_re|_source\.buildinfo)$/) { print f_ "purportedly source-only changes polluted by %s\n", $&; return 0; } @@ -2456,7 +2480,8 @@ sub import_tarball_commits ($$) { foreach my $tt (@$tartrees) { printdebug "import tartree $tt->{F} $tt->{Tree}\n"; - my $mbody = f_ "Import %s", $tt->{F}; + # untranslated so that different people's imports are identical + my $mbody = sprintf "Import %s", $tt->{F}; $tt->{Commit} = hash_commit_text($tt->{Orig} ? <{Tree} author $r1authline @@ -2635,6 +2660,8 @@ END chomp $@; progress "warning: $@"; $path = "$absurdity:$path"; + open T, ">../../absurd-apply-warnings" or die $!; + close T or die $!; progress f_ "%s: trying slow absurd-git-apply...", $us; rename "../../gbp-pq-output","../../gbp-pq-output.0" or $!==ENOENT @@ -2669,6 +2696,11 @@ gbp-pq import and dpkg-source disagree! dpkg-source --before-build gave tree %s END $rawimport_hash = $gapplied; + + if ($use_absurd) { + File::Copy::copy("../../absurd-apply-warnings", \*STDERR) + or die $!; + } }; last unless $@; } @@ -2694,7 +2726,10 @@ END if ($vcmp < 0) { @output = ($rawimport_mergeinput, $lastpush_mergeinput, { ReverseParents => 1, - Message => (f_ < (sprintf < 0) { @@ -3573,7 +3608,7 @@ sub is_gitattrs_setup () { # 0: there is a dgit-defuse-attrs but it needs fixing # undef: there is none my $gai = open_main_gitattrs(); - return 0 unless $gai; + return undef unless $gai; while (<$gai>) { next unless m{$gitattrs_ourmacro_re}; return 1 if m{\s-working-tree-encoding\s}; @@ -3840,6 +3875,16 @@ END printdone f_ "ready for work in %s", $dstdir; } +sub vcs_git_url_of_ctrl ($) { + my ($ctrl) = @_; + my $vcsgiturl = $ctrl->{'Vcs-Git'}; + if (length $vcsgiturl) { + $vcsgiturl =~ s/\s+-b\s+\S+//g; + $vcsgiturl =~ s/\s+\[[^][]*\]//g; + } + return $vcsgiturl; +} + sub clone ($) { # in multisuite, returns twice! # once in parent after first suite fetched, @@ -3871,21 +3916,15 @@ sub clone ($) { record_maindir(); setup_new_tree(); clone_set_head(); - my $giturl = access_giturl(1); - if (defined $giturl) { - runcmd @git, qw(remote add), 'origin', $giturl; - } if ($hasgit) { progress __ "fetching existing git history"; git_fetch_us(); - runcmd_ordryrun_local @git, qw(fetch origin); } else { progress __ "starting new git history"; } fetch_from_archive() or no_such_package; - my $vcsgiturl = $dsc->{'Vcs-Git'}; + my $vcsgiturl = vcs_git_url_of_ctrl $dsc; if (length $vcsgiturl) { - $vcsgiturl =~ s/\s+-b\s+\S+//g; runcmd @git, qw(remote add vcs-git), $vcsgiturl; } clone_finish($dstdir); @@ -4021,6 +4060,7 @@ sub get_source_format () { } $_ = ; F->error and confess "$!"; + close F; chomp; return ($_, \%options); } @@ -4353,11 +4393,11 @@ sub push_mktags ($$ $$ $) { my $cversion = getfield $clogp, 'Version'; my $clogsuite = getfield $clogp, 'Distribution'; + my $format = getfield $dsc, 'Format'; # We make the git tag by hand because (a) that makes it easier # to control the "tagger" (b) we can do remote signing my $authline = clogp_authline $clogp; - my $delibs = join(" ", "",@deliberatelies); my $mktag = sub { my ($tw) = @_; @@ -4373,22 +4413,33 @@ tag $tag tagger $authline END + + my @dtxinfo = @deliberatelies; + unshift @dtxinfo, "--quilt=$quilt_mode" if madformat($format); + unshift @dtxinfo, do_split_brain() ? "split" : "no-split" + # rpush protocol 5 and earlier don't tell us + unless $we_are_initiator && $protovsn < 6; + my $dtxinfo = join(" ", "",@dtxinfo); + my $tag_metadata = <{View} eq 'dgit') { - print TO f_ <{View} eq 'maint') { - print TO f_ <= 6) { + determine_whether_split_brain getfield $dsc, 'Format'; + $do_split_brain eq ($i_param{'splitbrain'} // '') + or badproto \*RO, + "split brain mismatch, $do_split_brain != $i_param{'split_brain'}"; + printdebug "rpush split brain $do_split_brain\n"; + } + } my @localpaths = i_method "i_want", $keyword; printdebug "[[ $keyword @localpaths\n"; @@ -5192,8 +5271,6 @@ sub i_resp_want ($) { print RI "files-end\n" or confess "$!"; } -our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos); - sub i_localname_parsed_changelog { return "remote-changelog.822"; } @@ -5261,7 +5338,7 @@ sub i_want_signed_tag { die unless $i_param{'csuite'} =~ m/^$suite_re$/; $csuite = $&; - push_parse_dsc $i_dscfn, 'remote dsc', $i_version; + defined $dsc or badproto \*RO, "dsc (before parsed-changelog)"; my @tagwants = push_tagwants $i_version, $head, $maintview, "tag"; @@ -6554,17 +6631,21 @@ sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage sub build_or_push_prep_early () { our $build_or_push_prep_early_done //= 0; return if $build_or_push_prep_early_done++; - badusage f_ "-p is not allowed with dgit %s", $subcommand - if defined $package; my $clogp = parsechangelog(); $isuite = getfield $clogp, 'Distribution'; - $package = getfield $clogp, 'Source'; + my $gotpackage = getfield $clogp, 'Source'; $version = getfield $clogp, 'Version'; + $package //= $gotpackage; + if ($package ne $gotpackage) { + fail f_ "-p specified package %s, but changelog says %s", + $package, $gotpackage; + } $dscfn = dscfn($version); } sub build_or_push_prep_modes () { - my ($format,) = determine_whether_split_brain(); + my ($format) = get_source_format(); + determine_whether_split_brain($format); fail __ "dgit: --include-dirty is not supported with split view". " (including with view-splitting quilt modes)" @@ -6622,6 +6703,31 @@ sub build_prep ($) { } } +sub maybe_warn_opt_confusion ($$$) { + my ($subcommand, $willrun, $optsref) = @_; + foreach (@$optsref) { + if (m/^(?: --dry-run $ + | --damp-run $ + | --clean= | -w[gcnd] + | --(?:include|ignore)-dirty$ + | --quilt= | --gbp$ | --dpm$ | --baredebian + | --split-view= + | --build-products-dir= + )/x) { + print STDERR f_ <",@cmd; - exec @cmd or fail f_ "exec curl: %s\n", $!; + my $json = api_query_raw $subpath; + print $json or die "$!"; } sub repos_server_url () { @@ -7567,6 +7675,9 @@ sub parseopts () { f_ "%s: warning: ignoring unknown force option %s\n", $us, $_; $_=''; + } elsif (m/^--for-push$/s) { + push @ropts, $_; + $access_forpush = 1; } elsif (m/^--config-lookup-explode=(.+)$/s) { # undocumented, for testing push @ropts, $_; @@ -7712,6 +7823,7 @@ sub parseopts_late_defaults () { or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode; $quilt_mode = $1; } + $quilt_mode =~ s/^(baredebian)\+git$/$1/; foreach my $moc (@modeopt_cfgs) { local $access_forpush;