From 60b04024f8823192b74c1ed5b14f318049865ac7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 13 Dec 2018 19:45:47 +0100 Subject: substitute: Ignore irrelevant narinfo signatures. Fixes . Fixes a bug whereby 'guix substitute' would accept narinfos whose signature does not cover the StorePath/NarHash/References tuple. * guix/scripts/substitute.scm (narinfo-sha256)[%mandatory-fields]: New variable. Compute SIGNED-FIELDS; return #f unless each of the %MANDATORY-FIELDS is among SIGNED-FIELDS. * tests/substitute.scm ("query narinfo with signature over nothing") ("query narinfo with signature over irrelevant bits"): New tests. --- tests/substitute.scm | 42 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/substitute.scm b/tests/substitute.scm index 964a57f30b..f4f2e9512d 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Nikita Karetnikov -;;; Copyright © 2014, 2015, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -211,6 +211,46 @@ a file for NARINFO." (lambda () (guix-substitute "--query")))))))) +(test-equal "query narinfo with signature over nothing" + ;; The signature is computed over the empty string, not over the important + ;; parts, so the narinfo must be ignored. + "" + + (with-narinfo (string-append "Signature: " (signature-field "") "\n" + %narinfo "\n") + (string-trim-both + (with-output-to-string + (lambda () + (with-input-from-string (string-append "have " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + (lambda () + (guix-substitute "--query")))))))) + +(test-equal "query narinfo with signature over irrelevant bits" + ;; The signature is valid but it does not cover the + ;; StorePath/NarHash/References tuple and is thus irrelevant; the narinfo + ;; must be ignored. + "" + + (let ((prefix (string-append "StorePath: " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo +URL: example.nar +Compression: none\n"))) + (with-narinfo (string-append prefix + "Signature: " (signature-field prefix) " +NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +NarSize: 42 +References: bar baz +Deriver: " (%store-prefix) "/foo.drv +System: mips64el-linux\n") + (string-trim-both + (with-output-to-string + (lambda () + (with-input-from-string (string-append "have " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + (lambda () + (guix-substitute "--query"))))))))) + (test-equal "query narinfo signed with authorized key" (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") -- cgit v1.2.3 From adb158b7396cbdcda347fa298978408e531a03fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Dec 2018 11:10:25 +0100 Subject: deduplication: Gracefully handle ENOSPC raised by 'link' calls. Reported by Andreas Enge in . * guix/store/deduplication.scm (replace-with-link): Catch ENOSPC around 'get-temp-link'. Do nothing when 'get-temp-link' throws ENOSPC. Move code to restore PARENT's permissions outside of 'catch'. * tests/store-deduplication.scm ("deduplicate, ENOSPC"): New test. --- guix/store/deduplication.scm | 40 ++++++++++++++++++++++++++------------- tests/store-deduplication.scm | 44 ++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 70 insertions(+), 14 deletions(-) (limited to 'tests') diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 21b0c81f3d..a777940f86 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -99,24 +99,38 @@ LINK-PREFIX." (define* (replace-with-link target to-replace #:key (swap-directory (dirname target))) "Atomically replace the file TO-REPLACE with a link to TARGET. Use -SWAP-DIRECTORY as the directory to store temporary hard links. +SWAP-DIRECTORY as the directory to store temporary hard links. Upon ENOSPC +and EMLINK, TO-REPLACE is left unchanged. Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." - (let* ((temp-link (get-temp-link target swap-directory)) - (parent (dirname to-replace)) - (stat (stat parent))) - (make-file-writable parent) + (define temp-link (catch 'system-error (lambda () - (rename-file temp-link to-replace) - - ;; Restore PARENT's mtime and permissions. - (set-file-time parent stat) - (chmod parent (stat:mode stat))) + (get-temp-link target swap-directory)) (lambda args - (delete-file temp-link) - (unless (= EMLINK (system-error-errno args)) - (apply throw args)))))) + ;; We get ENOSPC when we can't fit an additional entry in + ;; SWAP-DIRECTORY. + (if (= ENOSPC (system-error-errno args)) + #f + (apply throw args))))) + + ;; If we couldn't create TEMP-LINK, that's OK: just don't do the + ;; replacement, which means TO-REPLACE won't be deduplicated. + (when temp-link + (let* ((parent (dirname to-replace)) + (stat (stat parent))) + (make-file-writable parent) + (catch 'system-error + (lambda () + (rename-file temp-link to-replace)) + (lambda args + (delete-file temp-link) + (unless (= EMLINK (system-error-errno args)) + (apply throw args)))) + + ;; Restore PARENT's mtime and permissions. + (set-file-time parent stat) + (chmod parent (stat:mode stat))))) (define* (deduplicate path hash #:key (store %store-directory)) "Check if a store item with sha256 hash HASH already exists. If so, diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm index e438aa84c6..e2870a363d 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm @@ -48,7 +48,7 @@ (put-bytevector port data)))) identical) ;; Make the parent of IDENTICAL read-only. This should not prevent - ;; deduplication for inserting its hard link. + ;; deduplication from inserting its hard link. (chmod (dirname (second identical)) #o544) (call-with-output-file unique @@ -64,4 +64,46 @@ (stat:nlink (stat unique)) (map (compose stat:nlink stat) identical)))))) +(test-equal "deduplicate, ENOSPC" + (cons* #f ;inode comparison + (append (make-list 3 4) + (make-list 7 1))) ;'nlink' values + + ;; In this scenario the first 3 files are properly deduplicated and then we + ;; simulate a full '.links' directory where link(2) gets ENOSPC, thereby + ;; preventing deduplication of the subsequent files. + (call-with-temporary-directory + (lambda (store) + (let ((true-link link) + (links 0) + (data1 (string->utf8 "Hello, world!")) + (data2 (string->utf8 "Hi, world!")) + (identical (map (lambda (n) + (string-append store "/" (number->string n) + "/a/b/c")) + (iota 10))) + (populate (lambda (data) + (lambda (file) + (mkdir-p (dirname file)) + (call-with-output-file file + (lambda (port) + (put-bytevector port data))))))) + (for-each (populate data1) (take identical 5)) + (for-each (populate data2) (drop identical 5)) + (dynamic-wind + (lambda () + (set! link (lambda (old new) + (set! links (+ links 1)) + (if (<= links 3) + (true-link old new) + (throw 'system-error "link" "~A" '("Whaaat?!") + (list ENOSPC)))))) + (lambda () + (deduplicate store (nar-sha256 store) #:store store)) + (lambda () + (set! link true-link))) + + (cons (apply = (map (compose stat:ino stat) identical)) + (map (compose stat:nlink stat) identical)))))) + (test-end "store-deduplication") -- cgit v1.2.3 From cce654fabdf09cac7d18f9bad842ba8445aa022c Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Mon, 17 Dec 2018 21:05:35 +0100 Subject: import: Update opam importer. * guix/import/opam.scm: Update importer for opam 2. * tests/opam.scm: Update tests for the opam 2 importer. --- guix/import/opam.scm | 305 ++++++++++++++++++++++++++++----------------------- po/guix/POTFILES.in | 1 + tests/opam.scm | 225 +++++++++++++++++++++++++------------ 3 files changed, 321 insertions(+), 210 deletions(-) (limited to 'tests') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index f252bdc31a..c42a5d767d 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -17,132 +17,108 @@ ;;; along with GNU Guix. If not, see . (define-module (guix import opam) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) - #:use-module (ice-9 vlist) + #:use-module (ice-9 peg) + #:use-module (ice-9 receive) #:use-module ((ice-9 rdelim) #:select (read-line)) + #:use-module (ice-9 textual-ports) + #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (web uri) #:use-module (guix http-client) + #:use-module (guix git) + #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) #:export (opam->guix-package)) -(define (opam-urls) - "Fetch the urls.txt file from the opam repository and returns the list of -URLs it contains." - (let ((port (http-fetch/cached (string->uri "https://opam.ocaml.org/urls.txt")))) - (let loop ((result '())) - (let ((line (read-line port))) - (if (eof-object? line) - (begin - (close port) - result) - (loop (cons line result))))))) - -(define (vhash-ref hashtable key default) - (match (vhash-assoc key hashtable) - (#f default) - ((_ . x) x))) - -(define (hashtable-update hashtable line) - "Parse @var{line} to get the name and version of the package and adds them -to the hashtable." - (let* ((line (string-split line #\ ))) - (match line - ((url foo ...) - (if (equal? url "repo") - hashtable - (match (string-split url #\/) - ((type name1 versionstr foo ...) - (if (equal? type "packages") - (match (string-split versionstr #\.) - ((name2 versions ...) - (let ((version (string-join versions "."))) - (if (equal? name1 name2) - (let ((curr (vhash-ref hashtable name1 '()))) - (vhash-cons name1 (cons version curr) hashtable)) - hashtable))) - (_ hashtable)) - hashtable)) - (_ hashtable)))) - (_ hashtable)))) - -(define (urls->hashtable urls) - "Transform urls.txt in a hashtable whose keys are package names and values -the list of available versions." - (let ((hashtable vlist-null)) - (let loop ((urls urls) (hashtable hashtable)) - (match urls - (() hashtable) - ((url rest ...) (loop rest (hashtable-update hashtable url))))))) +;; Define a PEG parser for the opam format +(define-peg-pattern SP none (or " " "\n")) +(define-peg-pattern SP2 body (or " " "\n")) +(define-peg-pattern QUOTE none "\"") +(define-peg-pattern QUOTE2 body "\"") +(define-peg-pattern COLON none ":") +;; A string character is any character that is not a quote, or a quote preceded by a backslash. +(define-peg-pattern STRCHR body + (or " " "!" (and (ignore "\\") "\"") + (and (ignore "\\") "\\") (range #\# #\頋))) +(define-peg-pattern operator all (or "=" "!" "<" ">")) + +(define-peg-pattern records body (* (and (or record weird-record) (* SP)))) +(define-peg-pattern record all (and key COLON (* SP) value)) +(define-peg-pattern weird-record all (and key (* SP) dict)) +(define-peg-pattern key body (+ (or (range #\a #\z) "-"))) +(define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP))) +(define-peg-pattern ground-value body (and (or multiline-string string-pat list-pat var) (* SP))) +(define-peg-pattern conditional-value all (and ground-value (* SP) condition)) +(define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE)) +(define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]"))) +(define-peg-pattern var all (+ (or (range #\a #\z) "-"))) +(define-peg-pattern multiline-string all + (and QUOTE QUOTE QUOTE (* SP) + (* (or SP2 STRCHR (and QUOTE2 (not-followed-by QUOTE)) + (and QUOTE2 QUOTE2 (not-followed-by QUOTE)))) + QUOTE QUOTE QUOTE)) +(define-peg-pattern dict all (and (ignore "{") (* SP) records (* SP) (ignore "}"))) + +(define-peg-pattern condition body (and (ignore "{") condition-form (ignore "}"))) + +(define-peg-pattern condition-form body + (and + (* SP) + (or condition-and condition-or condition-form2) + (* SP))) +(define-peg-pattern condition-form2 body + (and (* SP) (or condition-greater-or-equal condition-greater + condition-lower-or-equal condition-lower + condition-neq condition-eq condition-content) (* SP))) + +;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string)) +(define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string)) +(define-peg-pattern condition-greater all (and (ignore ">") (* SP) condition-string)) +(define-peg-pattern condition-lower-or-equal all (and (ignore (and "<" "=")) (* SP) condition-string)) +(define-peg-pattern condition-lower all (and (ignore "<") (* SP) condition-string)) +(define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&")) (* SP) condition-form)) +(define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form)) +(define-peg-pattern condition-eq all (and condition-content (* SP) (ignore "=") (* SP) condition-content)) +(define-peg-pattern condition-neq all (and condition-content (* SP) (ignore (and "!" "=")) (* SP) condition-content)) +(define-peg-pattern condition-content body (or condition-string condition-var)) +(define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!")))) +(define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE)) +(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-"))) + +(define (get-opam-repository) + "Update or fetch the latest version of the opam repository and return the +path to the repository." + (receive (location commit) + (update-cached-checkout "https://github.com/ocaml/opam-repository") + location)) (define (latest-version versions) "Find the most recent version from a list of versions." - (match versions - ((first rest ...) - (let loop ((versions rest) (m first)) - (match versions - (() m) - ((first rest ...) - (loop rest (if (version>? m first) m first)))))))) - -(define (fetch-package-url uri) - "Fetch and parse the url file. Return the URL the package can be downloaded -from." - (let ((port (http-fetch uri))) - (let loop ((result #f)) - (let ((line (read-line port))) - (if (eof-object? line) - (begin - (close port) - result) - (let* ((line (string-split line #\ ))) - (match line - ((key value rest ...) - (if (member key '("archive:" "http:")) - (loop (string-trim-both value #\")) - (loop result)))))))))) - -(define (fetch-package-metadata uri) - "Fetch and parse the opam file. Return an association list containing the -homepage, the license and the list of inputs." - (let ((port (http-fetch uri))) - (let loop ((result '()) (dependencies? #f)) - (let ((line (read-line port))) - (if (eof-object? line) - (begin - (close port) - result) - (let* ((line (string-split line #\ ))) - (match line - ((key value ...) - (let ((dependencies? - (if dependencies? - (not (equal? key "]")) - (equal? key "depends:"))) - (val (string-trim-both (string-join value "") #\"))) - (cond - ((equal? key "homepage:") - (loop (cons `("homepage" . ,val) result) dependencies?)) - ((equal? key "license:") - (loop (cons `("license" . ,val) result) dependencies?)) - ((and dependencies? (not (equal? val "["))) - (match (string-split val #\{) - ((val rest ...) - (let ((curr (assoc-ref result "inputs")) - (new (string-trim-both - val (list->char-set '(#\] #\[ #\"))))) - (loop (cons `("inputs" . ,(cons new (if curr curr '()))) result) - (if (string-contains val "]") #f dependencies?)))))) - (else (loop result dependencies?)))))))))))) - -(define (string->license str) - (cond - ((equal? str "MIT") '(license:expat)) - ((equal? str "GPL2") '(license:gpl2)) - ((equal? str "LGPLv2") '(license:lgpl2)) - (else `()))) + (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions)) + +(define (find-latest-version package repository) + "Get the latest version of a package as described in the given repository." + (let* ((dir (string-append repository "/packages/" package)) + (versions (scandir dir (lambda (name) (not (string-prefix? "." name)))))) + (if versions + (let ((versions (map + (lambda (dir) + (string-join (cdr (string-split dir #\.)) ".")) + versions))) + (latest-version versions)) + (begin + (format #t (G_ "Package not found in opam repository: ~a~%") package) + #f)))) + +(define (get-metadata opam-file) + (with-input-from-file opam-file + (lambda _ + (peg:tree (match-pattern records (get-string-all (current-input-port))))))) (define (ocaml-name->guix-name name) (cond @@ -151,33 +127,85 @@ homepage, the license and the list of inputs." ((string-prefix? "conf-" name) (substring name 5)) (else (string-append "ocaml-" name)))) -(define (dependencies->inputs dependencies) - "Transform the list of dependencies in a list of inputs." - (if (not dependencies) - '() - (map (lambda (input) - (list input (list 'unquote (string->symbol input)))) - (map ocaml-name->guix-name dependencies)))) +(define (metadata-ref file lookup) + (pk 'file file 'lookup lookup) + (fold (lambda (record acc) + (match record + ((record key val) + (if (equal? key lookup) + (match val + (('list-pat . stuff) stuff) + (('string-pat stuff) stuff) + (('multiline-string stuff) stuff) + (('dict records ...) records)) + acc)))) + #f file)) + +(define (native? condition) + (match condition + (('condition-var var) + (match var + ("with-test" #t) + ("test" #t) + ("build" #t) + (_ #f))) + ((or ('condition-or cond-left cond-right) ('condition-and cond-left cond-right)) + (or (native? cond-left) + (native? cond-right))) + (_ #f))) + +(define (dependency->input dependency) + (match dependency + (('string-pat str) str) + (('conditional-value val condition) + (if (native? condition) "" (dependency->input val))))) + +(define (dependency->native-input dependency) + (match dependency + (('string-pat str) "") + (('conditional-value val condition) + (if (native? condition) (dependency->input val) "")))) + +(define (ocaml-names->guix-names names) + (map ocaml-name->guix-name + (remove (lambda (name) + (or (equal? "" name)) + (equal? "ocaml" name)) + names))) + +(define (depends->inputs depends) + (filter (lambda (name) + (and (not (equal? "" name)) + (not (equal? "ocaml" name)) + (not (equal? "ocamlfind" name)))) + (map dependency->input depends))) + +(define (depends->native-inputs depends) + (filter (lambda (name) (not (equal? "" name))) + (map dependency->native-input depends))) + +(define (dependency-list->inputs lst) + (map + (lambda (dependency) + (list dependency (list 'unquote (string->symbol dependency)))) + (ocaml-names->guix-names lst))) (define (opam->guix-package name) - (let* ((hashtable (urls->hashtable (opam-urls))) - (versions (vhash-ref hashtable name #f))) - (unless (eq? versions #f) - (let* ((version (latest-version versions)) - (package-url (string-append "https://opam.ocaml.org/packages/" name - "/" name "." version "/")) - (url-url (string-append package-url "url")) - (opam-url (string-append package-url "opam")) - (source-url (fetch-package-url url-url)) - (metadata (fetch-package-metadata opam-url)) - (dependencies (assoc-ref metadata "inputs")) - (inputs (dependencies->inputs dependencies))) + (and-let* ((repository (get-opam-repository)) + (version (find-latest-version name repository)) + (file (string-append repository "/packages/" name "/" name "." (pk 'version version) "/opam")) + (opam-content (get-metadata file)) + (url-dict (metadata-ref (pk 'metadata opam-content) "url")) + (source-url (metadata-ref url-dict "src")) + (requirements (metadata-ref opam-content "depends")) + (inputs (dependency-list->inputs (depends->inputs requirements))) + (native-inputs (dependency-list->inputs (depends->native-inputs requirements)))) (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) `(package (name ,(ocaml-name->guix-name name)) - (version ,version) + (version ,(metadata-ref opam-content "version")) (source (origin (method url-fetch) @@ -187,7 +215,10 @@ homepage, the license and the list of inputs." ,@(if (null? inputs) '() `((inputs ,(list 'quasiquote inputs)))) - (home-page ,(assoc-ref metadata "homepage")) - (synopsis "") - (description "") - (license ,@(string->license (assoc-ref metadata "license"))))))))))) + ,@(if (null? native-inputs) + '() + `((native-inputs ,(list 'quasiquote native-inputs)))) + (home-page ,(metadata-ref opam-content "homepage")) + (synopsis ,(metadata-ref opam-content "synopsis")) + (description ,(metadata-ref opam-content "description")) + (license #f))))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index e0da801587..c432973f9e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -7,6 +7,7 @@ gnu/system.scm gnu/services/shepherd.scm gnu/system/mapped-devices.scm gnu/system/shadow.scm +guix/import/opam.scm guix/scripts.scm guix/scripts/build.scm guix/discovery.scm diff --git a/tests/opam.scm b/tests/opam.scm index a1320abfdc..e0ec5ef3d4 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -21,98 +21,177 @@ #:use-module (guix base32) #:use-module (gcrypt hash) #:use-module (guix tests) + #:use-module ((guix build syscalls) #:select (mkdtemp!)) #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which)) + #:use-module ((guix utils) #:select (call-with-temporary-output-file)) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (web uri) - #:use-module (ice-9 match)) - -(define test-url-file - "http: \"https://example.org/foo-1.0.0.tar.gz\" -checksum: \"ac8920f39a8100b94820659bc2c20817\"") - -(define test-source-hash - "") - -(define test-urls - "repo ac8920f39a8100b94820659bc2c20817 0o644 -packages/foo/foo.1.0.0/url ac8920f39a8100b94820659bc2c20817 0o644 -packages/foo/foo.1.0.0/opam ac8920f39a8100b94820659bc2c20817 0o644 -packages/foo/foo.1.0.0/descr ac8920f39a8100b94820659bc2c20817 0o644") + #:use-module (ice-9 match) + #:use-module (ice-9 peg)) (define test-opam-file -"opam-version: 1.2 +"opam-version: \"2.0\" + version: \"1.0.0\" maintainer: \"Alice Doe\" -authors: \"Alice Doe, John Doe\" +authors: [ + \"Alice Doe\" + \"John Doe\" +] homepage: \"https://example.org/\" bug-reports: \"https://example.org/bugs\" -license: \"MIT\" dev-repo: \"https://example.org/git\" build: [ - \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" + [\"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\"] ] build-test: [ - \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\" + [\"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\"] ] depends: [ \"alcotest\" {test & >= \"0.7.2\"} \"ocamlbuild\" {build & >= \"0.9.2\"} -]") + \"zarith\" {>= \"0.7\"} +] +synopsis: \"Some example package\" +description: \"\"\" +This package is just an example.\"\"\" +url { + src: \"https://example.org/foo-1.0.0.tar.gz\" + checksum: \"md5=74c6e897658e820006106f45f736381f\" +}") + +(define test-source-hash + "") + +(define test-repo + (mkdtemp! "/tmp/opam-repo.XXXXXX")) (test-begin "opam") (test-assert "opam->guix-package" - ;; Replace network resources with sample data. - (mock ((guix import utils) url-fetch - (lambda (url file-name) - (match url - ("https://example.org/foo-1.0.0.tar.gz" - (begin - (mkdir-p "foo-1.0.0") - (system* "tar" "czvf" file-name "foo-1.0.0/") - (delete-file-recursively "foo-1.0.0") - (set! test-source-hash - (call-with-input-file file-name port-sha256)))) - (_ (error "Unexpected URL: " url))))) - (mock ((guix http-client) http-fetch/cached - (lambda (url . rest) - (match (uri->string url) - ("https://opam.ocaml.org/urls.txt" - (values (open-input-string test-urls) - (string-length test-urls))) - (_ (error "Unexpected URL: " url))))) - (mock ((guix http-client) http-fetch - (lambda (url . rest) - (match url - ("https://opam.ocaml.org/packages/foo/foo.1.0.0/url" - (values (open-input-string test-url-file) - (string-length test-url-file))) - ("https://opam.ocaml.org/packages/foo/foo.1.0.0/opam" - (values (open-input-string test-opam-file) - (string-length test-opam-file))) - (_ (error "Unexpected URL: " url))))) - (match (opam->guix-package "foo") - (('package - ('name "ocaml-foo") - ('version "1.0.0") - ('source ('origin - ('method 'url-fetch) - ('uri "https://example.org/foo-1.0.0.tar.gz") - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'ocaml-build-system) - ('inputs - ('quasiquote - (("ocamlbuild" ('unquote 'ocamlbuild)) - ("ocaml-alcotest" ('unquote 'ocaml-alcotest))))) - ('home-page "https://example.org/") - ('synopsis "") - ('description "") - ('license 'license:expat)) - (string=? (bytevector->nix-base32-string - test-source-hash) - hash)) - (x - (pk 'fail x #f))))))) + (mock ((guix import utils) url-fetch + (lambda (url file-name) + (match url + ("https://example.org/foo-1.0.0.tar.gz" + (begin + (mkdir-p "foo-1.0.0") + (system* "tar" "czvf" file-name "foo-1.0.0/") + (delete-file-recursively "foo-1.0.0") + (set! test-source-hash + (call-with-input-file file-name port-sha256)))) + (_ (error "Unexpected URL: " url))))) + (let ((my-package (string-append test-repo "/packages/foo/foo.1.0.0"))) + (mkdir-p my-package) + (with-output-to-file (string-append my-package "/opam") + (lambda _ + (format #t "~a" test-opam-file)))) + (mock ((guix import opam) get-opam-repository + (lambda _ + test-repo)) + (match (opam->guix-package "foo") + (('package + ('name "ocaml-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri "https://example.org/foo-1.0.0.tar.gz") + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'ocaml-build-system) + ('inputs + ('quasiquote + (("ocaml-zarith" ('unquote 'ocaml-zarith))))) + ('native-inputs + ('quasiquote + (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) + ("ocamlbuild" ('unquote 'ocamlbuild))))) + ('home-page "https://example.org/") + ('synopsis "Some example package") + ('description "This package is just an example.") + ('license #f)) + (string=? (bytevector->nix-base32-string + test-source-hash) + hash)) + (x + (pk 'fail x #f)))))) + +;; Test the opam file parser +;; We fold over some test cases. Each case is a pair of the string to parse and the +;; expected result. +(test-assert "parse-strings" + (fold (lambda (test acc) + (display test) (newline) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) string-pat) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("\"hello\"" . (string-pat "hello")) + ("\"hello world\"" . (string-pat "hello world")) + ("\"The dreaded \\\"é\\\"\"" . (string-pat "The dreaded \"é\"")) + ("\"Have some \\\\\\\\ :)\"" . (string-pat "Have some \\\\ :)")) + ("\"今日は\"" . (string-pat "今日は"))))) + +(test-assert "parse-multiline-strings" + (fold (lambda (test acc) + (display test) (newline) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) multiline-string) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("\"\"\"hello\"\"\"" . (multiline-string "hello")) + ("\"\"\"hello \"world\"!\"\"\"" . (multiline-string "hello \"world\"!")) + ("\"\"\"hello \"\"world\"\"!\"\"\"" . (multiline-string "hello \"\"world\"\"!"))))) + +(test-assert "parse-lists" + (fold (lambda (test acc) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) list-pat) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("[]" . list-pat) + ("[make]" . (list-pat (var "make"))) + ("[\"make\"]" . (list-pat (string-pat "make"))) + ("[\n a\n b\n c]" . (list-pat (var "a") (var "b") (var "c"))) + ("[a b \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c")))))) + +(test-assert "parse-dicts" + (fold (lambda (test acc) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) dict) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("{}" . dict) + ("{a: \"b\"}" . (dict (record "a" (string-pat "b")))) + ("{a: \"b\"\nc: \"d\"}" . (dict (record "a" (string-pat "b")) (record "c" (string-pat "d"))))))) + +(test-assert "parse-conditions" + (fold (lambda (test acc) + (and acc + (let ((result (peg:tree (match-pattern (@@ (guix import opam) condition) (car test))))) + (if (equal? result (cdr test)) + #t + (pk 'fail (list (car test) result (cdr test)) #f))))) + #t '(("" . #f) + ("{}" . #f) + ("{build}" . (condition-var "build")) + ("{>= \"0.2.0\"}" . (condition-greater-or-equal + (condition-string "0.2.0"))) + ("{>= \"0.2.0\" & test}" . (condition-and + (condition-greater-or-equal + (condition-string "0.2.0")) + (condition-var "test"))) + ("{>= \"0.2.0\" | build}" . (condition-or + (condition-greater-or-equal + (condition-string "0.2.0")) + (condition-var "build")))))) (test-end "opam") -- cgit v1.2.3 From a93c1606312e41ffe509977502ce6055f40bc629 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Dec 2018 22:47:44 +0100 Subject: environment: Support package transformation options. Fixes . Reported by Adrien Guilbaud . * guix/scripts/environment.scm (show-help): Add call to 'show-transformation-options-help'. (%options): Add %TRANSFORMATION-OPTIONS. (options/resolve-packages): Add 'store' parameter. [transform, package->manifest-entry*]: New procedures. Use 'package->manifest-entry*' instead of 'package->manifest-entry'. (guix-environment): Move definition of 'manifest' within 'with-store'. * tests/guix-environment.sh: Add test. --- doc/guix.texi | 3 ++- guix/scripts/environment.scm | 24 ++++++++++++++++++------ tests/guix-environment.sh | 14 +++++++++++++- 3 files changed, 33 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 1c26dc5a89..3ee65116b6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8350,7 +8350,8 @@ guix environment --container --share=$HOME=/exchange --ad-hoc guile -- guile @command{guix environment} also supports all of the common build options that @command{guix -build} supports (@pxref{Common Build Options}). +build} supports (@pxref{Common Build Options}) as well as package +transformation options (@pxref{Package Transformation Options}). @node Invoking guix publish diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 5965e3426e..7733fbcae4 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -162,6 +162,8 @@ COMMAND or an interactive shell in that environment.\n")) (newline) (show-build-options-help) (newline) + (show-transformation-options-help) + (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -261,7 +263,9 @@ COMMAND or an interactive shell in that environment.\n")) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) - %standard-build-options)) + + (append %transformation-options + %standard-build-options))) (define (pick-all alist key) "Return a list of values in ALIST associated with KEY." @@ -274,7 +278,7 @@ COMMAND or an interactive shell in that environment.\n")) (_ memo))) '() alist)) -(define (options/resolve-packages opts) +(define (options/resolve-packages store opts) "Return OPTS with package specification strings replaced by manifest entries for the corresponding packages." (define (manifest-entry=? e1 e2) @@ -282,15 +286,21 @@ for the corresponding packages." (string=? (manifest-entry-output e1) (manifest-entry-output e2)))) + (define transform + (cut (options->transformation opts) store <>)) + + (define* (package->manifest-entry* package #:optional (output "out")) + (package->manifest-entry (transform package) output)) + (define (packages->outputs packages mode) (match packages ((? package? package) (if (eq? mode 'ad-hoc-package) - (list (package->manifest-entry package)) + (list (package->manifest-entry* package)) (package-environment-inputs package))) (((? package? package) (? string? output)) (if (eq? mode 'ad-hoc-package) - (list (package->manifest-entry package output)) + (list (package->manifest-entry* package output)) (package-environment-inputs package))) ((lst ...) (append-map (cut packages->outputs <> mode) lst)))) @@ -301,7 +311,7 @@ for the corresponding packages." (('package 'ad-hoc-package (? string? spec)) (let-values (((package output) (specification->package+output spec))) - (list (package->manifest-entry package output)))) + (list (package->manifest-entry* package output)))) (('package 'package (? string? spec)) (package-environment-inputs (specification->package+output spec))) @@ -654,7 +664,6 @@ message if any test fails." ;; within the container. '("/bin/sh") (list %default-shell)))) - (manifest (options/resolve-packages opts)) (mappings (pick-all opts 'file-system-mapping))) (when container? (assert-container-features)) @@ -666,6 +675,9 @@ message if any test fails." (with-store store (with-status-report print-build-event + (define manifest + (options/resolve-packages store opts)) + (set-build-options-from-command-line store opts) ;; Use the bootstrap Guile when requested. diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index b44aca099d..30b21028aa 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2015, 2016, 2017 Ludovic Courtès +# Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès # # This file is part of GNU Guix. # @@ -118,6 +118,18 @@ fi # in its profile (e.g., for 'gzip'), but we have to accept them. guix environment guix --bootstrap -n +# Try program transformation options. +mkdir "$tmpdir/emacs-36.8" +drv="`guix environment --ad-hoc emacs -n 2>&1 | grep 'emacs.*\.drv'`" +transformed_drv="`guix environment --ad-hoc emacs --with-source="$tmpdir/emacs-36.8" -n 2>&1 | grep 'emacs.*\.drv'`" +test -n "$drv" +test "$drv" != "$transformed_drv" +case "$transformed_drv" in + *-emacs-36.8.drv) true;; + *) false;; +esac +rmdir "$tmpdir/emacs-36.8" + if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then # Compute the build environment for the initial GNU Make. -- cgit v1.2.3 From 9b9de08477afe0ea519f916ad3d33c9720c3278d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Dec 2018 23:01:51 +0100 Subject: publish: Add a 'Cache-Control' header on /nar responses. Fixes . Reported by Chris Marusich . * guix/scripts/publish.scm (render-nar/cached): Add #:ttl and honor it. (make-request-handler): Pass #:ttl to 'render-nar/cached'. * tests/publish.scm ("with cache, uncompressed"): Pass "--ttl=42h" to 'guix publish'. Check 'Cache-Control' on narinfo response and on nar response. --- guix/scripts/publish.scm | 11 +++++++++-- tests/publish.scm | 17 +++++++++++++++-- 2 files changed, 24 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index c5326b33da..a236f3e45c 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -537,14 +537,19 @@ requested using POOL." (not-found request)))) (define* (render-nar/cached store cache request store-item - #:key (compression %no-compression)) + #:key ttl (compression %no-compression)) "Respond to REQUEST with a nar for STORE-ITEM. If the nar is in CACHE, -return it; otherwise, return 404." +return it; otherwise, return 404. When TTL is true, use it as the +'Cache-Control' expiration time." (let ((cached (nar-cache-file cache store-item #:compression compression))) (if (file-exists? cached) (values `((content-type . (application/octet-stream (charset . "ISO-8859-1"))) + ,@(if ttl + `((cache-control (max-age . ,ttl))) + '()) + ;; XXX: We're not returning the actual contents, deferring ;; instead to 'http-write'. This is a hack to work around ;; . @@ -819,6 +824,7 @@ blocking." %default-gzip-compression)))) (if cache (render-nar/cached store cache request store-item + #:ttl narinfo-ttl #:compression compression) (render-nar store request store-item #:compression compression))) @@ -829,6 +835,7 @@ blocking." (if (nar-path? components) (if cache (render-nar/cached store cache request store-item + #:ttl narinfo-ttl #:compression %no-compression) (render-nar store request store-item #:compression %no-compression)) diff --git a/tests/publish.scm b/tests/publish.scm index 0e793c1ee5..79a786e723 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -411,10 +411,12 @@ FileSize: ~a~%" (random-text)))) (test-equal "with cache, uncompressed" (list #t + (* 42 3600) ;TTL on narinfo `(("StorePath" . ,item) ("URL" . ,(string-append "nar/" (basename item))) ("Compression" . "none")) 200 ;nar/… + (* 42 3600) ;TTL on nar/… (path-info-nar-size (query-path-info %store item)) ;FileSize 404) ;nar/gzip/… @@ -423,7 +425,7 @@ FileSize: ~a~%" (let ((thread (with-separate-output-ports (call-with-new-thread (lambda () - (guix-publish "--port=6796" "-C2" + (guix-publish "--port=6796" "-C2" "--ttl=42h" (string-append "--cache=" cache))))))) (wait-until-ready 6796) (let* ((base "http://localhost:6796/") @@ -437,13 +439,19 @@ FileSize: ~a~%" (and (= 404 (response-code response)) (wait-for-file cached) - (let* ((body (http-get-port url)) + (let* ((response (http-get url)) + (body (http-get-port url)) (compressed (http-get (string-append base "nar/gzip/" (basename item)))) (uncompressed (http-get (string-append base "nar/" (basename item)))) (narinfo (recutils->alist body))) (list (file-exists? nar) + (match (assq-ref (response-headers response) + 'cache-control) + ((('max-age . ttl)) ttl) + (_ #f)) + (filter (lambda (item) (match item (("Compression" . _) #t) @@ -452,6 +460,11 @@ FileSize: ~a~%" (_ #f))) narinfo) (response-code uncompressed) + (match (assq-ref (response-headers uncompressed) + 'cache-control) + ((('max-age . ttl)) ttl) + (_ #f)) + (string->number (assoc-ref narinfo "FileSize")) (response-code compressed)))))))))) -- cgit v1.2.3