From 8df2eca6b0915942ea087d7c5981514c532d47a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 16 Jul 2018 11:17:55 +0200 Subject: [PATCH] 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 | 115 ++++++++++++++++++++++++++++++++++++++++------ guix/packages.scm | 3 ++ tests/gexp.scm | 20 ++++---- 3 files changed, 114 insertions(+), 24 deletions(-) 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 @@ names and file names suitable for the #:allowed-references argument to 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 @@ The other arguments are as for 'derivation'." 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 @@ The other arguments are as for 'derivation'." (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 @@ The other arguments are as for 'derivation'." "/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 @@ execution environment." ;;; 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 @@ execution environment." (local-file "build/utils.scm" "build-utils.scm")) -(define* (imported-files files - #:key (name "file-import") - (system (%current-system)) - (guile (%guile-for-build)) +(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)) + ;; 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 @@ as returned by 'local-file' for example." (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 @@ last one is created from the given object." (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 @@ they can refer to each other." (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 @@ specifies modules in scope when evaluating SNIPPET." (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 @@ "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!"))