From bf4211523baf8ab1c853aac48ef0324f8f704510 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Nov 2013 01:06:25 +0100 Subject: guix build: Add '--log-file'. * guix/scripts/build.scm (show-help): Add '--log-file'. (%options): Likewise. (guix-build): Set %FILE-PORT-NAME-CANONICALIZATION. Honor '--log-file'. * tests/guix-build.sh: Add '--log-file' tests. * doc/guix.texi (Invoking guix build): Document '--log-file'. --- guix/scripts/build.scm | 150 +++++++++++++++++++++++++++++-------------------- 1 file changed, 88 insertions(+), 62 deletions(-) (limited to 'guix/scripts/build.scm') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a06755dc7a..f63736c09c 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -95,6 +95,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) as a garbage collector root")) (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) + (display (_ " + --log-file return the log file names for the given derivations")) (newline) (display (_ " -h, --help display this help and exit")) @@ -161,7 +163,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (lambda (opt name arg result) (let ((level (string->number arg))) (alist-cons 'verbosity level - (alist-delete 'verbosity result))))))) + (alist-delete 'verbosity result))))) + (option '("log-file") #f #f + (lambda (opt name arg result) + (alist-cons 'log-file? #t result))))) ;;; @@ -235,68 +240,89 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (leave (_ "~A: unknown package~%") name)))))) (with-error-handling - (let ((opts (parse-options))) - (define package->derivation - (match (assoc-ref opts 'target) - (#f package-derivation) - (triplet - (cut package-cross-derivation <> <> triplet <>)))) + ;; Ask for absolute file names so that .drv file names passed from the + ;; user to 'read-derivation' are absolute when it returns. + (with-fluids ((%file-port-name-canonicalization 'absolute)) + (let ((opts (parse-options))) + (define package->derivation + (match (assoc-ref opts 'target) + (#f package-derivation) + (triplet + (cut package-cross-derivation <> <> triplet <>)))) - (parameterize ((%store (open-connection))) - (let* ((src? (assoc-ref opts 'source?)) - (sys (assoc-ref opts 'system)) - (drv (filter-map (match-lambda - (('expression . str) - (derivations-from-package-expressions - str package->derivation sys src?)) - (('argument . (? derivation-path? drv)) - (call-with-input-file drv read-derivation)) - (('argument . (? string? x)) - (let ((p (find-package x))) - (if src? - (let ((s (package-source p))) - (package-source-derivation - (%store) s)) - (package->derivation (%store) p sys)))) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) + (parameterize ((%store (open-connection))) + (let* ((src? (assoc-ref opts 'source?)) + (sys (assoc-ref opts 'system)) + (drv (filter-map (match-lambda + (('expression . str) + (derivations-from-package-expressions + str package->derivation sys src?)) + (('argument . (? derivation-path? drv)) + (call-with-input-file drv read-derivation)) + (('argument . (? store-path?)) + ;; Nothing to do; maybe for --log-file. + #f) + (('argument . (? string? x)) + (let ((p (find-package x))) + (if src? + (let ((s (package-source p))) + (package-source-derivation + (%store) s)) + (package->derivation (%store) p sys)))) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) - (show-what-to-build (%store) drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?)) + (unless (assoc-ref opts 'log-file?) + (show-what-to-build (%store) drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?))) - ;; TODO: Add more options. - (set-build-options (%store) - #:keep-failed? (assoc-ref opts 'keep-failed?) - #:build-cores (or (assoc-ref opts 'cores) 0) - #:fallback? (assoc-ref opts 'fallback?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:max-silent-time (assoc-ref opts 'max-silent-time) - #:verbosity (assoc-ref opts 'verbosity)) + ;; TODO: Add more options. + (set-build-options (%store) + #:keep-failed? (assoc-ref opts 'keep-failed?) + #:build-cores (or (assoc-ref opts 'cores) 0) + #:fallback? (assoc-ref opts 'fallback?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:max-silent-time (assoc-ref opts 'max-silent-time) + #:verbosity (assoc-ref opts 'verbosity)) - (if (assoc-ref opts 'derivations-only?) - (begin - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root <> <>) - (map (compose list derivation-file-name) drv) - roots)) - (or (assoc-ref opts 'dry-run?) - (and (build-derivations (%store) drv) - (for-each (lambda (d) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation->output-path - d out-name))) - (derivation-outputs d)))) - drv) - (for-each (cut register-root <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots))))))))) + (cond ((assoc-ref opts 'log-file?) + (for-each (lambda (file) + (let ((log (log-file (%store) file))) + (if log + (format #t "~a~%" log) + (leave (_ "no build log for '~a'~%") + file)))) + (delete-duplicates + (append (map derivation-file-name drv) + (filter-map (match-lambda + (('argument + . (? store-path? file)) + file) + (_ #f)) + opts))))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations (%store) drv) + (for-each (lambda (d) + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation->output-path + d out-name))) + (derivation-outputs d)))) + drv) + (for-each (cut register-root <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots)))))))))) -- cgit v1.2.3 From ac5de156ae5de8cb61870469863fb862b6a1205e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 18 Nov 2013 23:08:20 +0100 Subject: guix build: '-e' can be passed a monadic thunk. * guix/ui.scm (read/eval): New procedure. (read/eval-package-expression): Use it. * guix/scripts/build.scm (derivations-from-package-expressions): Rename to... (derivation-from-expression): ... this. Accept procedures, under the assumption that they are monadic thunk. (show-help): Adjust accordingly. (guix-build): Ditto. * tests/guix-build.sh: Add test. * doc/guix.texi (Invoking guix build): Augment description of '-e'. --- doc/guix.texi | 6 +++++- guix/scripts/build.scm | 33 +++++++++++++++++++-------------- guix/ui.scm | 31 ++++++++++++++++++------------- tests/guix-build.sh | 8 ++++++++ 4 files changed, 50 insertions(+), 28 deletions(-) (limited to 'guix/scripts/build.scm') diff --git a/doc/guix.texi b/doc/guix.texi index cfa5aac326..847c73ab8c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1483,12 +1483,16 @@ The @var{options} may be zero or more of the following: @item --expression=@var{expr} @itemx -e @var{expr} -Build the package @var{expr} evaluates to. +Build the package or derivation @var{expr} evaluates to. For example, @var{expr} may be @code{(@@ (gnu packages guile) guile-1.8)}, which unambiguously designates this specific variant of version 1.8 of Guile. +Alternately, @var{expr} may refer to a zero-argument monadic procedure +(@pxref{The Store Monad}). The procedure must return a derivation as a +monadic value, which is then passed through @code{run-with-store}. + @item --source @itemx -S Build the packages' source derivations, rather than the packages diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index f63736c09c..dd9a9b8127 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -23,6 +23,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix utils) + #:use-module (guix monads) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -38,19 +39,23 @@ (define %store (make-parameter #f)) -(define (derivations-from-package-expressions str package-derivation - system source?) +(define (derivation-from-expression str package-derivation + system source?) "Read/eval STR and return the corresponding derivation path for SYSTEM. -When SOURCE? is true, return the derivations of the package sources; -otherwise, use PACKAGE-DERIVATION to compute the derivation of a package." - (let ((p (read/eval-package-expression str))) - (if source? - (let ((source (package-source p))) - (if source - (package-source-derivation (%store) source) - (leave (_ "package `~a' has no source~%") - (package-name p)))) - (package-derivation (%store) p system)))) +When SOURCE? is true and STR evaluates to a package, return the derivation of +the package source; otherwise, use PACKAGE-DERIVATION to compute the +derivation of a package." + (match (read/eval str) + ((? package? p) + (if source? + (let ((source (package-source p))) + (if source + (package-source-derivation (%store) source) + (leave (_ "package `~a' has no source~%") + (package-name p)))) + (package-derivation (%store) p system))) + ((? procedure? proc) + (run-with-store (%store) (proc) #:system system)))) ;;; @@ -68,7 +73,7 @@ otherwise, use PACKAGE-DERIVATION to compute the derivation of a package." (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " - -e, --expression=EXPR build the package EXPR evaluates to")) + -e, --expression=EXPR build the package or derivation EXPR evaluates to")) (display (_ " -S, --source build the packages' source derivations")) (display (_ " @@ -255,7 +260,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (sys (assoc-ref opts 'system)) (drv (filter-map (match-lambda (('expression . str) - (derivations-from-package-expressions + (derivation-from-expression str package->derivation sys src?)) (('argument . (? derivation-path? drv)) (call-with-input-file drv read-derivation)) diff --git a/guix/ui.scm b/guix/ui.scm index 8a28574c3c..f15419f7a8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -45,6 +45,7 @@ show-what-to-build call-with-error-handling with-error-handling + read/eval read/eval-package-expression location->string switch-symlinks @@ -193,25 +194,29 @@ General help using GNU software: ")) (leave (_ "~a~%") (strerror (system-error-errno args))))))) -(define (read/eval-package-expression str) - "Read and evaluate STR and return the package it refers to, or exit an -error." +(define (read/eval str) + "Read and evaluate STR, raising an error if something goes wrong." (let ((exp (catch #t (lambda () (call-with-input-string str read)) (lambda args (leave (_ "failed to read expression ~s: ~s~%") str args))))) - (let ((p (catch #t - (lambda () - (eval exp the-scm-module)) - (lambda args - (leave (_ "failed to evaluate expression `~a': ~s~%") - exp args))))) - (if (package? p) - p - (leave (_ "expression `~s' does not evaluate to a package~%") - exp))))) + (catch #t + (lambda () + (eval exp the-scm-module)) + (lambda args + (leave (_ "failed to evaluate expression `~a': ~s~%") + exp args))))) + +(define (read/eval-package-expression str) + "Read and evaluate STR and return the package it refers to, or exit an +error." + (match (read/eval str) + ((? package? p) p) + (_ + (leave (_ "expression ~s does not evaluate to a package~%") + str)))) (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t)) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index e228b38616..391e7b9da3 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -72,3 +72,11 @@ if guix build -n time-3.2; # FAIL, version not found then false; else true; fi if guix build -n something-that-will-never-exist; # FAIL then false; else true; fi + +# Invoking a monadic procedure. +guix build -e "(begin + (use-modules (guix monads) (guix utils)) + (lambda () + (derivation-expression \"test\" (%current-system) + '(mkdir %output) '())))" \ + --dry-run -- cgit v1.2.3