;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module ((guix diagnostics)
+ #:select (source-properties->location))
#:use-module ((guix utils)
#:select (%current-system
- source-properties->location
call-with-temporary-directory
version>? version-prefix?
cache-directory))
#:use-module (guix derivations)
#:use-module (guix base32)
#:use-module (gcrypt hash)
- #:autoload (guix cache) (maybe-remove-expired-cache-entries)
+ #:autoload (guix cache) (maybe-remove-expired-cache-entries
+ file-expiration-time)
#:autoload (guix ui) (show-what-to-build*)
#:autoload (guix build utils) (mkdir-p)
#:use-module (srfi srfi-1)
inferior-eval
inferior-eval-with-store
inferior-object?
+ inferior-exception?
+ inferior-exception-arguments
+ inferior-exception-inferior
+ inferior-exception-stack
read-repl-response
inferior-packages
inferior-package-native-search-paths
inferior-package-transitive-native-search-paths
inferior-package-search-paths
+ inferior-package-provenance
inferior-package-derivation
inferior-package->manifest-entry
gexp->derivation-in-inferior
%inferior-cache-directory
+ cached-channel-instance
inferior-for-channels))
;;; Commentary:
(letrec ((result (inferior 'pipe pipe close (cons 0 rest)
(delay (%inferior-packages result))
(delay (%inferior-package-table result)))))
+
+ ;; For protocol (0 1) and later, send the protocol version we support.
+ (match rest
+ ((n _ ...)
+ (when (>= n 1)
+ (send-inferior-request '(() repl-version 0 1 1) result)))
+ (_
+ #t))
+
(inferior-eval '(use-modules (guix)) result)
(inferior-eval '(use-modules (gnu)) result)
(inferior-eval '(use-modules (ice-9 match)) result)
(set-record-type-printer! <inferior-object> write-inferior-object)
-(define (read-repl-response port)
- "Read a (guix repl) response from PORT and return it as a Scheme object."
+;; Reified exception thrown by an inferior.
+(define-condition-type &inferior-exception &error
+ inferior-exception?
+ (arguments inferior-exception-arguments) ;key + arguments
+ (inferior inferior-exception-inferior) ;<inferior> | #f
+ (stack inferior-exception-stack)) ;list of (FILE COLUMN LINE)
+
+(define* (read-repl-response port #:optional inferior)
+ "Read a (guix repl) response from PORT and return it as a Scheme object.
+Raise '&inferior-exception' when an exception is read from PORT."
(define sexp->object
(match-lambda
(('value value)
(match (read port)
(('values objects ...)
(apply values (map sexp->object objects)))
+ (('exception ('arguments key objects ...)
+ ('stack frames ...))
+ ;; Protocol (0 1 1) and later.
+ (raise (condition (&inferior-exception
+ (arguments (cons key (map sexp->object objects)))
+ (inferior inferior)
+ (stack frames)))))
(('exception key objects ...)
- (apply throw key (map sexp->object objects)))))
+ ;; Protocol (0 0).
+ (raise (condition (&inferior-exception
+ (arguments (cons key (map sexp->object objects)))
+ (inferior inferior)
+ (stack '())))))))
(define (read-inferior-response inferior)
- (read-repl-response (inferior-socket inferior)))
+ (read-repl-response (inferior-socket inferior)
+ inferior))
(define (send-inferior-request exp inferior)
(write exp (inferior-socket inferior))
(define inferior-package-transitive-native-search-paths
(cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
+(define (inferior-package-provenance package)
+ "Return a \"provenance sexp\" for PACKAGE, an inferior package. The result
+is similar to the sexp returned by 'package-provenance' for regular packages."
+ (inferior-package-field package
+ '(let* ((describe
+ (false-if-exception
+ (resolve-interface '(guix describe))))
+ (provenance
+ (false-if-exception
+ (module-ref describe
+ 'package-provenance))))
+ (or provenance (const #f)))))
+
(define (proxy client backend) ;adapted from (guix ssh)
"Proxy communication between CLIENT and BACKEND until CLIENT closes the
connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
(make-parameter (string-append (cache-directory #:ensure? #f)
"/inferiors")))
+(define* (cached-channel-instance store
+ channels
+ #:key
+ (authenticate? #t)
+ (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. AUTHENTICATE?
+determines whether CHANNELS are authenticated."
+ (define instances
+ (latest-channel-instances store channels
+ #:authenticate? authenticate?))
+
+ (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))
+ ;; Note: Caching is fine even when AUTHENTICATE? is false because
+ ;; we always call 'latest-channel-instances?'.
+ (symlink* (derivation->output-path profile) cached)
+ (add-indirect-root* cached)
+ (return cached))))))
+
(define* (inferior-for-channels channels
#:key
(cache-directory (%inferior-cache-directory))
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))
HCoop / jackhill / guix / guix.git / blobdiff