* bug#28745: [PATCH] tarballs generated on github are generated on demand (leading to different hash sums)
2017-10-08 11:40 bug#28745: tarballs generated on github are generated on demand (leading to different hash sums) ng0
2017-10-08 11:44 ` ng0
2017-10-08 21:58 ` Ricardo Wurmus
@ 2017-10-16 3:10 ` Maxim Cournoyer
2017-10-20 21:04 ` Ludovic Courtès
2 siblings, 1 reply; 8+ messages in thread
From: Maxim Cournoyer @ 2017-10-16 3:10 UTC (permalink / raw)
To: bug#28745
[-- Attachment #1: Type: text/plain, Size: 693 bytes --]
Hello,
I could finish a script that helped me finding all of our affected
packages, verify that only the hash but not the content of the archives
had changed, as well as automate the hash update for those safe to
update.
Attached is the patch and the scripts I used. I think we might
want to reuse some of it to extend guix lint to warn packagers that
archives coming from .*github.*archives URL are not guaranteed to be
stable and that it would be better, if available, to use manually
uploaded releases archives.
Thanks!
Maxim
PS: I've also uploaded the scripts here:
https://notabug.org/apteryx/fiasco for ease of cloning. Any comments
about my nascent (ab)use of Scheme are welcome!
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-gnu-packages-Fix-the-hashes-of-mutated-GitHub-archiv.patch --]
[-- Type: text/x-patch, Size: 6358 bytes --]
From 774a764149ecb0e234ae09c9a0a273af671c3c86 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sun, 15 Oct 2017 22:17:12 -0400
Subject: [PATCH] gnu: packages: Fix the hashes of mutated GitHub archives.
Fixes bug https://bugs.gnu.org/28745.
* gnu/packages/audio.scm (csound): Fix hash.
* gnu/packages/engineering.scm (fritzing): Likewise.
* gnu/packages/erlang.scm (erlang): Likewise.
* gnu/packages/fonts.scm (font-google-material-design-icons): Likewise.
* gnu/packages/graphics.scm (ogre): Likewise.
* gnu/packages/java.scm (java-plexus-interpolation, antlr3): Likewise.
* gnu/packages/serialization.scm (yaml-cpp): Likewise.
* gnu/packages/version-control.scm (libgit2): Likewise.
---
gnu/packages/audio.scm | 2 +-
gnu/packages/engineering.scm | 2 +-
gnu/packages/erlang.scm | 2 +-
gnu/packages/fonts.scm | 2 +-
gnu/packages/graphics.scm | 2 +-
gnu/packages/java.scm | 4 ++--
gnu/packages/serialization.scm | 2 +-
gnu/packages/version-control.scm | 2 +-
8 files changed, 9 insertions(+), 9 deletions(-)
diff --git a/gnu/packages/audio.scm b/gnu/packages/audio.scm
index 0900630df..fbbe77509 100644
--- a/gnu/packages/audio.scm
+++ b/gnu/packages/audio.scm
@@ -580,7 +580,7 @@ emulation (valve, tape), bit fiddling (decimator, pointer-cast), etc.")
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
- "0f67vyy3r29hn26qkkcwnizrnzzy8p7gmg3say5q3wjhxns3b5yl"))))
+ "0xqpqws4jsv7fyawcjzwaw544qbfh29xq164kdf30a9v1n3yklp4"))))
(build-system cmake-build-system)
(inputs
`(("alsa-lib" ,alsa-lib)
diff --git a/gnu/packages/engineering.scm b/gnu/packages/engineering.scm
index 9f9949ef8..c9e184d7d 100644
--- a/gnu/packages/engineering.scm
+++ b/gnu/packages/engineering.scm
@@ -429,7 +429,7 @@ multipole-accelerated algorithm.")
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
- "0pvk57z2pxz89pcwwm61lkpvj4w9qxqz8mi0zkpj6pnaljabp7bf"))))
+ "15rwjp4xdj9w1z9f709rz9p0k2mi9k9idma9hvzkj5j8p04mg7yd"))))
(build-system gnu-build-system)
(arguments
`(#:phases
diff --git a/gnu/packages/erlang.scm b/gnu/packages/erlang.scm
index cf4d7a595..1a575a0fd 100644
--- a/gnu/packages/erlang.scm
+++ b/gnu/packages/erlang.scm
@@ -46,7 +46,7 @@
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
- "1azjjyb743i6vjq7rnh5qnslsqg0x60a9zrlhg9n3dpm13z1b22l"))
+ "11xp6vv1v7iay9dg1xc6xm7izfsanbn5pgwp96ba0j1fmlkhjw92"))
(patches (search-patches "erlang-man-path.patch"))))
(build-system gnu-build-system)
(native-inputs
diff --git a/gnu/packages/fonts.scm b/gnu/packages/fonts.scm
index b65d3a9e9..9975c73a2 100644
--- a/gnu/packages/fonts.scm
+++ b/gnu/packages/fonts.scm
@@ -1026,7 +1026,7 @@ monospace, slab-serif fonts.")
version ".tar.gz"))
(sha256
(base32
- "183n0qv3q8w6n27libarq1fhc4mqv2d3sasbfmbn7x9r5pw9c6ga"))
+ "018i3za9r6kf6svci33z09lc5pr5yz4164m8gzzwjzzqcrng0p5j"))
(file-name (string-append name "-" version ".tar.gz"))))
(build-system font-build-system)
(home-page "http://google.github.io/material-design-icons")
diff --git a/gnu/packages/graphics.scm b/gnu/packages/graphics.scm
index 8e3c5563f..3ffb4dd25 100644
--- a/gnu/packages/graphics.scm
+++ b/gnu/packages/graphics.scm
@@ -244,7 +244,7 @@ exception-handling library.")
"/archive/v" version ".tar.gz"))
(sha256
(base32
- "1ab354bmwwryxr4zgxchfkm6h4z38mjgif8yn89x640rsrgw5ipj"))
+ "1p0c91cc7zg3c00wjaibnxb0a0xm14mkg0h65pzpw93m0d6nc8wd"))
(file-name (string-append name "-" version ".tar.gz"))))
(build-system cmake-build-system)
(arguments
diff --git a/gnu/packages/java.scm b/gnu/packages/java.scm
index 95fba20e8..45cb16f1f 100644
--- a/gnu/packages/java.scm
+++ b/gnu/packages/java.scm
@@ -2299,7 +2299,7 @@ more.")
"plexus-interpolation-" version ".tar.gz"))
(sha256
(base32
- "1w79ljwk42ymrgy8kqxq4l82pgdj6287gabpfnpkyzbrnclsnfrp"))))
+ "03377yzlx5q440m6sxxgv6a5qb8fl30zzcgxgc0hxk5qgl2z1jjn"))))
(build-system ant-build-system)
(arguments
`(#:jar-name "plexus-interpolation.jar"
@@ -4429,7 +4429,7 @@ StringTemplate also powers ANTLR.")
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
- "07zff5frmjd53rnqdx31h0pmswz1lv0p2lp28cspfszh25ysz6sj"))))
+ "0218v683081lg54z9hvjxinhxd4dqp870jx6n39gslm0bkyi4vd6"))))
(build-system ant-build-system)
(arguments
`(#:jar-name (string-append ,name "-" ,version ".jar")
diff --git a/gnu/packages/serialization.scm b/gnu/packages/serialization.scm
index 186692612..c66e814e5 100644
--- a/gnu/packages/serialization.scm
+++ b/gnu/packages/serialization.scm
@@ -247,7 +247,7 @@ that implements both the msgpack and msgpack-rpc specifications.")
"yaml-cpp-" version ".tar.gz"))
(sha256
(base32
- "1vk6pjh0f5k6jwk2sszb9z5169whmiha9ainbdpa1arxlkq7v3b6"))))
+ "1ck7jk0wjfigrf4cgcjqsir4yp1s6vamhhxhpsgfvs46pgm5pk6y"))))
(build-system cmake-build-system)
(arguments
'(#:configure-flags '("-DBUILD_SHARED_LIBS=ON")))
diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm
index 38756f06c..c3f6a8500 100644
--- a/gnu/packages/version-control.scm
+++ b/gnu/packages/version-control.scm
@@ -363,7 +363,7 @@ everything from small to very large projects with speed and efficiency.")
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
- "1fdk9yhwvl1w1z71ykzcvgh4nsf8scxcbclz5anh98zpplmhmisa"))
+ "1b3figbhp5l83vd37vq6j2narrq4yl9pfw6mw0px0dzb1hz3jqka"))
(patches (search-patches "libgit2-0.25.1-mtime-0.patch"))))
(build-system cmake-build-system)
(outputs '("out" "debug"))
--
2.14.1
[-- Attachment #3: (fiasco finder) module --]
[-- Type: text/plain, Size: 11900 bytes --]
(define-module (fiasco finder)
#:use-module (ice-9 control)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 regex)
#:use-module (ice-9 textual-ports)
#:use-module (gnu packages)
#:use-module (guix base32)
#:use-module (guix build utils)
#:use-module (guix download)
#:use-module ((guix build download)
#:select (url-fetch)
#:prefix build:)
#:use-module (guix download)
#:use-module (guix packages)
#:use-module (guix scripts download)
#:use-module (guix scripts hash)
#:use-module (guix store)
#:use-module (guix ui)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:export (result
result?
result-package-name
result-package-version
result-guix-hash
result-upstream-hash
result-hash-ok?
result-safe-to-update?
result-date
result->package
results-dir
results-file
results-file->results
results->results-file
purge-deprecated-results!
find-problematic-packages))
;;; Commentary: Finds GitHub packages whose hash got broken.
;;; Requirements: tar and diff command line tools.
;; Workaround Geiser bug #83 (see:
;; https://github.com/jaor/geiser/issues/83)
(guix-warning-port (current-warning-port))
;;;
;;; Parameters to configure.
;;;
(define substitute-urls
(make-parameter (cons* "https://berlin.guixsd.org"
"https://bayfront.guixsd.org"
%default-substitute-urls)))
(define results-dir
(make-parameter (string-append (getenv "HOME") "/src/guile-hacks/fiasco")))
(define results-file
(make-parameter (string-append (results-dir) "/results.txt")))
(define tar-diff-dir
(make-parameter (string-append (results-dir) "/tar-diffs")))
;;;
;;; Data structures and supporting functions.
;;;
(define-record-type <result>
(make-result package-name package-version guix-hash
upstream-hash hash-ok? safe-to-update? date)
result?
(package-name result-package-name)
(package-version result-package-version)
(guix-hash result-guix-hash)
(upstream-hash result-upstream-hash)
(hash-ok? result-hash-ok?)
(safe-to-update? result-safe-to-update?)
(date result-date))
(define (result->sexp result)
(list (result-package-name result)
(result-package-version result)
(result-guix-hash result)
(result-upstream-hash result)
(result-hash-ok? result)
(result-safe-to-update? result)
(result-date result)))
(define (sexp->result sexp)
(match sexp
((package-name package-version guix-hash
upstream-hash safe-to-update? result-hash-ok? date)
(make-result package-name package-version guix-hash
upstream-hash safe-to-update? result-hash-ok? date))))
(define (results-file->results file)
"Read the results from FILE and return the list of result records."
(with-input-from-file file
(lambda ()
(let loop ((line (read (current-input-port))))
(if (eof-object? line)
'()
(cons (sexp->result line)
(loop (read (current-input-port)))))))))
(define (result-package-exist? result)
"Return the package referred to by RESULT or #f if it doesn't exist."
(let* ((name (result-package-name result))
(version (result-package-version result))
(packages (find-best-packages-by-name name version)))
(not (null? packages))))
(define (result->package result)
"Return the package referred to by RESULT or null if it doesn't exist."
(let* ((name (result-package-name result))
(version (result-package-version result))
(packages (find-best-packages-by-name name version)))
(if (null? packages)
(begin
(warn (format #f "The package ~a, version ~a is no longer in Guix"
name version))
'())
(first packages))))
(define (results->results-file results file)
"Overwrite the FILE content with the RESULTS."
(with-output-to-file file
(lambda ()
(for-each (lambda (result)
(write (result->sexp result) (current-output-port))
(display "\n" (current-output-port)))
results))))
(define (result<? result1 result2)
"Predicate to sort results alphabetically by name and versions."
(let ((name1 (result-package-name result1))
(name2 (result-package-name result2))
(version1 (result-package-version result1))
(version2 (result-package-version result2)))
(or (string<? name1 name2)
(and (string=? name1 name2)
(string<? version1 version2)))))
(define (purge-deprecated-results! file)
"Overwrite FILE after purging the results of Guix packages no longer
available."
(let* ((all-results (results-file->results file))
(valid-results
(sort (filter result-package-exist? all-results) result<?)))
(results->results-file valid-results file)))
\f
;;;
;;; Functions and procedures.
;;;
(define (package<? package1 package2)
"Predicate to sort packages alphabetically by name and versions."
(or (string<? (package-name package1) (package-name package2))
(and (string=? (package-name package1) (package-name package2))
(string<? (package-version package1) (package-version package2)))))
(define (problematic-uri? uri)
(define (contains-github-archive? uri)
(regexp-match? (string-match "github.com/.*/archive/" uri)))
;; URI can be a string or a list of string.
(match uri
((uri1 uri2 ...) ;match list of strings
(not (null? (filter contains-github-archive? uri))))
(uri1 ;match string
(contains-github-archive? uri1))))
(define (problematic-github-package? package)
(let ((source (package-source package)))
(and (origin? source)
(eq? (origin-method source) url-fetch)
(problematic-uri? (origin-uri source)))))
(define (problematic-github-packages)
"Return the list of all the potentially problematic GitHub packages in Guix."
(sort (fold-packages (lambda (p r)
(if (problematic-github-package? p)
(cons p r)
r))
'())
package<?))
(define* (already-checked-packages #:optional (file (results-file)))
"List of already checked packages."
(if (file-exists? file)
(filter package? (map result->package
(results-file->results file)))
'()))
(define (origin->nix-base32-bash origin)
(bytevector->nix-base32-string (origin-sha256 origin)))
(define (origin->download-uri-suffix origin)
"Form the suffix part of the URI of a downloadable substitute file."
(let ((file-name (origin-actual-file-name origin))
(hash (origin->nix-base32-bash origin)))
(string-append "/file/" file-name "/sha256/" hash)))
(define* (download-substitute package file)
"Download the substitute of PACKAGE and return it as FILE, or #f if
the substitute could not be downloaded."
(let* ((origin (package-source package))
(download-uri-suffix (origin->download-uri-suffix origin)))
(let/ec return
(for-each (lambda (url)
;; Do not verify certificate to work around bug#28810.
(let* ((uri (string-append url download-uri-suffix))
(file (build:url-fetch uri file
#:verify-certificate? #f)))
(when file
(return file)))) ;abort loop
(substitute-urls))
(warn "Failed to download a substitute for package: "
(package-name package))
#f)))
(define (file-hash file)
"Return the nix-base32 string corresponding to the sha256 hash of FILE."
(and file
(string-trim-both (with-output-to-string
(lambda ()
(guix-hash file))))))
(define (compare-tar-archives archive1 archive2)
"Return #f if the archives content is the same. Otherwise, a string
detailing the differences is returned."
(let* ((tmpdir (tmpnam))
(subdir1 (string-append tmpdir "/archive1"))
(subdir2 (string-append tmpdir "/archive2"))
(name1 (basename archive1))
(name2 (basename archive2))
(diff-file (string-append (tar-diff-dir) "/"
name1 "-" name2 ".diff")))
(define (untar archive-file dest-dir)
(unless (zero? (system* "tar" "-C" dest-dir "-xf" archive-file))
(error "Failed to extract archive: " archive-file)))
(mkdir-p subdir1)
(mkdir-p subdir2)
(mkdir-p (tar-diff-dir))
(untar archive1 subdir1)
(untar archive2 subdir2)
;; Use --no-dereference to prevent diff failing on broken
;; symlinks that archives may contain (e.g. antlr3).
(let* ((input-pipe (open-pipe* OPEN_READ
"diff" "-r" "--no-dereference"
subdir1 subdir2))
(output (get-string-all input-pipe))
(exit-val (status:exit-val (close-pipe input-pipe))))
(case exit-val
((0) #f)
((1)
(with-output-to-file diff-file
(lambda ()
(display output)))
(format #t "Diff saved to ~a:~%~a~%" diff-file output))
(else (error "diff failed comparing the folders: " subdir1 subdir2
"exit status: " exit-val))))))
(define (hash-ok? hash1 hash2)
(and (string? hash1)
(string? hash2)
(string=? hash1 hash2)))
(define (check-package-hash package)
"Verify the hash of a package and return a <result> object. Assumes
the definition of PACKAGE contains an origin using the url-fetch
method and a base32 encoded sha256 hash."
(let* ((date (date->string (current-date)))
(name (package-name package))
(version (package-version package))
(origin (package-source package))
(tmpdir (tmpnam))
(tmpdir! (mkdir-p tmpdir))
(file-name (origin-actual-file-name origin))
(upstream-archive (string-append tmpdir "/upstream-" file-name))
(substitute-archive (string-append tmpdir "/substitute-" file-name))
(uri (origin-uri origin))
(guix-hash (origin->nix-base32-bash origin))
(upstream-hash (file-hash (build:url-fetch uri upstream-archive)))
(hash-ok? (hash-ok? upstream-hash guix-hash))
(substitute (and upstream-hash ;stop if false
(not hash-ok?)
(download-substitute package
substitute-archive)))
(safe-to-update?
(if hash-ok?
#f ;false here means 'no need to update'
(and substitute ;stop here if we don't have a substitute
(not (compare-tar-archives upstream-archive
substitute-archive))))))
(make-result name version guix-hash upstream-hash hash-ok?
safe-to-update? date)))
\f
;;;
;;; Main program
;;;
(define (find-problematic-packages)
"Find and print the names of the potentially problematic GitHub packages."
(define (print-packages packages)
(for-each (lambda (name)
(format #t "~a~%" name))
(map package-name packages))
(format #t "~%"))
(define (verify-package-hash package)
(format #t "~%~a verifying package hash...~%" (package-name package))
(let* ((result (check-package-hash package))
(name (result-package-name result))
(guix-hash (result-guix-hash result))
(upstream-hash (result-upstream-hash result))
(hash-ok? (result-hash-ok? result)))
(format #t "~a Guix hash: ~s~%" name guix-hash)
(format #t "~a upstream hash: ~s~%" name upstream-hash)
(if hash-ok?
(format #t "~a hash OK~%" name)
(format #t "~a hash NOK~%" name))
(cond
(hash-ok? #t) ;no-op
((result-safe-to-update? result)
(format #t "~a hash can be safely updated~%" name))
(else (format #t "~a requires manual verification~%" name)))
;; Append result to results file.
(let ((results-file (open-file (results-file) "a")))
(dynamic-wind
(lambda () #f)
(lambda ()
(write (result->sexp result) results-file)
(display "\n" results-file))
(lambda () (close results-file))))))
(let* ((problematic-github-packages (problematic-github-packages))
(already-checked-packages (already-checked-packages)))
(format #t "Number of potentially problematic GitHub packages: ~a~%"
(length problematic-github-packages))
;;(print-packages problematic-github-packages)
(unless (null? already-checked-packages)
(format #t "Skipping ~a already checked packages~%"
(length already-checked-packages)))
(for-each verify-package-hash
(lset-difference eq? problematic-github-packages
already-checked-packages))))
[-- Attachment #4: fiasco runner --]
[-- Type: text/plain, Size: 558 bytes --]
;;; Script that detects problematic github packages.
;;; To run, use something like this in the "fiasco" dir:
;;; ~/src/guix/pre-inst-env guile -L . main.scm
(use-modules (fiasco finder)
(fiasco fixer))
(define (main)
;; You may select a different results-dir by parameterizing it
;; differently below. More parameters available to configure can be
;; found in (fiasco finder).
(parameterize ((results-dir (string-append (getenv "HOME")
"/src/guile-hacks/fiasco")))
(find-problematic-packages)
(fix-packages-hash)))
(main)
[-- Attachment #5: (fiasco fixer) module --]
[-- Type: text/plain, Size: 1827 bytes --]
(define-module (fiasco fixer)
#:use-module (fiasco finder)
#:use-module (guix base32)
#:use-module (guix upstream)
#:export (fix-packages-hash))
;;; Commentary:
;;;
;;; Repair the packages whose hash can be safely updated, as found by
;;; the finder script. This should be run from a checkout of the Guix
;;; source tree, e.g. as "./pre-inst-guix guile ~/src/guile-hacks/fiasco/run.scm
(define (result-needs-checking? result)
(and (not (result-hash-ok? result))
(not (result-safe-to-update? result))))
(define* (fix-packages-hash #:optional (file (results-file)))
"Correct the packages whose hash can be safely updated, based on
data in FILE."
(let* ((results (results-file->results file))
(results-to-check (filter result-needs-checking? results))
(actionable-results (filter result-safe-to-update? results)))
(define (update-package-hash result)
(when (not (null? (result->package result)))
(let* ((package (result->package result))
(name (result-package-name result))
(version (result-package-version result))
(old-hash (result-guix-hash result))
(new-hash (result-upstream-hash result))
(new-hash-bv (nix-base32-string->bytevector new-hash)))
(format #t "~a: updating hash from ~s to ~s..." name old-hash new-hash)
(if (update-package-source package version new-hash-bv)
(format #t " success~%")
(format #t " failed~%")))))
(format #t "The following packages require manual verification:~%")
(for-each (lambda (r)
(format #t "~a version ~a~%"
(result-package-name r)
(result-package-version r)))
results-to-check)
(display "\n")
(format #t "Attempting to repair the hashes of ~a packages...~%"
(length actionable-results))
(for-each update-package-hash actionable-results)))
^ permalink raw reply related [flat|nested] 8+ messages in thread