summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build/download.scm13
-rw-r--r--guix/build/emacs-build-system.scm42
-rw-r--r--guix/import/hackage.scm6
-rw-r--r--guix/inferior.scm105
-rw-r--r--guix/scripts/build.scm19
-rw-r--r--guix/scripts/deploy.scm4
-rw-r--r--guix/scripts/pack.scm21
-rw-r--r--guix/scripts/pull.scm32
-rw-r--r--guix/scripts/time-machine.scm135
-rw-r--r--guix/utils.scm12
10 files changed, 273 insertions, 116 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm
index a4c91550a6..141ef409d6 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -187,10 +187,13 @@ name decoding bug described at
DIRECTORY. Those authority certificates are checked when
'peer-certificate-status' is later called."
(let ((cred (make-certificate-credentials))
- (files (or (scandir directory
- (lambda (file)
- (string-suffix? ".pem" file)))
- '())))
+ (files (match (scandir directory (cut string-suffix? ".pem" <>))
+ ((or #f ())
+ ;; Some distros provide nothing but bundles (*.crt) under
+ ;; /etc/ssl/certs, so look for them.
+ (or (scandir directory (cut string-suffix? ".crt" <>))
+ '()))
+ (pem pem))))
(for-each (lambda (file)
(let ((file (string-append directory "/" file)))
;; Protect against dangling symlinks.
@@ -198,7 +201,7 @@ DIRECTORY. Those authority certificates are checked when
(set-certificate-credentials-x509-trust-file!*
cred file
x509-certificate-format/pem))))
- (or files '()))
+ files)
cred))
(define (peer-certificate session)
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 47a9eda9e6..f0c41812f1 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -2,7 +2,7 @@
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2018, 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -74,40 +74,14 @@ archive, a directory, or an Emacs Lisp file."
#t)
(gnu:unpack #:source source)))
-(define* (set-emacs-load-path #:key source inputs #:allow-other-keys)
- (define (inputs->directories inputs)
- "Extract the directory part from INPUTS."
- (match inputs
- (((names . directories) ...) directories)))
-
- (define (input-directory->el-directory input-directory)
- "Return the correct Emacs Lisp directory in INPUT-DIRECTORY or #f, if there
-is no Emacs Lisp directory."
- (let ((legacy-elisp-directory (string-append input-directory %legacy-install-suffix))
- (guix-elisp-directory
- (string-append
- input-directory %install-suffix "/"
- (store-directory->elpa-name-version input-directory))))
- (cond
- ((file-exists? guix-elisp-directory) guix-elisp-directory)
- ((file-exists? legacy-elisp-directory) legacy-elisp-directory)
- (else #f))))
-
- (define (input-directories->el-directories input-directories)
- "Return the list of Emacs Lisp directories in INPUT-DIRECTORIES."
- (filter-map input-directory->el-directory input-directories))
-
- "Set the EMACSLOADPATH environment variable so that dependencies are found."
+(define* (add-source-to-load-path #:key dummy #:allow-other-keys)
+ "Augment the EMACSLOADPATH environment variable with the source directory."
(let* ((source-directory (getcwd))
- (input-elisp-directories (input-directories->el-directories
- (inputs->directories inputs)))
- (emacs-load-path-value
- (string-join
- (append input-elisp-directories (list source-directory))
- ":" 'suffix)))
+ (emacs-load-path-value (string-append (getenv "EMACSLOADPATH") ":"
+ source-directory)))
(setenv "EMACSLOADPATH" emacs-load-path-value)
- (format #t "environment variable `EMACSLOADPATH' set to ~a\n"
- emacs-load-path-value)))
+ (format #t "source directory ~s appended to the `EMACSLOADPATH' \
+environment variable\n" source-directory)))
(define* (build #:key outputs inputs #:allow-other-keys)
"Compile .el files."
@@ -269,7 +243,7 @@ second hyphen. This corresponds to 'name-version' as used in ELPA packages."
(define %standard-phases
(modify-phases gnu:%standard-phases
(replace 'unpack unpack)
- (add-after 'unpack 'set-emacs-load-path set-emacs-load-path)
+ (add-after 'unpack 'add-source-to-load-path add-source-to-load-path)
(delete 'bootstrap)
(delete 'configure)
;; Move the build phase after install: the .el files are byte compiled
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 5fe3d85a7f..9cf07c9504 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -52,8 +52,8 @@
hackage-package?))
(define ghc-standard-libraries
- ;; List of libraries distributed with ghc (8.4.3).
- ;; Contents of ...-ghc-8.4.3/lib/ghc-8.4.3.
+ ;; List of libraries distributed with ghc (8.6.5).
+ ;; Contents of ...-ghc-8.6.5/lib/ghc-8.6.5.
'("ghc"
"cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but
;; hackage-name->package-name takes this into account.
@@ -70,11 +70,13 @@
"ghc-boot"
"ghc-boot-th"
"ghc-compact"
+ "ghc-heap"
"ghc-prim"
"ghci"
"haskeline"
"hpc"
"integer-gmp"
+ "libiserv"
"mtl"
"parsec"
"pretty"
diff --git a/guix/inferior.scm b/guix/inferior.scm
index b8e2f21f42..71dae89e92 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -89,6 +89,7 @@
gexp->derivation-in-inferior
%inferior-cache-directory
+ cached-channel-instance
inferior-for-channels))
;;; Commentary:
@@ -635,6 +636,58 @@ failing when GUIX is too old and lacks the 'guix repl' command."
(make-parameter (string-append (cache-directory #:ensure? #f)
"/inferiors")))
+(define* (cached-channel-instance store
+ channels
+ #:key
+ (cache-directory (%inferior-cache-directory))
+ (ttl (* 3600 24 30)))
+ "Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
+The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.
+This procedure opens a new connection to the build daemon."
+ (define instances
+ (latest-channel-instances store channels))
+
+ (define key
+ (bytevector->base32-string
+ (sha256
+ (string->utf8
+ (string-concatenate (map channel-instance-commit instances))))))
+
+ (define cached
+ (string-append cache-directory "/" key))
+
+ (define (base32-encoded-sha256? str)
+ (= (string-length str) 52))
+
+ (define (cache-entries directory)
+ (map (lambda (file)
+ (string-append directory "/" file))
+ (scandir directory base32-encoded-sha256?)))
+
+ (define symlink*
+ (lift2 symlink %store-monad))
+
+ (define add-indirect-root*
+ (store-lift add-indirect-root))
+
+ (mkdir-p cache-directory)
+ (maybe-remove-expired-cache-entries cache-directory
+ cache-entries
+ #:entry-expiration
+ (file-expiration-time ttl))
+
+ (if (file-exists? cached)
+ cached
+ (run-with-store store
+ (mlet %store-monad ((profile
+ (channel-instances->derivation instances)))
+ (mbegin %store-monad
+ (show-what-to-build* (list profile))
+ (built-derivations (list profile))
+ (symlink* (derivation->output-path profile) cached)
+ (add-indirect-root* cached)
+ (return cached))))))
+
(define* (inferior-for-channels channels
#:key
(cache-directory (%inferior-cache-directory))
@@ -645,48 +698,10 @@ procedure opens a new connection to the build daemon.
This is a convenience procedure that people may use in manifests passed to
'guix package -m', for instance."
- (with-store store
- (let ()
- (define instances
- (latest-channel-instances store channels))
-
- (define key
- (bytevector->base32-string
- (sha256
- (string->utf8
- (string-concatenate (map channel-instance-commit instances))))))
-
- (define cached
- (string-append cache-directory "/" key))
-
- (define (base32-encoded-sha256? str)
- (= (string-length str) 52))
-
- (define (cache-entries directory)
- (map (lambda (file)
- (string-append directory "/" file))
- (scandir directory base32-encoded-sha256?)))
-
- (define symlink*
- (lift2 symlink %store-monad))
-
- (define add-indirect-root*
- (store-lift add-indirect-root))
-
- (mkdir-p cache-directory)
- (maybe-remove-expired-cache-entries cache-directory
- cache-entries
- #:entry-expiration
- (file-expiration-time ttl))
-
- (if (file-exists? cached)
- (open-inferior cached)
- (run-with-store store
- (mlet %store-monad ((profile
- (channel-instances->derivation instances)))
- (mbegin %store-monad
- (show-what-to-build* (list profile))
- (built-derivations (list profile))
- (symlink* (derivation->output-path profile) cached)
- (add-indirect-root* cached)
- (return (open-inferior cached)))))))))
+ (define cached
+ (with-store store
+ (cached-channel-instance store
+ channels
+ #:cache-directory cache-directory
+ #:ttl ttl)))
+ (open-inferior cached))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 9ad7379bbe..ae78df9c5c 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -802,7 +802,15 @@ build---packages, gexps, derivations, and so on."
(append-map (match-lambda
(('argument . (? string? spec))
(cond ((derivation-path? spec)
- (list (read-derivation-from-file spec)))
+ (catch 'system-error
+ (lambda ()
+ (list (read-derivation-from-file spec)))
+ (lambda args
+ ;; Non-existent .drv files can be substituted down
+ ;; the road, so don't error out.
+ (if (= ENOENT (system-error-errno args))
+ '()
+ (apply throw args)))))
((store-path? spec)
;; Nothing to do; maybe for --log-file.
'())
@@ -934,7 +942,11 @@ needed."
'())))
(items (filter-map (match-lambda
(('argument . (? store-path? file))
- (and (not (derivation-path? file))
+ ;; If FILE is a .drv that's not in
+ ;; store, keep it so that it can be
+ ;; substituted.
+ (and (or (not (derivation-path? file))
+ (not (file-exists? file)))
file))
(_ #f))
opts))
@@ -965,7 +977,8 @@ needed."
(map (compose list derivation-file-name) drv)
roots))
((not (assoc-ref opts 'dry-run?))
- (and (build-derivations store drv mode)
+ (and (build-derivations store (append drv items)
+ mode)
(for-each show-derivation-outputs drv)
(for-each (cut register-root store <> <>)
(map (lambda (drv)
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index f311587ec3..27b7e4fd1c 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -62,6 +62,10 @@ Perform the deployment specified by FILE.\n"))
(lambda args
(show-help)
(exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix deploy")))
+
(option '(#\s "system") #t #f
(lambda (opt name arg result)
(alist-cons 'system arg
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 920d6c01fe..89b3e389fc 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -800,6 +800,10 @@ last resort for relocation."
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
(alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (option '(#\d "derivation") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'derivation-only? #t result)))
+
(option '(#\f "format") #t #f
(lambda (opt name arg result)
(alist-cons 'format (string->symbol arg) result)))
@@ -918,6 +922,8 @@ Create a bundle of PACKAGE.\n"))
-r, --root=FILE make FILE a symlink to the result, and register it
as a garbage collector root"))
(display (G_ "
+ -d, --derivation return the derivation of the pack"))
+ (display (G_ "
-v, --verbosity=LEVEL use the given verbosity LEVEL"))
(display (G_ "
--bootstrap use the bootstrap binaries to build the pack"))
@@ -1002,6 +1008,7 @@ Create a bundle of PACKAGE.\n"))
(assoc-ref opts 'system)
#:graft? (assoc-ref opts 'graft?))))
(let* ((dry-run? (assoc-ref opts 'dry-run?))
+ (derivation? (assoc-ref opts 'derivation-only?))
(relocatable? (assoc-ref opts 'relocatable?))
(proot? (eq? relocatable? 'proot))
(manifest (let ((manifest (manifest-from-args store opts)))
@@ -1070,11 +1077,15 @@ Create a bundle of PACKAGE.\n"))
#:archiver
archiver)))
(mbegin %store-monad
- (show-what-to-build* (list drv)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?)
- (munless dry-run?
+ (munless derivation?
+ (show-what-to-build* (list drv)
+ #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run? dry-run?))
+ (mwhen derivation?
+ (return (format #t "~a~%"
+ (derivation-file-name drv))))
+ (munless (or derivation? dry-run?)
(built-derivations (list drv))
(mwhen gc-root
(register-root* (match (derivation->output-paths drv)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 92aac6066e..ef8d5c8fd9 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -36,6 +36,8 @@
#:autoload (guix inferior) (open-inferior)
#:use-module (guix scripts build)
#:autoload (guix build utils) (which)
+ #:use-module ((guix build syscalls)
+ #:select (with-file-lock/no-wait))
#:use-module (guix git)
#:use-module (git)
#:use-module (gnu packages)
@@ -56,6 +58,8 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 format)
#:export (display-profile-content
+ channel-list
+ with-git-error-handling
guix-pull))
@@ -79,8 +83,6 @@
(display (G_ "Usage: guix pull [OPTION]...
Download and deploy the latest version of Guix.\n"))
(display (G_ "
- --verbose produce verbose output"))
- (display (G_ "
-C, --channels=FILE deploy the channels defined in FILE"))
(display (G_ "
--url=URL download from the Git repository at URL"))
@@ -120,10 +122,7 @@ Download and deploy the latest version of Guix.\n"))
(define %options
;; Specifications of the command-line options.
- (cons* (option '("verbose") #f #f
- (lambda (opt name arg result)
- (alist-cons 'verbose? #t result)))
- (option '(#\C "channels") #t #f
+ (cons* (option '(#\C "channels") #t #f
(lambda (opt name arg result)
(alist-cons 'channel-file arg result)))
(option '(#\l "list-generations") #f #t
@@ -382,7 +381,7 @@ previous generation. Return true if there are news to display."
(display-channel-news profile))
(define* (build-and-install instances profile
- #:key use-substitutes? verbose? dry-run?)
+ #:key use-substitutes? dry-run?)
"Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is
true, display what would be built without actually building it."
(define update-profile
@@ -818,13 +817,16 @@ Use '~/.config/guix/channels.scm' instead."))
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
(canonical-package guile-2.2)))))
- (run-with-store store
- (build-and-install instances profile
- #:dry-run?
- (assoc-ref opts 'dry-run?)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:verbose?
- (assoc-ref opts 'verbose?))))))))))))))
+ (with-file-lock/no-wait (string-append profile ".lock")
+ (lambda (key . args)
+ (leave (G_ "profile ~a is locked by another process~%")
+ profile))
+
+ (run-with-store store
+ (build-and-install instances profile
+ #:dry-run?
+ (assoc-ref opts 'dry-run?)
+ #:use-substitutes?
+ (assoc-ref opts 'substitutes?)))))))))))))))
;;; pull.scm ends here
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
new file mode 100644
index 0000000000..19e635555a
--- /dev/null
+++ b/guix/scripts/time-machine.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Konrad Hinsen <konrad.hinsen@fastmail.net>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts time-machine)
+ #:use-module (guix ui)
+ #:use-module (guix scripts)
+ #:use-module (guix inferior)
+ #:use-module (guix channels)
+ #:use-module (guix store)
+ #:use-module (guix status)
+ #:use-module ((guix utils)
+ #:select (%current-system))
+ #:use-module ((guix scripts pull)
+ #:select (with-git-error-handling channel-list))
+ #:use-module ((guix scripts build)
+ #:select (%standard-build-options
+ show-build-options-help
+ set-build-options-from-command-line))
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:export (guix-time-machine))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define (show-help)
+ (display (G_ "Usage: guix time-machine [OPTION] -- COMMAND ARGS...
+Execute COMMAND ARGS... in an older version of Guix.\n"))
+ (display (G_ "
+ -C, --channels=FILE deploy the channels defined in FILE"))
+ (display (G_ "
+ --url=URL use the Git repository at URL"))
+ (display (G_ "
+ --commit=COMMIT use the specified COMMIT"))
+ (display (G_ "
+ --branch=BRANCH use the tip of the specified BRANCH"))
+ (newline)
+ (show-build-options-help)
+ (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 %options
+ ;; Specifications of the command-line options.
+ (cons* (option '(#\C "channels") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'channel-file arg result)))
+ (option '("url") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'repository-url arg
+ (alist-delete 'repository-url result))))
+ (option '("commit") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'ref `(commit . ,arg) result)))
+ (option '("branch") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'ref `(branch . ,arg) result)))
+ (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix time-machine")))
+
+ %standard-build-options))
+
+(define %default-options
+ ;; Alist of default option values.
+ `((system . ,(%current-system))
+ (substitutes? . #t)
+ (build-hook? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
+ (graft? . #t)
+ (debug . 0)
+ (verbosity . 1)))
+
+(define (parse-args args)
+ "Parse the list of command line arguments ARGS."
+ ;; The '--' token is used to separate the command to run from the rest of
+ ;; the operands.
+ (let-values (((args command) (break (cut string=? "--" <>) args)))
+ (let ((opts (parse-command-line args %options
+ (list %default-options))))
+ (match command
+ (() opts)
+ (("--") opts)
+ (("--" command ...) (alist-cons 'exec command opts))))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-time-machine . args)
+ (with-error-handling
+ (with-git-error-handling
+ (let* ((opts (parse-args args))
+ (channels (channel-list opts))
+ (command-line (assoc-ref opts 'exec)))
+ (when command-line
+ (let* ((directory
+ (with-store store
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (set-build-options-from-command-line store opts)
+ (cached-channel-instance store channels))))
+ (executable (string-append directory "/bin/guix")))
+ (apply execl (cons* executable executable command-line))))))))
diff --git a/guix/utils.scm b/guix/utils.scm
index 1f99c5b3f5..64853f2989 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -782,13 +782,11 @@ be determined."
;; the absolute file name by looking at %LOAD-PATH; doing this at
;; run time rather than expansion time is necessary to allow files
;; to be moved on the file system.
- (cond ((not file-name)
- #f) ;raising an error would upset Geiser users
- ((string-prefix? "/" file-name)
- (dirname file-name))
- (else
- #`(absolute-dirname #,file-name))))
- (#f
+ (if (string-prefix? "/" file-name)
+ (dirname file-name)
+ #`(absolute-dirname #,file-name)))
+ ((or ('filename . #f) #f)
+ ;; raising an error would upset Geiser users
#f))))))
;; A source location.