diff options
Diffstat (limited to 'perl/lib/Nix/GeneratePatches.pm')
| -rw-r--r-- | perl/lib/Nix/GeneratePatches.pm | 340 |
1 files changed, 0 insertions, 340 deletions
diff --git a/perl/lib/Nix/GeneratePatches.pm b/perl/lib/Nix/GeneratePatches.pm deleted file mode 100644 index 612c8a3a15ba..000000000000 --- a/perl/lib/Nix/GeneratePatches.pm +++ /dev/null @@ -1,340 +0,0 @@ -package Nix::GeneratePatches; - -use strict; -use File::Temp qw(tempdir); -use File::stat; -use Nix::Config; -use Nix::Manifest; - -our @ISA = qw(Exporter); -our @EXPORT = qw(generatePatches propagatePatches copyPatches); - - -# Some patch generations options. - -# Max size of NAR archives to generate patches for. -my $maxNarSize = $ENV{"NIX_MAX_NAR_SIZE"}; -$maxNarSize = 160 * 1024 * 1024 if !defined $maxNarSize; - -# If patch is bigger than this fraction of full archive, reject. -my $maxPatchFraction = $ENV{"NIX_PATCH_FRACTION"}; -$maxPatchFraction = 0.60 if !defined $maxPatchFraction; - -my $timeLimit = $ENV{"NIX_BSDIFF_TIME_LIMIT"}; -$timeLimit = 180 if !defined $timeLimit; - -my $hashAlgo = "sha256"; - - -sub findOutputPaths { - my $narFiles = shift; - - my %outPaths; - - foreach my $p (keys %{$narFiles}) { - - # Ignore derivations. - next if ($p =~ /\.drv$/); - - # Ignore builders (too much ambiguity -- they're all called - # `builder.sh'). - next if ($p =~ /\.sh$/); - next if ($p =~ /\.patch$/); - - # Don't bother including tar files etc. - next if ($p =~ /\.tar$/ || $p =~ /\.tar\.(gz|bz2|Z|lzma|xz)$/ || $p =~ /\.zip$/ || $p =~ /\.bin$/ || $p =~ /\.tgz$/ || $p =~ /\.rpm$/ || $p =~ /cvs-export$/ || $p =~ /fetchhg$/); - - $outPaths{$p} = 1; - } - - return %outPaths; -} - - -sub getNameVersion { - my $p = shift; - $p =~ /\/[0-9a-z]+((?:-[a-zA-Z][^\/-]*)+)([^\/]*)$/; - my $name = $1; - my $version = $2; - return undef unless defined $name && defined $version; - $name =~ s/^-//; - $version =~ s/^-//; - return ($name, $version); -} - - -# A quick hack to get a measure of the `distance' between two -# versions: it's just the position of the first character that differs -# (or 999 if they are the same). -sub versionDiff { - my $s = shift; - my $t = shift; - my $i; - return 999 if $s eq $t; - for ($i = 0; $i < length $s; $i++) { - return $i if $i >= length $t or - substr($s, $i, 1) ne substr($t, $i, 1); - } - return $i; -} - - -sub getNarBz2 { - my $narPath = shift; - my $narFiles = shift; - my $storePath = shift; - - my $narFileList = $$narFiles{$storePath}; - die "missing path $storePath" unless defined $narFileList; - - my $narFile = @{$narFileList}[0]; - die unless defined $narFile; - - $narFile->{url} =~ /\/([^\/]+)$/; - die unless defined $1; - return "$narPath/$1"; -} - - -sub containsPatch { - my $patches = shift; - my $storePath = shift; - my $basePath = shift; - my $patchList = $$patches{$storePath}; - return 0 if !defined $patchList; - my $found = 0; - foreach my $patch (@{$patchList}) { - # !!! baseHash might differ - return 1 if $patch->{basePath} eq $basePath; - } - return 0; -} - - -sub generatePatches { - my ($srcNarFiles, $dstNarFiles, $srcPatches, $dstPatches, $narPath, $patchesPath, $patchesURL, $tmpDir) = @_; - - my %srcOutPaths = findOutputPaths $srcNarFiles; - my %dstOutPaths = findOutputPaths $dstNarFiles; - - # For each output path in the destination, see if we need to / can - # create a patch. - - print STDERR "creating patches...\n"; - - foreach my $p (keys %dstOutPaths) { - - # If exactly the same path already exists in the source, skip it. - next if defined $srcOutPaths{$p}; - - print " $p\n"; - - # If not, then we should find the paths in the source that are - # `most' likely to be present on a system that wants to - # install this path. - - (my $name, my $version) = getNameVersion $p; - next unless defined $name && defined $version; - - my @closest = (); - my $closestVersion; - my $minDist = -1; # actually, larger means closer - - # Find all source paths with the same name. - - foreach my $q (keys %srcOutPaths) { - (my $name2, my $version2) = getNameVersion $q; - next unless defined $name2 && defined $version2; - - if ($name eq $name2) { - - my $srcSystem = @{$$dstNarFiles{$p}}[0]->{system}; - my $dstSystem = @{$$srcNarFiles{$q}}[0]->{system}; - if (defined $srcSystem && defined $dstSystem && $srcSystem ne $dstSystem) { - print " SKIPPING $q due to different systems ($srcSystem vs. $dstSystem)\n"; - next; - } - - # If the sizes differ too much, then skip. This - # disambiguates between, e.g., a real component and a - # wrapper component (cf. Firefox in Nixpkgs). - my $srcSize = @{$$srcNarFiles{$q}}[0]->{size}; - my $dstSize = @{$$dstNarFiles{$p}}[0]->{size}; - my $ratio = $srcSize / $dstSize; - $ratio = 1 / $ratio if $ratio < 1; - # print " SIZE $srcSize $dstSize $ratio $q\n"; - - if ($ratio >= 3) { - print " SKIPPING $q due to size ratio $ratio ($srcSize vs. $dstSize)\n"; - next; - } - - # If there are multiple matching names, include the - # ones with the closest version numbers. - my $dist = versionDiff $version, $version2; - if ($dist > $minDist) { - $minDist = $dist; - @closest = ($q); - $closestVersion = $version2; - } elsif ($dist == $minDist) { - push @closest, $q; - } - } - } - - if (scalar(@closest) == 0) { - print " NO BASE: $p\n"; - next; - } - - foreach my $closest (@closest) { - - # Generate a patch between $closest and $p. - print STDERR " $p <- $closest\n"; - - # If the patch already exists, skip it. - if (containsPatch($srcPatches, $p, $closest) || - containsPatch($dstPatches, $p, $closest)) - { - print " skipping, already exists\n"; - next; - } - - my $srcNarBz2 = getNarBz2 $narPath, $srcNarFiles, $closest; - my $dstNarBz2 = getNarBz2 $narPath, $dstNarFiles, $p; - - if (! -f $srcNarBz2) { - warn "patch source archive $srcNarBz2 is missing\n"; - next; - } - - system("$Nix::Config::bzip2 -d < $srcNarBz2 > $tmpDir/A") == 0 - or die "cannot unpack $srcNarBz2"; - - if (stat("$tmpDir/A")->size >= $maxNarSize) { - print " skipping, source is too large\n"; - next; - } - - system("$Nix::Config::bzip2 -d < $dstNarBz2 > $tmpDir/B") == 0 - or die "cannot unpack $dstNarBz2"; - - if (stat("$tmpDir/B")->size >= $maxNarSize) { - print " skipping, destination is too large\n"; - next; - } - - my $time1 = time(); - my $res = system("ulimit -t $timeLimit; $Nix::Config::libexecDir/nix/bsdiff $tmpDir/A $tmpDir/B $tmpDir/DIFF"); - my $time2 = time(); - if ($res) { - warn "binary diff computation aborted after ", $time2 - $time1, " seconds\n"; - next; - } - - my $baseHash = `$Nix::Config::binDir/nix-hash --flat --type $hashAlgo --base32 $tmpDir/A` or die; - chomp $baseHash; - - my $narHash = `$Nix::Config::binDir/nix-hash --flat --type $hashAlgo --base32 $tmpDir/B` or die; - chomp $narHash; - - my $narDiffHash = `$Nix::Config::binDir/nix-hash --flat --type $hashAlgo --base32 $tmpDir/DIFF` or die; - chomp $narDiffHash; - - my $narDiffSize = stat("$tmpDir/DIFF")->size; - my $dstNarBz2Size = stat($dstNarBz2)->size; - - print " size $narDiffSize; full size $dstNarBz2Size; ", $time2 - $time1, " seconds\n"; - - if ($narDiffSize >= $dstNarBz2Size) { - print " rejecting; patch bigger than full archive\n"; - next; - } - - if ($narDiffSize / $dstNarBz2Size >= $maxPatchFraction) { - print " rejecting; patch too large relative to full archive\n"; - next; - } - - my $finalName = "$narDiffHash.nar-bsdiff"; - - if (-e "$patchesPath/$finalName") { - print " not copying, already exists\n"; - } - - else { - system("cp '$tmpDir/DIFF' '$patchesPath/$finalName.tmp'") == 0 - or die "cannot copy diff"; - rename("$patchesPath/$finalName.tmp", "$patchesPath/$finalName") - or die "cannot rename $patchesPath/$finalName.tmp"; - } - - # Add the patch to the manifest. - addPatch $dstPatches, $p, - { url => "$patchesURL/$finalName", hash => "$hashAlgo:$narDiffHash" - , size => $narDiffSize, basePath => $closest, baseHash => "$hashAlgo:$baseHash" - , narHash => "$hashAlgo:$narHash", patchType => "nar-bsdiff" - }; - } - } -} - - -# Propagate useful patches from $srcPatches to $dstPatches. A patch -# is useful if it produces either paths in the $dstNarFiles or paths -# that can be used as the base for other useful patches. -sub propagatePatches { - my ($srcPatches, $dstNarFiles, $dstPatches) = @_; - - print STDERR "propagating patches...\n"; - - my $changed; - do { - # !!! we repeat this to reach the transitive closure; inefficient - $changed = 0; - - print STDERR "loop\n"; - - my %dstBasePaths; - foreach my $q (keys %{$dstPatches}) { - foreach my $patch (@{$$dstPatches{$q}}) { - $dstBasePaths{$patch->{basePath}} = 1; - } - } - - foreach my $p (keys %{$srcPatches}) { - my $patchList = $$srcPatches{$p}; - - my $include = 0; - - # Is path $p included in the destination? If so, include - # patches that produce it. - $include = 1 if defined $$dstNarFiles{$p}; - - # Is path $p a path that serves as a base for paths in the - # destination? If so, include patches that produce it. - # !!! check baseHash - $include = 1 if defined $dstBasePaths{$p}; - - if ($include) { - foreach my $patch (@{$patchList}) { - $changed = 1 if addPatch $dstPatches, $p, $patch; - } - } - - } - - } while $changed; -} - - -# Add all new patches in $srcPatches to $dstPatches. -sub copyPatches { - my ($srcPatches, $dstPatches) = @_; - foreach my $p (keys %{$srcPatches}) { - addPatch $dstPatches, $p, $_ foreach @{$$srcPatches{$p}}; - } -} - - -return 1; |