;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020, 2021 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 search-paths)
#:use-module (guix profiles)
#:use-module (guix channels)
+ #:use-module ((guix git) #:select (update-cached-checkout))
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix derivations)
#:autoload (guix build utils) (mkdir-p)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
#:autoload (ice-9 ftw) (scandir)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
(packages inferior-package-promise) ;promise of inferior packages
(table inferior-package-table)) ;promise of vhash
+(define (write-inferior inferior port)
+ (match inferior
+ (($ <inferior> pid _ _ version)
+ (format port "#<inferior ~a ~a ~a>"
+ pid version
+ (number->string (object-address inferior) 16)))))
+
+(set-record-type-printer! <inferior> write-inferior)
+
(define* (inferior-pipe directory command error-port)
"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
"Return the list of name/version pairs corresponding to the set of packages
available in INFERIOR.
-This is faster and requires less resource-intensive than calling
-'inferior-packages'."
+This is faster and less resource-intensive than calling 'inferior-packages'."
(if (inferior-eval '(defined? 'fold-available-packages)
inferior)
(inferior-eval '(fold-available-packages
"Proxy communication between CLIENT and BACKEND until CLIENT closes the
connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
input/output ports.)"
- (define (select* read write except)
- ;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
- ;; since 'select' sometimes returns non-empty sets for no good reason,
- ;; call 'select' a second time with a zero timeout to filter out incorrect
- ;; replies.
- (match (select read write except)
- ((read write except)
- (select read write except 0))))
-
;; Use buffered ports so that 'get-bytevector-some' returns up to the
;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
(setvbuf client 'block 65536)
(setvbuf backend 'block 65536)
(let loop ()
- (match (select* (list client backend) '() '())
+ (match (select (list client backend) '() '())
((reads () ())
(when (memq client reads)
(match (get-bytevector-some client)
(define* (inferior-package->manifest-entry package
#:optional (output "out")
- #:key (parent (delay #f))
- (properties '()))
+ #:key (properties '()))
"Return a manifest entry for the OUTPUT of package PACKAGE."
- ;; For each dependency, keep a promise pointing to its "parent" entry.
- (letrec* ((deps (map (match-lambda
- ((label package)
- (inferior-package->manifest-entry package
- #:parent (delay entry)))
- ((label package output)
- (inferior-package->manifest-entry package output
- #:parent (delay entry))))
- (inferior-package-propagated-inputs package)))
- (entry (manifest-entry
- (name (inferior-package-name package))
- (version (inferior-package-version package))
- (output output)
- (item package)
- (dependencies (delete-duplicates deps))
- (search-paths
- (inferior-package-transitive-native-search-paths package))
- (parent parent)
- (properties properties))))
- entry))
+ (define cache
+ (make-hash-table))
+
+ (define-syntax-rule (memoized package output exp)
+ ;; Memoize the entry returned by EXP for PACKAGE/OUTPUT. This is
+ ;; important as the same package may be traversed many times through
+ ;; propagated inputs, and querying the inferior is costly. Use
+ ;; 'hash'/'equal?', which is okay since <inferior-package> is simple.
+ (let ((compute (lambda () exp))
+ (key (cons package output)))
+ (or (hash-ref cache key)
+ (let ((result (compute)))
+ (hash-set! cache key result)
+ result))))
+
+ (let loop ((package package)
+ (output output)
+ (parent (delay #f)))
+ (memoized package output
+ ;; For each dependency, keep a promise pointing to its "parent" entry.
+ (letrec* ((deps (map (match-lambda
+ ((label package)
+ (loop package "out" (delay entry)))
+ ((label package output)
+ (loop package output (delay entry))))
+ (inferior-package-propagated-inputs package)))
+ (entry (manifest-entry
+ (name (inferior-package-name package))
+ (version (inferior-package-version package))
+ (output output)
+ (item package)
+ (dependencies (delete-duplicates deps))
+ (search-paths
+ (inferior-package-transitive-native-search-paths package))
+ (parent parent)
+ (properties properties))))
+ entry))))
\f
;;;
(make-parameter (string-append (cache-directory #:ensure? #f)
"/inferiors")))
+(define (channel-full-commit channel)
+ "Return the commit designated by CHANNEL as quickly as possible. If
+CHANNEL's 'commit' field is a full SHA1, return it as-is; if it's a SHA1
+prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
+ (let ((commit (channel-commit channel))
+ (branch (channel-branch channel)))
+ (if (and commit (= (string-length commit) 40))
+ commit
+ (let* ((ref (if commit `(commit . ,commit) `(branch . ,branch)))
+ (cache commit relation
+ (update-cached-checkout (channel-url channel)
+ #:ref ref
+ #:check-out? #f)))
+ commit))))
+
(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."
- (define instances
- (latest-channel-instances store channels))
+This procedure opens a new connection to the build daemon. AUTHENTICATE?
+determines whether CHANNELS are authenticated."
+ (define commits
+ ;; Since computing the instances of CHANNELS is I/O-intensive, use a
+ ;; cheaper way to get the commit list of CHANNELS. This limits overhead
+ ;; to the minimum in case of a cache hit.
+ (map channel-full-commit channels))
(define key
(bytevector->base32-string
(sha256
- (string->utf8
- (string-concatenate (map channel-instance-commit instances))))))
+ (string->utf8 (string-concatenate commits)))))
(define cached
(string-append cache-directory "/" key))
(string-append directory "/" file))
(scandir directory base32-encoded-sha256?)))
+ (define (symlink/safe old new)
+ (catch 'system-error
+ (lambda ()
+ (symlink old new))
+ (lambda args
+ (unless (= EEXIST (system-error-errno args))
+ (apply throw args)))))
+
(define symlink*
- (lift2 symlink %store-monad))
+ (lift2 symlink/safe %store-monad))
(define add-indirect-root*
(store-lift add-indirect-root))
(if (file-exists? cached)
cached
(run-with-store store
- (mlet %store-monad ((profile
- (channel-instances->derivation instances)))
+ (mlet* %store-monad ((instances
+ -> (latest-channel-instances store channels
+ #:authenticate?
+ authenticate?))
+ (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))))))
#:cache-directory cache-directory
#:ttl ttl)))
(open-inferior cached))
+
+;;; Local Variables:
+;;; eval: (put 'memoized 'scheme-indent-function 1)
+;;; End:
HCoop / jackhill / guix / guix.git / blobdiff