From 3dbf331942f11ee888ccbf849cacdd3a0ab971cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 3 Jul 2018 00:26:59 +0200 Subject: deduplication: Place link files under /gnu/store/.links. Previously they'd always be placed next to TO-REPLACE, which would lead to EPERM in some cases. * guix/store/deduplication.scm (replace-with-link): Add #:swap-directory parameter and honor it. Add call to 'make-file-writable'. Catch 'system-error' around 'rename-file'. (deduplicate): Pass #:swap-directory and remove uses of 'false-if-system-error'. * tests/store-deduplication.scm ("deduplicate"): Add 'chmod' call. --- tests/store-deduplication.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'tests') diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm index 2361723199..4ca2ec0f61 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm @@ -47,6 +47,10 @@ (define-module (test-store-deduplication) (lambda (port) (put-bytevector port data)))) identical) + ;; Make the parent of IDENTICAL read-only. This should not prevent + ;; deduplication for inserting its hard link. + (chmod (dirname (second identical)) #o544) + (call-with-output-file unique (lambda (port) (put-bytevector port (string->utf8 "This is unique.")))) -- cgit v1.2.3 From 25c7ff6a3ecbaa1e93b38d35c8cbff40b7f4edb8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 3 Jul 2018 10:52:55 +0200 Subject: syscalls: Define AT_SYMLINK_NOFOLLOW et al. * guix/build/syscalls.scm (AT_FDCWD, AT_SYMLINK_NOFOLLOW, AT_REMOVEDIR) (AT_SYMLINK_FOLLOW, AT_NO_AUTOMOUNT, AT_EMPTY_PATH): New variables. * tests/syscalls.scm ("utime with AT_SYMLINK_NOFOLLOW"): New test. --- guix/build/syscalls.scm | 17 +++++++++++++++++ tests/syscalls.scm | 13 +++++++++++++ 2 files changed, 30 insertions(+) (limited to 'tests') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 25726b885e..74cb675fcf 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -46,6 +46,14 @@ (define-module (guix build syscalls) MNT_DETACH MNT_EXPIRE UMOUNT_NOFOLLOW + + AT_FDCWD + AT_SYMLINK_NOFOLLOW + AT_REMOVEDIR + AT_SYMLINK_FOLLOW + AT_NO_AUTOMOUNT + AT_EMPTY_PATH + restart-on-EINTR mount-points swapon @@ -667,6 +675,15 @@ (define (free-disk-space file) (* (file-system-block-size fs) (file-system-blocks-available fs)))) +;; Flags for the *at command, notably the 'utime' procedure of libguile. +;; From . +(define AT_FDCWD -100) +(define AT_SYMLINK_NOFOLLOW #x100) +(define AT_REMOVEDIR #x200) +(define AT_SYMLINK_FOLLOW #x400) +(define AT_NO_AUTOMOUNT #x800) +(define AT_EMPTY_PATH #x1000) + ;;; ;;; Containers. diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 0d07280b99..3e267c9f01 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -60,6 +60,19 @@ (define temp-file (any (cute member <> (mount-points)) '("/" "/proc" "/sys" "/dev"))) +(false-if-exception (delete-file temp-file)) +(test-equal "utime with AT_SYMLINK_NOFOLLOW" + '(0 0) + (begin + ;; Test libguile's utime with AT_SYMLINK_NOFOLLOW, which libguile does not + ;; define as of Guile 2.2.4. + (symlink "/nowhere" temp-file) + (utime temp-file 0 0 0 0 AT_SYMLINK_NOFOLLOW) + (let ((st (lstat temp-file))) + (delete-file temp-file) + ;; Note: 'utimensat' does not change 'ctime'. + (list (stat:mtime st) (stat:atime st))))) + (test-assert "swapon, ENOENT/EPERM" (catch 'system-error (lambda () -- cgit v1.2.3 From ee75e80c05127020188b93d402d1d70b102eaacf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 5 Jul 2018 21:35:55 +0200 Subject: tests: Skip 'guix-pack.sh'. This works around a regression introduced in commit 66e9944e078cbb9e0d618377dd6df6e639640efa while waiting for a proper fix. * tests/guix-pack.sh: Add "exit 77". --- tests/guix-pack.sh | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'tests') diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index 917d52451c..bf367fa429 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -28,6 +28,11 @@ fi guix pack --version +# FIXME: Starting from commit 66e9944e078cbb9e0d618377dd6df6e639640efa, +# '--bootstrap' is mostly ineffective since 'guix pack' produces derivations +# that refer to guile-sqlite3 and libgcrypt. For now we just skip the test. +exit 77 + # Use --no-substitutes because we need to verify we can do this ourselves. GUIX_BUILD_OPTIONS="--no-substitutes" export GUIX_BUILD_OPTIONS -- cgit v1.2.3 From b24443bff9f9f3f36353eea2ef35e6dc3745a417 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 6 Jun 2018 19:14:39 +0200 Subject: guix: Add opam importer. * guix/scripts/import.scm (importers): Add opam. * guix/scripts/import/opam.scm: New file. * guix/import/opam.scm: New file. * tests/opam.scm: New file. * Makefile.am: Add them. * doc/guix.texi (Invoking guix import): Document it. --- Makefile.am | 3 + doc/guix.texi | 6 ++ guix/import/opam.scm | 193 +++++++++++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 2 +- guix/scripts/import/opam.scm | 92 +++++++++++++++++++++ tests/opam.scm | 118 ++++++++++++++++++++++++++ 6 files changed, 413 insertions(+), 1 deletion(-) create mode 100644 guix/import/opam.scm create mode 100644 guix/scripts/import/opam.scm create mode 100644 tests/opam.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 5dc04de35c..618d1653e4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -231,11 +231,13 @@ MODULES += \ guix/import/github.scm \ guix/import/gnome.scm \ guix/import/json.scm \ + guix/import/opam.scm \ guix/import/pypi.scm \ guix/import/stackage.scm \ guix/scripts/import/crate.scm \ guix/scripts/import/gem.scm \ guix/scripts/import/json.scm \ + guix/scripts/import/opam.scm \ guix/scripts/import/pypi.scm \ guix/scripts/import/stackage.scm \ guix/scripts/weather.scm @@ -382,6 +384,7 @@ if HAVE_GUILE_JSON SCM_TESTS += \ tests/pypi.scm \ + tests/opam.scm \ tests/cpan.scm \ tests/gem.scm \ tests/crate.scm diff --git a/doc/guix.texi b/doc/guix.texi index 7ce364b0af..a8e53a5308 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6661,6 +6661,12 @@ in Guix. @cindex crate Import metadata from the crates.io Rust package repository @uref{https://crates.io, crates.io}. + +@item opam +@cindex OPAM +@cindex OCaml +Import metadata from the @uref{https://opam.ocaml.org/, OPAM} package +repository used by the OCaml community. @end table The structure of the @command{guix import} code is modular. It would be diff --git a/guix/import/opam.scm b/guix/import/opam.scm new file mode 100644 index 0000000000..f252bdc31a --- /dev/null +++ b/guix/import/opam.scm @@ -0,0 +1,193 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Julien Lepiller +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix 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 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix 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 GNU Guix. If not, see . + +(define-module (guix import opam) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module ((ice-9 rdelim) #:select (read-line)) + #:use-module (srfi srfi-1) + #:use-module (web uri) + #:use-module (guix http-client) + #: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 (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 `()))) + +(define (ocaml-name->guix-name name) + (cond + ((equal? name "ocamlfind") "ocaml-findlib") + ((string-prefix? "ocaml" name) name) + ((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 (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))) + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch source-url temp) + `(package + (name ,(ocaml-name->guix-name name)) + (version ,version) + (source + (origin + (method url-fetch) + (uri ,source-url) + (sha256 (base32 ,(guix-hash-url temp))))) + (build-system ocaml-build-system) + ,@(if (null? inputs) + '() + `((inputs ,(list 'quasiquote inputs)))) + (home-page ,(assoc-ref metadata "homepage")) + (synopsis "") + (description "") + (license ,@(string->license (assoc-ref metadata "license"))))))))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index f8cb85700d..0b326e1049 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -75,7 +75,7 @@ (define %standard-import-options '()) ;;; (define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem" - "cran" "crate" "texlive" "json")) + "cran" "crate" "texlive" "json" "opam")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm new file mode 100644 index 0000000000..b549878742 --- /dev/null +++ b/guix/scripts/import/opam.scm @@ -0,0 +1,92 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Julien Lepiller +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix 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 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix 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 GNU Guix. If not, see . + +(define-module (guix scripts import opam) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import opam) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-opam)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import opam PACKAGE-NAME +Import and convert the opam package for PACKAGE-NAME.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import opam"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-opam . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (let ((sexp (opam->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp)) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/tests/opam.scm b/tests/opam.scm new file mode 100644 index 0000000000..26832174a8 --- /dev/null +++ b/tests/opam.scm @@ -0,0 +1,118 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Julien Lepiller +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix 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 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix 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 GNU Guix. If not, see . + +(define-module (test-opam) + #:use-module (guix import opam) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (guix tests) + #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which)) + #: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") + +(define test-opam-file +"opam-version: 1.2 +maintainer: \"Alice 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}%\" +] +build-test: [ + \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\" +] +depends: [ + \"alcotest\" {test & >= \"0.7.2\"} + \"ocamlbuild\" {build & >= \"0.9.2\"} +]") + +(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))))))) + +(test-end "opam") -- cgit v1.2.3 From 88388766f778d344699e7a8a0a4d970c403007e3 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Tue, 3 Jul 2018 23:28:42 +0300 Subject: import: gem: Add recursive import. * doc/guix.texi (Invoking guix import): Document gem recursive import. * guix/import/gem.scm (gem->guix-package): Return package and dependencies values. (gem-recursive-import): New procedure. * guix/scripts/import/gem.scm (show-help, %options): Add recursive option. (guix-import-gem): Use 'gem-recursive-import'. * tests/gem.scm (test-json): Rename to 'test-foo-json'. ("gem->guix-package"): Use 'test-foo-json'. (test-bar-json, test-bundler-json): New variables. ("gem-recursive-import"): New test. --- doc/guix.texi | 8 ++++ guix/import/gem.scm | 48 ++++++++++++-------- guix/scripts/import/gem.scm | 27 +++++++++-- tests/gem.scm | 108 ++++++++++++++++++++++++++++++++++++++++++-- 4 files changed, 163 insertions(+), 28 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index a8e53a5308..8026bea356 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6380,6 +6380,14 @@ The command below imports metadata for the @code{rails} Ruby package: guix import gem rails @end example +@table @code +@item --recursive +@itemx -r +Traverse the dependency graph of the given upstream package recursively +and generate package expressions for all those packages that are not yet +in Guix. +@end table + @item cpan @cindex CPAN Import metadata from @uref{https://www.metacpan.org/, MetaCPAN}@footnote{This diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 646163fb7b..ea576b5e4a 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson ;;; Copyright © 2016 Ben Woodcroft +;;; Copyright © 2018 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,7 +34,8 @@ (define-module (guix import gem) #:use-module (guix base32) #:use-module (guix build-system ruby) #:export (gem->guix-package - %gem-updater)) + %gem-updater + gem-recursive-import)) (define (rubygems-fetch name) "Return an alist representation of the RubyGems metadata for the package NAME, @@ -115,29 +117,30 @@ (define (make-gem-sexp name version hash home-page synopsis description ((license) (license->symbol license)) (_ `(list ,@(map license->symbol licenses))))))) -(define* (gem->guix-package package-name #:optional version) +(define* (gem->guix-package package-name #:optional (repo 'rubygems) version) "Fetch the metadata for PACKAGE-NAME from rubygems.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let ((package (rubygems-fetch package-name))) (and package - (let ((name (assoc-ref package "name")) - (version (assoc-ref package "version")) - (hash (assoc-ref package "sha")) - (synopsis (assoc-ref package "info")) ; nothing better to use - (description (beautify-description - (assoc-ref package "info"))) - (home-page (assoc-ref package "homepage_uri")) - (dependencies (map (lambda (dep) - (let ((name (assoc-ref dep "name"))) - (if (string=? name "bundler") - "bundler" ; special case, no prefix - (ruby-package-name name)))) - (assoc-ref* package "dependencies" - "runtime"))) - (licenses (map string->license - (assoc-ref package "licenses")))) - (make-gem-sexp name version hash home-page synopsis - description dependencies licenses))))) + (let* ((name (assoc-ref package "name")) + (version (assoc-ref package "version")) + (hash (assoc-ref package "sha")) + (synopsis (assoc-ref package "info")) ; nothing better to use + (description (beautify-description + (assoc-ref package "info"))) + (home-page (assoc-ref package "homepage_uri")) + (dependencies-names (map (lambda (dep) (assoc-ref dep "name")) + (assoc-ref* package "dependencies" "runtime"))) + (dependencies (map (lambda (dep) + (if (string=? dep "bundler") + "bundler" ; special case, no prefix + (ruby-package-name dep))) + dependencies-names)) + (licenses (map string->license + (assoc-ref package "licenses")))) + (values (make-gem-sexp name version hash home-page synopsis + description dependencies licenses) + dependencies-names))))) (define (guix-package->gem-name package) "Given a PACKAGE built from rubygems.org, return the name of the @@ -192,3 +195,8 @@ (define %gem-updater (description "Updater for RubyGem packages") (pred gem-package?) (latest latest-release))) + +(define* (gem-recursive-import package-name #:optional version) + (recursive-import package-name '() + #:repo->guix-package gem->guix-package + #:guix-name ruby-package-name)) diff --git a/guix/scripts/import/gem.scm b/guix/scripts/import/gem.scm index 349a0a072a..b6d9ccaae4 100644 --- a/guix/scripts/import/gem.scm +++ b/guix/scripts/import/gem.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson +;;; Copyright © 2018 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ (define-module (guix scripts import gem) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-gem)) @@ -44,6 +46,9 @@ (define (show-help) -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) + (display (G_ " + -r, --recursive generate package expressions for all Gem packages\ + that are not yet in Guix")) (newline) (show-bug-report-information)) @@ -56,6 +61,9 @@ (define %options (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import pypi"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -81,11 +89,20 @@ (define (parse-options) (reverse opts)))) (match args ((package-name) - (let ((sexp (gem->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (gem-recursive-import package-name 'rubygems)))) + (let ((sexp (gem->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/tests/gem.scm b/tests/gem.scm index a39e8ba514..4220170ff0 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson ;;; Copyright © 2016 Ricardo Wurmus +;;; Copyright © 2018 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,10 +24,11 @@ (define-module (test-gem) #:use-module (guix hash) #:use-module (guix tests) #:use-module ((guix build utils) #:select (delete-file-recursively)) + #:use-module (srfi srfi-41) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) -(define test-json +(define test-foo-json "{ \"name\": \"foo\", \"version\": \"1.0.0\", @@ -42,6 +44,34 @@ (define test-json \"licenses\": [\"MIT\", \"Apache 2.0\"] }") +(define test-bar-json + "{ + \"name\": \"bar\", + \"version\": \"1.0.0\", + \"sha\": \"f3676eafca9987cb5fe263df1edf2538bf6dafc712b30e17be3543a9680547a8\", + \"info\": \"Another cool gem\", + \"homepage_uri\": \"https://example.com\", + \"dependencies\": { + \"runtime\": [ + { \"name\": \"bundler\" }, + ] + }, + \"licenses\": [\"MIT\", \"Apache 2.0\"] +}") + +(define test-bundler-json + "{ + \"name\": \"bundler\", + \"version\": \"1.14.2\", + \"sha\": \"3bb53e03db0a8008161eb4c816ccd317120d3c415ba6fee6f90bbc7f7eec8690\", + \"info\": \"Ruby gem bundler\", + \"homepage_uri\": \"https://bundler.io/\", + \"dependencies\": { + \"runtime\": [] + }, + \"licenses\": [\"MIT\"] +}") + (test-begin "gem") (test-assert "gem->guix-package" @@ -50,8 +80,8 @@ (define test-json (lambda (url . rest) (match url ("https://rubygems.org/api/v1/gems/foo.json" - (values (open-input-string test-json) - (string-length test-json))) + (values (open-input-string test-foo-json) + (string-length test-foo-json))) (_ (error "Unexpected URL: " url))))) (match (gem->guix-package "foo") (('package @@ -76,4 +106,76 @@ (define test-json (x (pk 'fail x #f))))) +(test-assert "gem-recursive-import" + ;; Replace network resources with sample data. + (mock ((guix http-client) http-fetch + (lambda (url . rest) + (match url + ("https://rubygems.org/api/v1/gems/foo.json" + (values (open-input-string test-foo-json) + (string-length test-foo-json))) + ("https://rubygems.org/api/v1/gems/bar.json" + (values (open-input-string test-bar-json) + (string-length test-bar-json))) + ("https://rubygems.org/api/v1/gems/bundler.json" + (values (open-input-string test-bundler-json) + (string-length test-bundler-json))) + (_ (error "Unexpected URL: " url))))) + (match (stream->list (gem-recursive-import "foo")) + ((('package + ('name "ruby-foo") + ('version "1.0.0") + ('source + ('origin + ('method 'url-fetch) + ('uri ('rubygems-uri "foo" 'version)) + ('sha256 + ('base32 + "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk")))) + ('build-system 'ruby-build-system) + ('propagated-inputs + ('quasiquote + (("bundler" ('unquote 'bundler)) + ("ruby-bar" ('unquote 'ruby-bar))))) + ('synopsis "A cool gem") + ('description "This package provides a cool gem") + ('home-page "https://example.com") + ('license ('list 'license:expat 'license:asl2.0))) + ('package + ('name "ruby-bundler") + ('version "1.14.2") + ('source + ('origin + ('method 'url-fetch) + ('uri ('rubygems-uri "bundler" 'version)) + ('sha256 + ('base32 + "1446xiz7zg0bz7kgx9jv84y0s4hpsg61dj5l3qb0i00avc1kxd9v")))) + ('build-system 'ruby-build-system) + ('synopsis "Ruby gem bundler") + ('description "Ruby gem bundler") + ('home-page "https://bundler.io/") + ('license 'license:expat)) + ('package + ('name "ruby-bar") + ('version "1.0.0") + ('source + ('origin + ('method 'url-fetch) + ('uri ('rubygems-uri "bar" 'version)) + ('sha256 + ('base32 + "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk")))) + ('build-system 'ruby-build-system) + ('propagated-inputs + ('quasiquote + (('"bundler" ('unquote 'bundler))))) + ('synopsis "Another cool gem") + ('description "Another cool gem") + ('home-page "https://example.com") + ('license ('list 'license:expat 'license:asl2.0)))) + #t) + (x + (pk 'fail x #f))))) + (test-end "gem") -- cgit v1.2.3 From e39a44f34010e4439fc3fc4925b3f26b7ca6d719 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Thu, 12 Jul 2018 14:17:08 +0200 Subject: import: hackage: Evaluate "-any" and "-none" version comparison operators. * guix/import/cabal.scm (eval-cabal): Modify. * tests/hackage.scm (test-cabal-4): New variable and test. (test-cabal-5): New variable and test. (test-cabal-6): New variable and test. --- guix/import/cabal.scm | 2 ++ tests/hackage.scm | 71 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 73 insertions(+) (limited to 'tests') diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index cd0a2953c6..4cd09cac29 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -754,6 +754,8 @@ (define (impl haskell) ((string= spec-op ">") (version>? comp-ver spec-ver)) ((string= spec-op "<=") (not (version>? comp-ver spec-ver))) ((string= spec-op "<") (not (version>=? comp-ver spec-ver))) + ((string= spec-op "-any") #t) + ((string= spec-op "-none") #f) (else (raise (condition (&message (message "Failed to evaluate 'impl' test.")))))) diff --git a/tests/hackage.scm b/tests/hackage.scm index a4de8be91e..e17851a213 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -69,6 +69,65 @@ (define test-cabal-3 mtl >= 2.0 && < 3 ") +;; Check "-any", "-none" when name is different. +(define test-cabal-4 + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +library + if impl(ghcjs -any) + Build-depends: ghc-a + if impl(ghc>=7.2&&<7.6) + Build-depends: ghc-b + if impl(ghc == 7.8) + Build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +") + +;; Check "-any", "-none". +(define test-cabal-5 + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +library + if impl(ghc == 7.8) + Build-depends: + HTTP >= 4000.2.5 && < 4000.3, + if impl(ghc -any) + Build-depends: mtl >= 2.0 && < 3 + if impl(ghc>=7.2&&<7.6) + Build-depends: ghc-b +") + +;; Check "custom-setup". +(define test-cabal-6 + "name: foo +build-type: Custom +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +custom-setup + setup-depends: base >= 4.7 && < 5, + Cabal >= 1.24, + haskell-gi == 0.21.* +library + if impl(ghc>=7.2&&<7.6) + Build-depends: ghc-b + if impl(ghc == 7.8) + Build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +") + ;; A fragment of a real Cabal file with minor modification to check precedence ;; of 'and' over 'or', missing final newline, spaces between keywords and ;; parentheses and between key and column. @@ -139,6 +198,18 @@ (define* (eval-test-with-cabal test-cabal #:key (cabal-environment '())) (eval-test-with-cabal test-cabal-3 #:cabal-environment '(("impl" . "ghc-7.8")))) +(test-assert "hackage->guix-package test 4" + (eval-test-with-cabal test-cabal-4 + #:cabal-environment '(("impl" . "ghc-7.8")))) + +(test-assert "hackage->guix-package test 5" + (eval-test-with-cabal test-cabal-5 + #:cabal-environment '(("impl" . "ghc-7.8")))) + +(test-assert "hackage->guix-package test 6" + (eval-test-with-cabal test-cabal-6 + #:cabal-environment '(("impl" . "ghc-7.8")))) + (test-assert "read-cabal test 1" (match (call-with-input-string test-read-cabal-1 read-cabal) ((("name" ("test-me")) -- cgit v1.2.3 From bc6e291ef0b3c71c07e50d88d7764e5dd334e8b1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Jul 2018 14:33:11 +0200 Subject: guix package: Use relative symlinks to generations. Reported by Roel Janssen at . * guix/profiles.scm (switch-to-generation): Use (basename generation) as the symlink target. * guix/scripts/package.scm (build-and-use-profile): Likewise, use (basename name) as the symlink target. * tests/guix-package.sh: Adjust --roll-back test accordingly. Add explicitly test with '-p foo/prof'. --- guix/profiles.scm | 2 +- guix/scripts/package.scm | 2 +- tests/guix-package.sh | 12 +++++++++++- 3 files changed, 13 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index d2a794b187..f34f4fcff6 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1521,7 +1521,7 @@ (define (switch-to-generation profile number) (profile profile) (generation number))))) (else - (switch-symlinks profile generation) + (switch-symlinks profile (basename generation)) current)))) (define (switch-to-previous-generation profile) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 29829f52c8..b38a55d01c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -190,7 +190,7 @@ (define* (build-and-use-profile store profile manifest (let* ((entries (manifest-entries manifest)) (count (length entries))) (switch-symlinks name prof) - (switch-symlinks profile name) + (switch-symlinks profile (basename name)) (unless (string=? profile %current-profile) (register-gc-root store name)) (format #t (N_ "~a package in profile~%" diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 3b3fa35cd8..cef3b3452e 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -185,6 +185,16 @@ grep -E 'emacs[[:blank:]]+42\.5\.9rc7[[:blank:]]+.*-emacs-42.5.9rc7' \ rm "$emacs_tarball" "$tmpfile" rmdir "$module_dir" +# Profiles with a relative file name. Make sure we don't create dangling +# symlinks--see bug report at +# . +mkdir -p "$module_dir/foo" +( cd "$module_dir" ; \ + guix package --bootstrap -i guile-bootstrap -p foo/prof ) +test -f "$module_dir/foo/prof/bin/guile" +rm "$module_dir/foo"/* +rmdir "$module_dir/foo" +rmdir "$module_dir" # # Try with the default profile. @@ -215,7 +225,7 @@ do guix package --bootstrap --roll-back ! test -f "$HOME/.guix-profile/bin" ! test -f "$HOME/.guix-profile/lib" - test "`readlink "$default_profile"`" = "$default_profile-0-link" + test "`readlink "$default_profile"`" = "`basename $default_profile-0-link`" done # Check whether '-p ~/.guix-profile' makes any difference. -- cgit v1.2.3 From 2ca299caf64489f4e1e665ec1158fb0309b0b565 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Jul 2018 14:18:36 +0200 Subject: Add (guix inferior) and (guix scripts repl). * guix/inferior.scm, guix/scripts/repl.scm, tests/inferior.scm: New files. * Makefile.am (MODULES): Add 'guix/scripts/repl.scm' and 'guix/inferior.scm'. (SCM_TESTS): Add 'tests/inferior.scm'. * doc/guix.texi (Invoking guix repl): New node. --- Makefile.am | 3 + doc/guix.texi | 53 ++++++++++++++ guix/inferior.scm | 197 +++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/repl.scm | 199 ++++++++++++++++++++++++++++++++++++++++++++++++++ tests/inferior.scm | 69 +++++++++++++++++ 5 files changed, 521 insertions(+) create mode 100644 guix/inferior.scm create mode 100644 guix/scripts/repl.scm create mode 100644 tests/inferior.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 618d1653e4..134ab0f142 100644 --- a/Makefile.am +++ b/Makefile.am @@ -85,6 +85,7 @@ MODULES = \ guix/nar.scm \ guix/derivations.scm \ guix/grafts.scm \ + guix/inferior.scm \ guix/gnu-maintenance.scm \ guix/self.scm \ guix/upstream.scm \ @@ -200,6 +201,7 @@ MODULES = \ guix/scripts/substitute.scm \ guix/scripts/authenticate.scm \ guix/scripts/refresh.scm \ + guix/scripts/repl.scm \ guix/scripts/system.scm \ guix/scripts/system/search.scm \ guix/scripts/lint.scm \ @@ -357,6 +359,7 @@ SCM_TESTS = \ tests/profiles.scm \ tests/search-paths.scm \ tests/syscalls.scm \ + tests/inferior.scm \ tests/gremlin.scm \ tests/bournish.scm \ tests/lint.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index eaec4c422b..7a5ddefd4e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -166,6 +166,7 @@ Programming Interface * Derivations:: Low-level interface to package derivations. * The Store Monad:: Purely functional interface to the store. * G-Expressions:: Manipulating build expressions. +* Invoking guix repl:: Fiddling with Guix interactively. Defining Packages @@ -3267,6 +3268,7 @@ package definitions. * Derivations:: Low-level interface to package derivations. * The Store Monad:: Purely functional interface to the store. * G-Expressions:: Manipulating build expressions. +* Invoking guix repl:: Fiddling with Guix interactively. @end menu @node Defining Packages @@ -5544,6 +5546,57 @@ corresponding to @var{obj} for @var{system}, cross-compiling for has an associated gexp compiler, such as a @code{}. @end deffn +@node Invoking guix repl +@section Invoking @command{guix repl} + +@cindex REPL, read-eval-print loop +The @command{guix repl} command spawns a Guile @dfn{read-eval-print loop} +(REPL) for interactive programming (@pxref{Using Guile Interactively,,, guile, +GNU Guile Reference Manual}). Compared to just launching the @command{guile} +command, @command{guix repl} guarantees that all the Guix modules and all its +dependencies are available in the search path. You can use it this way: + +@example +$ guix repl +scheme@@(guile-user)> ,use (gnu packages base) +scheme@@(guile-user)> coreutils +$1 = # +@end example + +@cindex inferiors +In addition, @command{guix repl} implements a simple machine-readable REPL +protocol for use by @code{(guix inferior)}, a facility to interact with +@dfn{inferiors}, separate processes running a potentially different revision +of Guix. + +The available options are as follows: + +@table @code +@item --type=@var{type} +@itemx -t @var{type} +Start a REPL of the given @var{TYPE}, which can be one of the following: + +@table @code +@item guile +This is default, and it spawns a standard full-featured Guile REPL. +@item machine +Spawn a REPL that uses the machine-readable protocol. This is the protocol +that the @code{(guix inferior)} module speaks. +@end table + +@item --listen=@var{endpoint} +By default, @command{guix repl} reads from standard input and writes to +standard output. When this option is passed, it will instead listen for +connections on @var{endpoint}. Here are examples of valid options: + +@table @code +@item --listen=tcp:37146 +Accept connections on localhost on port 37146. + +@item --listen=unix:/tmp/socket +Accept connections on the Unix-domain socket @file{/tmp/socket}. +@end table +@end table @c ********************************************************************* @node Utilities diff --git a/guix/inferior.scm b/guix/inferior.scm new file mode 100644 index 0000000000..629c2c4313 --- /dev/null +++ b/guix/inferior.scm @@ -0,0 +1,197 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix 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 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix 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 GNU Guix. If not, see . + +(define-module (guix inferior) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:export (inferior? + open-inferior + close-inferior + inferior-eval + inferior-object? + + inferior-package? + inferior-package-name + inferior-package-version + + inferior-packages + inferior-package-synopsis + inferior-package-description)) + +;;; Commentary: +;;; +;;; This module provides a way to spawn Guix "inferior" processes and to talk +;;; to them. It allows us, from one instance of Guix, to interact with +;;; another instance of Guix coming from a different commit. +;;; +;;; Code: + +;; Inferior Guix process. +(define-record-type + (inferior pid socket version) + inferior? + (pid inferior-pid) + (socket inferior-socket) + (version inferior-version)) ;REPL protocol version + +(define (inferior-pipe directory command) + "Return an input/output pipe on the Guix instance in DIRECTORY. This runs +'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if +it's an old Guix." + (let ((pipe (with-error-to-port (%make-void-port "w") + (lambda () + (open-pipe* OPEN_BOTH + (string-append directory "/" command) + "repl" "-t" "machine"))))) + (if (eof-object? (peek-char pipe)) + (begin + (close-pipe pipe) + + ;; Older versions of Guix didn't have a 'guix repl' command, so + ;; emulate it. + (open-pipe* OPEN_BOTH "guile" + "-L" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/lib/guile/" + (effective-version) "/site-ccache") + "-c" + (object->string + `(begin + (primitive-load ,(search-path %load-path + "guix/scripts/repl.scm")) + ((@ (guix scripts repl) machine-repl)))))) + pipe))) + +(define* (open-inferior directory #:key (command "bin/guix")) + "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or +equivalent. Return #f if the inferior could not be launched." + (define pipe + (inferior-pipe directory command)) + + (setvbuf pipe _IOLBF) + (match (read pipe) + (('repl-version 0 rest ...) + (let ((result (inferior 'pipe pipe (cons 0 rest)))) + (inferior-eval '(use-modules (guix)) result) + (inferior-eval '(use-modules (gnu)) result) + (inferior-eval '(define %package-table (make-hash-table)) + result) + result)) + (_ + #f))) + +(define (close-inferior inferior) + "Close INFERIOR." + (close-pipe (inferior-socket inferior))) + +;; Non-self-quoting object of the inferior. +(define-record-type + (inferior-object address appearance) + inferior-object? + (address inferior-object-address) + (appearance inferior-object-appearance)) + +(define (write-inferior-object object port) + (match object + (($ _ appearance) + (format port "#" appearance)))) + +(set-record-type-printer! write-inferior-object) + +(define (inferior-eval exp inferior) + "Evaluate EXP in INFERIOR." + (define sexp->object + (match-lambda + (('value value) + value) + (('non-self-quoting address string) + (inferior-object address string)))) + + (write exp (inferior-socket inferior)) + (newline (inferior-socket inferior)) + (match (read (inferior-socket inferior)) + (('values objects ...) + (apply values (map sexp->object objects))) + (('exception key objects ...) + (apply throw key (map sexp->object objects))))) + + +;;; +;;; Inferior packages. +;;; + +(define-record-type + (inferior-package inferior name version id) + inferior-package? + (inferior inferior-package-inferior) + (name inferior-package-name) + (version inferior-package-version) + (id inferior-package-id)) + +(define (write-inferior-package package port) + (match package + (($ _ name version) + (format port "#" + name version + (number->string (object-address package) 16))))) + +(set-record-type-printer! write-inferior-package) + +(define (inferior-packages inferior) + "Return the list of packages known to INFERIOR." + (let ((result (inferior-eval + '(fold-packages (lambda (package result) + (let ((id (object-address package))) + (hashv-set! %package-table id package) + (cons (list (package-name package) + (package-version package) + id) + result))) + '()) + inferior))) + (map (match-lambda + ((name version id) + (inferior-package inferior name version id))) + result))) + +(define (inferior-package-field package getter) + "Return the field of PACKAGE, an inferior package, accessed with GETTER." + (let ((inferior (inferior-package-inferior package)) + (id (inferior-package-id package))) + (inferior-eval `(,getter (hashv-ref %package-table ,id)) + inferior))) + +(define* (inferior-package-synopsis package #:key (translate? #t)) + "Return the Texinfo synopsis of PACKAGE, an inferior package. When +TRANSLATE? is true, translate it to the current locale's language." + (inferior-package-field package + (if translate? + '(compose (@ (guix ui) P_) package-synopsis) + 'package-synopsis))) + +(define* (inferior-package-description package #:key (translate? #t)) + "Return the Texinfo description of PACKAGE, an inferior package. When +TRANSLATE? is true, translate it to the current locale's language." + (inferior-package-field package + (if translate? + '(compose (@ (guix ui) P_) package-description) + 'package-description))) diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm new file mode 100644 index 0000000000..b157833a49 --- /dev/null +++ b/guix/scripts/repl.scm @@ -0,0 +1,199 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix 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 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix 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 GNU Guix. If not, see . + +(define-module (guix scripts repl) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (gnu packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:autoload (system repl repl) (start-repl) + #:autoload (system repl server) + (make-tcp-server-socket make-unix-domain-server-socket) + #:export (machine-repl + guix-repl)) + +;;; Commentary: +;;; +;;; This command provides a Guile REPL + +(define %default-options + `((type . guile))) + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix repl"))) + (option '(#\t "type") #t #f + (lambda (opt name arg result) + (alist-cons 'type (string->symbol arg) result))) + (option '("listen") #t #f + (lambda (opt name arg result) + (alist-cons 'listen arg result))))) + + +(define (show-help) + (display (G_ "Usage: guix repl [OPTIONS...] +Start a Guile REPL in the Guix execution environment.\n")) + (display (G_ " + -t, --type=TYPE start a REPL of the given TYPE")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (self-quoting? x) + "Return #t if X is self-quoting." + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? pair? null? vector? + bytevector? number? boolean?))) + +(define user-module + ;; Module where we execute user code. + (let ((module (resolve-module '(guix-user) #f #f #:ensure #t))) + (beautify-user-module! module) + module)) + +(define* (machine-repl #:optional + (input (current-input-port)) + (output (current-output-port))) + "Run a machine-usable REPL over ports INPUT and OUTPUT. + +The protocol of this REPL is meant to be machine-readable and provides proper +support to represent multiple-value returns, exceptions, objects that lack a +read syntax, and so on. As such it is more convenient and robust than parsing +Guile's REPL prompt." + (define (value->sexp value) + (if (self-quoting? value) + `(value ,value) + `(non-self-quoting ,(object-address value) + ,(object->string value)))) + + (write `(repl-version 0 0) output) + (newline output) + (force-output output) + + (let loop () + (match (read input) + ((? eof-object?) #t) + (exp + (catch #t + (lambda () + (let ((results (call-with-values + (lambda () + + (primitive-eval exp)) + list))) + (write `(values ,@(map value->sexp results)) + output) + (newline output) + (force-output output))) + (lambda (key . args) + (write `(exception ,key ,@(map value->sexp args))) + (newline output) + (force-output output))) + (loop))))) + +(define (call-with-connection spec thunk) + "Dynamically-bind the current input and output ports according to SPEC and +call THUNK." + (if (not spec) + (thunk) + + ;; Note: the "PROTO:" prefix in SPEC is here so that we can eventually + ;; parse things like "fd:123" in a non-ambiguous way. + (match (string-index spec #\:) + (#f + (leave (G_ "~A: invalid listen specification~%") spec)) + (index + (let ((protocol (string-take spec index)) + (address (string-drop spec (+ index 1)))) + (define socket + (match protocol + ("tcp" + (make-tcp-server-socket #:port (string->number address))) + ("unix" + (make-unix-domain-server-socket #:path address)) + (_ + (leave (G_ "~A: unsupported protocol family~%") + protocol)))) + + (listen socket 10) + (let loop () + (match (accept socket) + ((connection . address) + (if (= AF_UNIX (sockaddr:fam address)) + (info (G_ "accepted connection~%")) + (info (G_ "accepted connection from ~a~%") + (inet-ntop (sockaddr:fam address) + (sockaddr:addr address)))) + (dynamic-wind + (const #t) + (lambda () + (parameterize ((current-input-port connection) + (current-output-port connection)) + (thunk))) + (lambda () + (false-if-exception (close-port connection)) + (info (G_ "connection closed~%")))))) + (loop))))))) + + +(define (guix-repl . args) + (define opts + ;; Return the list of package names. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (G_ "~A: extraneous argument~%") arg)) + %default-options)) + + (with-error-handling + (let ((type (assoc-ref opts 'type))) + (call-with-connection (assoc-ref opts 'listen) + (lambda () + (case type + ((guile) + (save-module-excursion + (lambda () + (set-current-module user-module) + (start-repl)))) + ((machine) + (machine-repl)) + (else + (leave (G_ "~a: unknown type of REPL~%") type)))))))) + +;; Local Variables: +;; eval: (put 'call-with-connection 'scheme-indent-function 1) +;; End: diff --git a/tests/inferior.scm b/tests/inferior.scm new file mode 100644 index 0000000000..5e0f8ae66e --- /dev/null +++ b/tests/inferior.scm @@ -0,0 +1,69 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix 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 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix 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 GNU Guix. If not, see . + +(define-module (test-inferior) + #:use-module (guix inferior) + #:use-module (guix packages) + #:use-module (gnu packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(define %top-srcdir + (dirname (search-path %load-path "guix.scm"))) + +(define %top-builddir + (dirname (search-path %load-compiled-path "guix.go"))) + + +(test-begin "inferior") + +(test-equal "open-inferior" + '(42 #t) + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (and (inferior? inferior) + (let ((a (inferior-eval '(apply * '(6 7)) inferior)) + (b (inferior-eval '(@ (gnu packages base) coreutils) + inferior))) + (close-inferior inferior) + (list a (inferior-object? b)))))) + +(test-equal "inferior-packages" + (take (sort (fold-packages (lambda (package lst) + (alist-cons (package-name package) + (package-version package) + lst)) + '()) + (lambda (x y) + (string Date: Fri, 13 Jul 2018 15:53:25 -0400 Subject: tests: Don't rely on temporary directories being permanent. * tests/gexp.scm ("gexp->script #:module-path", "program-file #:module-path"): Use run-with-store. --- tests/gexp.scm | 56 +++++++++++++++++++++++++++++--------------------------- 1 file changed, 29 insertions(+), 27 deletions(-) (limited to 'tests') diff --git a/tests/gexp.scm b/tests/gexp.scm index 83fe811546..391a0f8be5 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -948,7 +948,7 @@ (define shebang (return (and (zero? (close-pipe pipe)) (= (expt n 2) (string->number str))))))) -(test-assertm "gexp->script #:module-path" +(test-assert "gexp->script #:module-path" (call-with-temporary-directory (lambda (directory) (define str @@ -961,23 +961,24 @@ (define str (define-public %fake! ,str)) port))) - (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32)) - (gexp (begin - (use-modules (guix base32)) - (write (list %load-path - %fake!)))))) - (drv (gexp->script "guile-thing" exp - #:guile %bootstrap-guile - #:module-path (list directory))) - (out -> (derivation->output-path drv)) - (done (built-derivations (list drv)))) - (let* ((pipe (open-input-pipe out)) - (data (read pipe))) - (return (and (zero? (close-pipe pipe)) - (match data - ((load-path str*) - (and (string=? str* str) - (not (member directory load-path)))))))))))) + (run-with-store %store + (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32)) + (gexp (begin + (use-modules (guix base32)) + (write (list %load-path + %fake!)))))) + (drv (gexp->script "guile-thing" exp + #:guile %bootstrap-guile + #:module-path (list directory))) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv)))) + (let* ((pipe (open-input-pipe out)) + (data (read pipe))) + (return (and (zero? (close-pipe pipe)) + (match data + ((load-path str*) + (and (string=? str* str) + (not (member directory load-path))))))))))))) (test-assertm "program-file" (let* ((n (random (expt 2 50))) @@ -996,7 +997,7 @@ (define-public %fake! ,str)) (return (and (zero? (close-pipe pipe)) (= n (string->number str))))))))) -(test-assertm "program-file #:module-path" +(test-assert "program-file #:module-path" (call-with-temporary-directory (lambda (directory) (define text (random-text)) @@ -1014,14 +1015,15 @@ (define-public %stupid-thing ,text)) (file (program-file "program" exp #:guile %bootstrap-guile #:module-path (list directory)))) - (mlet* %store-monad ((drv (lower-object file)) - (out -> (derivation->output-path drv))) - (mbegin %store-monad - (built-derivations (list drv)) - (let* ((pipe (open-input-pipe out)) - (str (get-string-all pipe))) - (return (and (zero? (close-pipe pipe)) - (string=? text str)))))))))) + (run-with-store %store + (mlet* %store-monad ((drv (lower-object file)) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((pipe (open-input-pipe out)) + (str (get-string-all pipe))) + (return (and (zero? (close-pipe pipe)) + (string=? text str))))))))))) (test-assertm "program-file & with-extensions" (let* ((exp (with-extensions (list %extension-package) -- cgit v1.2.3 From b94b698d4ed4bc478c56e507d53e5284d4f63073 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Jul 2018 19:28:07 +0200 Subject: serialization: Add 'write-file-tree'. * guix/serialization.scm (write-contents-from-port): New procedure. (write-contents): Write in terms of 'write-contents-from-port'. (filter/sort-directory-entries, write-file-tree): New procedures. (write-file): Rewrite in terms of 'write-file-tree'. * tests/nar.scm ("write-file-tree + restore-file"): New test. --- guix/serialization.scm | 140 ++++++++++++++++++++++++++++++++++++++----------- tests/nar.scm | 62 +++++++++++++++++++++- 2 files changed, 169 insertions(+), 33 deletions(-) (limited to 'tests') diff --git a/guix/serialization.scm b/guix/serialization.scm index b41a0a09d1..129374f541 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -47,6 +47,7 @@ (define-module (guix serialization) nar-read-error-token write-file + write-file-tree restore-file)) ;;; Comment: @@ -211,14 +212,19 @@ (define (call-with-binary-input-file file proc) (lambda () (close-port port)))))) - (write-string "contents" p) - (write-long-long size p) (call-with-binary-input-file file - ;; Use 'sendfile' when P is a file port. - (if (file-port? p) - (cut sendfile p <> size 0) - (cut dump <> p size))) - (write-padding size p)) + (lambda (input) + (write-contents-from-port input p size)))) + +(define (write-contents-from-port input output size) + "Write SIZE bytes from port INPUT to port OUTPUT." + (write-string "contents" output) + (write-long-long size output) + ;; Use 'sendfile' when both OUTPUT and INPUT are file ports. + (if (and (file-port? output) (file-port? input)) + (sendfile output input size 0) + (dump input output size)) + (write-padding size output)) (define (read-contents in out) "Read the contents of a file from the Nar at IN, write it to OUT, and return @@ -263,47 +269,113 @@ (define* (write-file file port sub-directories of FILE as needed. For each directory entry, call (SELECT? FILE STAT), where FILE is the entry's absolute file name and STAT is the result of 'lstat'; exclude entries for which SELECT? does not return true." + (write-file-tree file port + #:file-type+size + (lambda (file) + (let* ((stat (lstat file)) + (size (stat:size stat))) + (case (stat:type stat) + ((directory) + (values 'directory size)) + ((regular) + (values (if (zero? (logand (stat:mode stat) + #o100)) + 'regular + 'executable) + size)) + (else + (values (stat:type stat) size))))) ;bah! + #:file-port (cut open-file <> "r0b") + #:symlink-target readlink + + #:directory-entries + (lambda (directory) + ;; 'scandir' defaults to 'string-locale '("." ".."))) + string '("." "..")) lst) + string '("." ".."))) string +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -152,6 +152,66 @@ (define %test-dir (test-begin "nar") +(test-assert "write-file-tree + restore-file" + (let* ((file1 (search-path %load-path "guix.scm")) + (file2 (search-path %load-path "guix/base32.scm")) + (file3 "#!/bin/something") + (output (string-append %test-dir "/output"))) + (dynamic-wind + (lambda () #t) + (lambda () + (define-values (port get-bytevector) + (open-bytevector-output-port)) + (write-file-tree "root" port + #:file-type+size + (match-lambda + ("root" + (values 'directory 0)) + ("root/foo" + (values 'regular (stat:size (stat file1)))) + ("root/lnk" + (values 'symlink 0)) + ("root/dir" + (values 'directory 0)) + ("root/dir/bar" + (values 'regular (stat:size (stat file2)))) + ("root/dir/exe" + (values 'executable (string-length file3)))) + #:file-port + (match-lambda + ("root/foo" (open-input-file file1)) + ("root/dir/bar" (open-input-file file2)) + ("root/dir/exe" (open-input-string file3))) + #:symlink-target + (match-lambda + ("root/lnk" "foo")) + #:directory-entries + (match-lambda + ("root" '("foo" "dir" "lnk")) + ("root/dir" '("bar" "exe")))) + (close-port port) + + (rm-rf %test-dir) + (mkdir %test-dir) + (restore-file (open-bytevector-input-port (get-bytevector)) + output) + (and (file=? (string-append output "/foo") file1) + (string=? (readlink (string-append output "/lnk")) + "foo") + (file=? (string-append output "/dir/bar") file2) + (string=? (call-with-input-file (string-append output "/dir/exe") + get-string-all) + file3) + (> (logand (stat:mode (lstat (string-append output "/dir/exe"))) + #o100) + 0) + (equal? '("." ".." "bar" "exe") + (scandir (string-append output "/dir"))) + (equal? '("." ".." "dir" "foo" "lnk") + (scandir output)))) + (lambda () + (false-if-exception (rm-rf %test-dir)))))) + (test-assert "write-file supports non-file output ports" (let ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) -- cgit v1.2.3 From 7f11efbac7a13898bd925d2ef1e9d26cb0e22ade Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Jul 2018 09:55:49 +0200 Subject: store: Add 'add-file-tree-to-store'. * guix/store.scm (%not-slash): New variable. (add-file-tree-to-store, interned-file-tree): New procedures. * tests/store.scm ("add-file-tree-to-store"): New test. --- guix/store.scm | 100 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/store.scm | 46 ++++++++++++++++++++++++++ 2 files changed, 146 insertions(+) (limited to 'tests') diff --git a/guix/store.scm b/guix/store.scm index cc5c24a77d..f41a1e2690 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -78,6 +78,7 @@ (define-module (guix store) add-data-to-store add-text-to-store add-to-store + add-file-tree-to-store binary-file build-things build @@ -137,6 +138,7 @@ (define-module (guix store) set-current-system text-file interned-file + interned-file-tree %store-prefix store-path @@ -951,6 +953,101 @@ (define add-to-store (hash-set! cache args path) path)))))) +(define %not-slash + (char-set-complement (char-set #\/))) + +(define* (add-file-tree-to-store server tree + #:key + (hash-algo "sha256") + (recursive? #t)) + "Add the given TREE to the store on SERVER. TREE must be an entry such as: + + (\"my-tree\" directory + (\"a\" regular (data \"hello\")) + (\"b\" symlink \"a\") + (\"c\" directory + (\"d\" executable (file \"/bin/sh\")))) + +This is a generalized version of 'add-to-store'. It allows you to reproduce +an arbitrary directory layout in the store without creating a derivation." + + ;; Note: The format of TREE was chosen to allow trees to be compared with + ;; 'equal?', which in turn allows us to memoize things. + + (define root + ;; TREE is a single entry. + (list tree)) + + (define basename + (match tree + ((name . _) name))) + + (define (lookup file) + (let loop ((components (string-tokenize file %not-slash)) + (tree root)) + (match components + ((basename) + (assoc basename tree)) + ((head . rest) + (loop rest + (match (assoc-ref tree head) + (('directory . entries) entries))))))) + + (define (file-type+size file) + (match (lookup file) + ((_ (and type (or 'directory 'symlink)) . _) + (values type 0)) + ((_ type ('file file)) + (values type (stat:size (stat file)))) + ((_ type ('data (? string? data))) + (values type (string-length data))) + ((_ type ('data (? bytevector? data))) + (values type (bytevector-length data))))) + + (define (file-port file) + (match (lookup file) + ((_ (or 'regular 'executable) content) + (match content + (('file (? string? file)) + (open-file file "r0b")) + (('data (? string? str)) + (open-input-string str)) + (('data (? bytevector? bv)) + (open-bytevector-input-port bv)))))) + + (define (symlink-target file) + (match (lookup file) + ((_ 'symlink target) target))) + + (define (directory-entries directory) + (match (lookup directory) + ((_ 'directory (names . _) ...) names))) + + (define cache + (nix-server-add-to-store-cache server)) + + (or (hash-ref cache tree) + (begin + ;; We don't use the 'operation' macro so we can use 'write-file-tree' + ;; instead of 'write-file'. + (record-operation 'add-to-store/tree) + (let ((port (nix-server-socket server))) + (write-int (operation-id add-to-store) port) + (write-string basename port) + (write-int 1 port) ;obsolete, must be #t + (write-int (if recursive? 1 0) port) + (write-string hash-algo port) + (write-file-tree basename port + #:file-type+size file-type+size + #:file-port file-port + #:symlink-target symlink-target + #:directory-entries directory-entries) + (let loop ((done? (process-stderr server))) + (or done? (loop (process-stderr server)))) + (let ((result (read-store-path port))) + (hash-set! cache tree result) + result))))) + (define build-things (let ((build (operation (build-things (string-list things) (integer mode)) @@ -1402,6 +1499,9 @@ (define* (interned-file file #:optional name #:select? select?) store))) +(define interned-file-tree + (store-lift add-file-tree-to-store)) + (define build ;; Monadic variant of 'build-things'. (store-lift build-things)) diff --git a/tests/store.scm b/tests/store.scm index afecec940a..47fab0df18 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -210,6 +210,52 @@ (define %store (valid-path? store path) (file-exists? path))))) +(test-equal "add-file-tree-to-store" + `(42 + ("." directory #t) + ("./bar" directory #t) + ("./foo" directory #t) + ("./foo/a" regular "file a") + ("./foo/b" symlink "a") + ("./foo/c" directory #t) + ("./foo/c/p" regular "file p") + ("./foo/c/q" directory #t) + ("./foo/c/q/x" regular "#!/bin/sh\nexit 42") + ("./foo/c/q/y" symlink "..") + ("./foo/c/q/z" directory #t)) + (let* ((tree `("file-tree" directory + ("foo" directory + ("a" regular (data "file a")) + ("b" symlink "a") + ("c" directory + ("p" regular (data ,(string->utf8 "file p"))) + ("q" directory + ("x" executable + (data "#!/bin/sh\nexit 42")) + ("y" symlink "..") + ("z" directory)))) + ("bar" directory))) + (result (add-file-tree-to-store %store tree))) + (cons (status:exit-val (system* (string-append result "/foo/c/q/x"))) + (with-directory-excursion result + (map (lambda (file) + (let ((type (stat:type (lstat file)))) + `(,file ,type + ,(match type + ((or 'regular 'executable) + (call-with-input-file file + get-string-all)) + ('symlink (readlink file)) + ('directory #t))))) + (find-files "." #:directories? #t)))))) + +(test-equal "add-file-tree-to-store, flat" + "Hello, world!" + (let* ((tree `("flat-file" regular (data "Hello, world!"))) + (result (add-file-tree-to-store %store tree))) + (and (file-exists? result) + (call-with-input-file result get-string-all)))) + (test-assert "references" (let* ((t1 (add-text-to-store %store "random1" (random-text))) -- cgit v1.2.3 From 8df2eca6b0915942ea087d7c5981514c532d47a2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Jul 2018 11:17:55 +0200 Subject: gexp: 'imported-files' no longer creates a derivation by default. * guix/gexp.scm (gexp->derivation): Add #:import-creates-derivation?. Pass #:derivation? to 'imported-modules' and 'compiled-modules'. In -L argument, check whether MODULES is a derivation. (%not-slash): New variable. (file-mapping->tree): New procedure. (imported-files): Rename to... (imported-files/derivation): ... this. (imported-files): New procedure. Rewrite in terms of 'interned-file-tree' when possible; add #:derivation? parameter. (imported-modules, compiled-modules): Add #:derivation? parameter and pass it to 'imported-files'. * guix/packages.scm (patch-and-repack): Pass #:import-creates-derivation? to 'gexp->derivation'. * tests/gexp.scm ("imported-files"): Adjust to no longer expect a derivation. --- guix/gexp.scm | 117 +++++++++++++++++++++++++++++++++++++++++++++++------- guix/packages.scm | 3 ++ tests/gexp.scm | 20 +++++----- 3 files changed, 115 insertions(+), 25 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 3414b81dc6..19d90f5eee 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -601,6 +601,12 @@ (define* (gexp->derivation name exp allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t) + + ;; TODO: This parameter is transitional; it's here + ;; to avoid a full rebuild. Remove it on the next + ;; rebuild cycle. + import-creates-derivation? + deprecation-warnings (script-name (string-append name "-builder"))) "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a @@ -695,6 +701,8 @@ (define (extension-flags extension) extensions)) (modules (if (pair? %modules) (imported-modules %modules + #:derivation? + import-creates-derivation? #:system system #:module-path module-path #:guile guile-for-build @@ -703,6 +711,8 @@ (define (extension-flags extension) (return #f))) (compiled (if (pair? %modules) (compiled-modules %modules + #:derivation? + import-creates-derivation? #:system system #:module-path module-path #:extensions extensions @@ -735,7 +745,9 @@ (define (extension-flags extension) "/bin/guile") `("--no-auto-compile" ,@(if (pair? %modules) - `("-L" ,(derivation->output-path modules) + `("-L" ,(if (derivation? modules) + (derivation->output-path modules) + modules) "-C" ,(derivation->output-path compiled)) '()) ,@(append-map extension-flags exts) @@ -1013,6 +1025,49 @@ (define (substitute-references exp substs) ;;; Module handling. ;;; +(define %not-slash + (char-set-complement (char-set #\/))) + +(define (file-mapping->tree mapping) + "Convert MAPPING, an alist like: + + ((\"guix/build/utils.scm\" . \"…/utils.scm\")) + +to a tree suitable for 'interned-file-tree'." + (let ((mapping (map (match-lambda + ((destination . source) + (cons (string-tokenize destination + %not-slash) + source))) + mapping))) + (fold (lambda (pair result) + (match pair + ((destination . source) + (let loop ((destination destination) + (result result)) + (match destination + ((file) + (let* ((mode (stat:mode (stat source))) + (type (if (zero? (logand mode #o100)) + 'regular + 'executable))) + (alist-cons file + `(,type (file ,source)) + result))) + ((file rest ...) + (let ((directory (assoc-ref result file))) + (alist-cons file + `(directory + ,@(loop rest + (match directory + (('directory . entries) entries) + (#f '())))) + (if directory + (alist-delete file result) + result))))))))) + '() + mapping))) + (define %utils-module ;; This file provides 'mkdir-p', needed to implement 'imported-files' and ;; other primitives below. Note: We give the file name relative to this @@ -1021,18 +1076,18 @@ (define %utils-module (local-file "build/utils.scm" "build-utils.scm")) -(define* (imported-files files - #:key (name "file-import") - (system (%current-system)) - (guile (%guile-for-build)) - - ;; XXX: The only reason we have - ;; #:deprecation-warnings is because (guix build - ;; utils), which we use here, relies on _IO*, which - ;; is deprecated in 2.2. On the next full-rebuild - ;; cycle, we should disable such warnings - ;; unconditionally. - (deprecation-warnings #f)) +(define* (imported-files/derivation files + #:key (name "file-import") + (system (%current-system)) + (guile (%guile-for-build)) + + ;; XXX: The only reason we have + ;; #:deprecation-warnings is because (guix + ;; build utils), which we use here, relies + ;; on _IO*, which is deprecated in 2.2. On + ;; the next full-rebuild cycle, we should + ;; disable such warnings unconditionally. + (deprecation-warnings #f)) "Return a derivation that imports FILES into STORE. FILES must be a list of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the resulting store path. FILE can be either a file name, or a file-like object, @@ -1081,8 +1136,38 @@ (define build (else '()))))) +(define* (imported-files files + #:key (name "file-import") + + ;; TODO: Remove this parameter on the next rebuild + ;; cycle. + (derivation? #f) + + ;; The following parameters make sense when creating + ;; an actual derivation. + (system (%current-system)) + (guile (%guile-for-build)) + (deprecation-warnings #f)) + "Import FILES into the store and return the resulting derivation or store +file name (a derivation is created if and only if some elements of FILES are +file-like objects and not local file names.) FILES must be a list +of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the +resulting store path. FILE can be either a file name, or a file-like object, +as returned by 'local-file' for example." + (if (or derivation? + (any (match-lambda + ((_ . (? struct? source)) #t) + (_ #f)) + files)) + (imported-files/derivation files #:name name + #:system system #:guile guile + #:deprecation-warnings deprecation-warnings) + (interned-file-tree `(,name directory + ,@(file-mapping->tree files))))) + (define* (imported-modules modules #:key (name "module-import") + (derivation? #f) ;TODO: remove on next rebuild (system (%current-system)) (guile (%guile-for-build)) (module-path %load-path) @@ -1106,12 +1191,15 @@ (define* (imported-modules modules (let ((f (module->source-file-name module))) (cons f (search-path* module-path f))))) modules))) - (imported-files files #:name name #:system system + (imported-files files #:name name + #:derivation? derivation? + #:system system #:guile guile #:deprecation-warnings deprecation-warnings))) (define* (compiled-modules modules #:key (name "module-import-compiled") + (derivation? #f) ;TODO: remove on next rebuild (system (%current-system)) (guile (%guile-for-build)) (module-path %load-path) @@ -1131,6 +1219,7 @@ (define build-utils-hack? (not (equal? module-path %load-path)))) (mlet %store-monad ((modules (imported-modules modules + #:derivation? derivation? #:system system #:guile guile #:module-path diff --git a/guix/packages.scm b/guix/packages.scm index c762fa7c39..a220b9c476 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -646,6 +646,9 @@ (define (first-file directory) (let ((name (tarxz-name original-file-name))) (gexp->derivation name build + ;; TODO: Remove this on the next rebuild cycle. + #:import-creates-derivation? #t + #:graft? #f #:system system #:deprecation-warnings #t ;to avoid a rebuild diff --git a/tests/gexp.scm b/tests/gexp.scm index 391a0f8be5..c89d0c4855 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -635,18 +635,16 @@ (define guile ,guile) "guix/derivations.scm")) ("p/q" . ,(search-path %load-path "guix.scm")) ("p/z" . ,(search-path %load-path "guix/store.scm")))) - (drv (imported-files files))) + (dir (imported-files files))) (mbegin %store-monad - (built-derivations (list drv)) - (let ((dir (derivation->output-path drv))) - (return - (every (match-lambda - ((path . source) - (equal? (call-with-input-file (string-append dir "/" path) - get-bytevector-all) - (call-with-input-file source - get-bytevector-all)))) - files)))))) + (return + (every (match-lambda + ((path . source) + (equal? (call-with-input-file (string-append dir "/" path) + get-bytevector-all) + (call-with-input-file source + get-bytevector-all)))) + files))))) (test-assertm "imported-files with file-like objects" (mlet* %store-monad ((plain -> (plain-file "foo" "bar!")) -- cgit v1.2.3 From e529d46828c359b449fc570bdc293fc12534647c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 16 Jul 2018 11:40:34 +0200 Subject: gexp: 'imported-files/derivation' can copy files instead of symlinking. * guix/gexp.scm (imported-files/derivation): Add #:symlink? and honor it. (imported-files): Pass #:symlink? to 'imported-files/derivation'. * tests/gexp.scm ("imported-files with file-like objects"): Add 'file=?' and use it instead of calling 'readlink'. --- guix/gexp.scm | 8 ++++++-- tests/gexp.scm | 11 +++++++---- 2 files changed, 13 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 19d90f5eee..ffc976d61b 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1078,6 +1078,7 @@ (define %utils-module (define* (imported-files/derivation files #:key (name "file-import") + (symlink? #f) (system (%current-system)) (guile (%guile-for-build)) @@ -1091,7 +1092,8 @@ (define* (imported-files/derivation files "Return a derivation that imports FILES into STORE. FILES must be a list of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the resulting store path. FILE can be either a file name, or a file-like object, -as returned by 'local-file' for example." +as returned by 'local-file' for example. If SYMLINK? is true, create symlinks +to the source files instead of copying them." (define file-pair (match-lambda ((final-path . (? string? file-name)) @@ -1114,7 +1116,8 @@ (define build (for-each (match-lambda ((final-path store-path) (mkdir-p (dirname final-path)) - (symlink store-path final-path))) + ((ungexp (if symlink? 'symlink 'copy-file)) + store-path final-path))) '(ungexp files))))) ;; TODO: Pass FILES as an environment variable so that BUILD remains @@ -1160,6 +1163,7 @@ (define* (imported-files files (_ #f)) files)) (imported-files/derivation files #:name name + #:symlink? derivation? #:system system #:guile guile #:deprecation-warnings deprecation-warnings) (interned-file-tree `(,name directory diff --git a/tests/gexp.scm b/tests/gexp.scm index c89d0c4855..b22e635805 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -652,16 +652,19 @@ (define guile ,guile) (files -> `(("a/b/c" . ,q-scm) ("p/q" . ,plain))) (drv (imported-files files))) + (define (file=? file1 file2) + ;; Assume deduplication is in place. + (= (stat:ino (lstat file1)) + (stat:ino (lstat file2)))) + (mbegin %store-monad (built-derivations (list drv)) (mlet %store-monad ((dir -> (derivation->output-path drv)) (plain* (text-file "foo" "bar!")) (q-scm* (interned-file q-scm "c"))) (return - (and (string=? (readlink (string-append dir "/a/b/c")) - q-scm*) - (string=? (readlink (string-append dir "/p/q")) - plain*))))))) + (and (file=? (string-append dir "/a/b/c") q-scm*) + (file=? (string-append dir "/p/q") plain*))))))) (test-equal "gexp-modules & ungexp" '((bar) (foo)) -- cgit v1.2.3 From c71cd4a61fc8085ccb17169aad826d6f9ee1718b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Jul 2018 17:08:53 +0200 Subject: hash: sha256 port now implements 'port-position'. * guix/hash.scm (open-sha256-port)[position]: New variable. [get-position]: New procedure. Pass it to 'make-custom-binary-output-port'. * tests/hash.scm ("open-sha256-port, hello"): Test 'port-position'. --- guix/hash.scm | 7 ++++++- tests/hash.scm | 4 ++-- 2 files changed, 8 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/hash.scm b/guix/hash.scm index 39834043e1..8d7ba21425 100644 --- a/guix/hash.scm +++ b/guix/hash.scm @@ -101,6 +101,7 @@ (define sha256-md (open-sha256-md)) (define digest #f) + (define position 0) (define (finalize!) (let ((ptr (md-read sha256-md 0))) @@ -114,14 +115,18 @@ (define (write! bv offset len) 0) (let ((ptr (bytevector->pointer bv offset))) (md-write sha256-md ptr len) + (set! position (+ position len)) len))) + (define (get-position) + position) + (define (close) (unless digest (finalize!))) (values (make-custom-binary-output-port "sha256" - write! #f #f + write! get-position #f close) (lambda () (unless digest diff --git a/tests/hash.scm b/tests/hash.scm index da87616eec..47dff3915b 100644 --- a/tests/hash.scm +++ b/tests/hash.scm @@ -64,12 +64,12 @@ (define %hello-sha256 (get))) (test-equal "open-sha256-port, hello" - %hello-sha256 + (list %hello-sha256 (string-length "hello world")) (let-values (((port get) (open-sha256-port))) (put-bytevector port (string->utf8 "hello world")) (force-output port) - (get))) + (list (get) (port-position port)))) (test-assert "port-sha256" (let* ((file (search-path %load-path "ice-9/psyntax.scm")) -- cgit v1.2.3 From e4752118691e41ae8307649d1abfd4739b3e4bfa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Jul 2018 14:49:34 +0200 Subject: database: Reset timestamps to one second after the Epoch. Previously, store items registered in the database by this code (for instance, store items retrieved by 'guix offload' and passed to 'restore-file-set') would have an mtime of 0 instead of 1. This would cause problems for things like .go files: Guile would consider them to be older than the corresponding .scm file, and consequently it would ignore them and possibly use another (incorrect) .go file. Reported by Ricardo Wurmus. * guix/store/database.scm (reset-timestamps): Pass 1, not 0, to 'utime'. * tests/store-database.scm ("register-path"): Check the mtime of FILE and REF. --- guix/store/database.scm | 8 +++++--- tests/store-database.scm | 7 +++++-- 2 files changed, 10 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/guix/store/database.scm b/guix/store/database.scm index 8f35b63e37..0879a95d0b 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -190,12 +190,14 @@ (define* (sqlite-register db #:key path (references '()) (define (reset-timestamps file) "Reset the modification time on FILE and on all the files it contains, if it's a directory. While at it, canonicalize file permissions." + ;; Note: We're resetting to one second after the Epoch like 'guix-daemon' + ;; has always done. (let loop ((file file) (type (stat:type (lstat file)))) (case type ((directory) (chmod file #o555) - (utime file 0 0 0 0) + (utime file 1 1 0 0) (let ((parent file)) (for-each (match-lambda (("." . _) #f) @@ -209,10 +211,10 @@ (define (reset-timestamps file) (type type)))))) (scandir* parent)))) ((symlink) - (utime file 0 0 0 0 AT_SYMLINK_NOFOLLOW)) + (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW)) (else (chmod file (if (executable-file? file) #o555 #o444)) - (utime file 0 0 0 0))))) + (utime file 1 1 0 0))))) (define* (register-path path #:key (references '()) deriver prefix diff --git a/tests/store-database.scm b/tests/store-database.scm index fcae66e2de..4d91884250 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -32,7 +32,8 @@ (define %store (test-begin "store-database") -(test-assert "register-path" +(test-equal "register-path" + '(1 1) (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) "-fake"))) (when (valid-path? %store file) @@ -50,7 +51,9 @@ (define %store (and (valid-path? %store file) (equal? (references %store file) (list ref)) (null? (valid-derivers %store file)) - (null? (referrers %store file)))))) + (null? (referrers %store file)) + (list (stat:mtime (lstat file)) + (stat:mtime (lstat ref))))))) (test-equal "new database" (list 1 2) -- cgit v1.2.3 From 8440db459a10daa24282038f35bc0b6771bd51ab Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Mon, 23 Jul 2018 00:25:34 +0200 Subject: import: PyPI: Update redirected URL. * guix/import/pypi.scm (guix-package->pypi-name, pypi->guix-package): Update docstrings. (pypi-package?): Test for pypi.org, too. (pypi-fetch): s/pypi.python.org/pypi.org/ * tests/pypi.scm ("guix-package->pypi-name, new URL style", "pypi->guix-package", "pypi->guix-package, wheels"): Likewise. --- guix/import/pypi.scm | 10 +++++----- tests/pypi.scm | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 6beab6b010..25560bac46 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -51,8 +51,7 @@ (define-module (guix import pypi) (define (pypi-fetch name) "Return an alist representation of the PyPI metadata for the package NAME, or #f on failure." - (json-fetch-alist (string-append "https://pypi.python.org/pypi/" - name "/json"))) + (json-fetch-alist (string-append "https://pypi.org/pypi/" name "/json"))) ;; For packages found on PyPI that lack a source distribution. (define-condition-type &missing-source-error &error @@ -87,7 +86,7 @@ (define (python->package-name name) (string-append "python-" (snake-case name)))) (define (guix-package->pypi-name package) - "Given a Python PACKAGE built from pypi.python.org, return the name of the + "Given a Python PACKAGE built from pypi.org, return the name of the package on PyPI." (define (url->pypi-name url) (hyphen-package-name->name+version @@ -269,7 +268,7 @@ (define (make-pypi-sexp name version source-url wheel-url home-page synopsis (license ,(license->symbol license))))))) (define (pypi->guix-package package-name) - "Fetch the metadata for PACKAGE-NAME from pypi.python.org, and return the + "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let ((package (pypi-fetch package-name))) (and package @@ -304,7 +303,8 @@ (define (pypi-package? package) "Return true if PACKAGE is a Python package from PyPI." (define (pypi-url? url) - (or (string-prefix? "https://pypi.python.org/" url) + (or (string-prefix? "https://pypi.org/" url) + (string-prefix? "https://pypi.python.org/" url) (string-prefix? "https://pypi.io/packages" url))) (let ((source-url (and=> (package-source package) origin-uri)) diff --git a/tests/pypi.scm b/tests/pypi.scm index 74f13e9662..310c6c8f29 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -89,7 +89,7 @@ (define test-metadata (dummy-package "foo" (source (dummy-origin (uri - "https://pypi.python.org/packages/a2/3b/4756e6a0ceb14e084042a2a65c615d68d25621c6fd446d0fc10d14c4ce7d/certbot-0.8.1.tar.gz")))))) + "https://pypi.org/packages/a2/3b/4756e6a0ceb14e084042a2a65c615d68d25621c6fd446d0fc10d14c4ce7d/certbot-0.8.1.tar.gz")))))) (test-equal "guix-package->pypi-name, several URLs" "cram" @@ -120,7 +120,7 @@ (define test-metadata (mock ((guix http-client) http-fetch (lambda (url . rest) (match url - ("https://pypi.python.org/pypi/foo/json" + ("https://pypi.org/pypi/foo/json" (values (open-input-string test-json) (string-length test-json))) ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) @@ -182,7 +182,7 @@ (define test-metadata (mock ((guix http-client) http-fetch (lambda (url . rest) (match url - ("https://pypi.python.org/pypi/foo/json" + ("https://pypi.org/pypi/foo/json" (values (open-input-string test-json) (string-length test-json))) ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) -- cgit v1.2.3