channels: Add mechanism to patch checkouts of the 'guix channel.
* guix/channels.scm (<patch>): New record type.
(apply-patches): New procedure.
(latest-channel-instance)[dot-git?]: New procedure.
Use 'update-cached-checkout' and 'add-to-store' instead of
'latest-repository-commit'. Call 'apply-patches' when CHANNEL is the
'guix channel.
(%patches): New variable.
* guix/git.scm (url+commit->name): Make public.
* tests/channels.scm ("latest-channel-instances includes channel dependencies")
("latest-channel-instances excludes duplicate channel dependencies"):
Mock 'update-cached-checkout' instead of 'latest-repository-commit'.
Wrap body in 'with-store' and pass the store to 'latest-channel-instances'.
This commit is contained in:
Ludovic Courtès
parent
4ba425060a
commit
053b10c3ef
3 changed files with 79 additions and 36 deletions
|
|
@ -199,13 +199,45 @@ description file or its default value."
|
|||
channel INSTANCE."
|
||||
(channel-metadata-dependencies (channel-instance-metadata instance)))
|
||||
|
||||
(define (latest-channel-instance store channel)
|
||||
;; Patch to apply to a source tree.
|
||||
(define-record-type <patch>
|
||||
(patch predicate application)
|
||||
patch?
|
||||
(predicate patch-predicate) ;procedure
|
||||
(application patch-application)) ;procedure
|
||||
|
||||
(define (apply-patches checkout commit patches)
|
||||
"Apply the matching PATCHES to CHECKOUT, modifying files in place. The
|
||||
result is unspecified."
|
||||
(let loop ((patches patches))
|
||||
(match patches
|
||||
(() #t)
|
||||
((($ <patch> predicate modify) rest ...)
|
||||
;; PREDICATE is passed COMMIT so that it can choose to only apply to
|
||||
;; ancestors.
|
||||
(when (predicate checkout commit)
|
||||
(modify checkout))
|
||||
(loop rest)))))
|
||||
|
||||
(define* (latest-channel-instance store channel
|
||||
#:key (patches %patches))
|
||||
"Return the latest channel instance for CHANNEL."
|
||||
(define (dot-git? file stat)
|
||||
(and (string=? (basename file) ".git")
|
||||
(eq? 'directory (stat:type stat))))
|
||||
|
||||
(let-values (((checkout commit)
|
||||
(latest-repository-commit store (channel-url channel)
|
||||
#:ref (channel-reference
|
||||
channel))))
|
||||
(channel-instance channel commit checkout)))
|
||||
(update-cached-checkout (channel-url channel)
|
||||
#:ref (channel-reference channel))))
|
||||
(when (guix-channel? channel)
|
||||
;; Apply the relevant subset of PATCHES directly in CHECKOUT. This is
|
||||
;; safe to do because 'switch-to-ref' eventually does a hard reset.
|
||||
(apply-patches checkout commit patches))
|
||||
|
||||
(let* ((name (url+commit->name (channel-url channel) commit))
|
||||
(checkout (add-to-store store name #t "sha256" checkout
|
||||
#:select? (negate dot-git?))))
|
||||
(channel-instance channel commit checkout))))
|
||||
|
||||
(define* (latest-channel-instances store channels #:optional (previous-channels '()))
|
||||
"Return a list of channel instances corresponding to the latest checkouts of
|
||||
|
|
@ -337,12 +369,18 @@ to '%package-module-path'."
|
|||
'guile-2.2.4))
|
||||
|
||||
(define %quirks
|
||||
;; List of predicate/package pairs. This allows us provide information
|
||||
;; List of predicate/package pairs. This allows us to provide information
|
||||
;; about specific Guile versions that old Guix revisions might need to use
|
||||
;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See
|
||||
;; <https://bugs.gnu.org/37506>
|
||||
`((,syscalls-reexports-local-variables? . ,guile-2.2.4)))
|
||||
|
||||
(define %patches
|
||||
;; Bits of past Guix revisions can become incompatible with newer Guix and
|
||||
;; Guile. This variable lists <patch> records for the Guix source tree that
|
||||
;; apply to the Guix source.
|
||||
'())
|
||||
|
||||
(define* (guile-for-source source #:optional (quirks %quirks))
|
||||
"Return the Guile package to use when building SOURCE or #f if the default
|
||||
'%guile-for-build' should be good enough."
|
||||
|
|
|
|||
|
|
@ -40,6 +40,7 @@
|
|||
|
||||
with-repository
|
||||
update-cached-checkout
|
||||
url+commit->name
|
||||
latest-repository-commit
|
||||
commit-difference
|
||||
|
||||
|
|
|
|||
|
|
@ -135,44 +135,48 @@
|
|||
(name 'test)
|
||||
(url "test")))
|
||||
(test-dir (channel-instance-checkout instance--simple)))
|
||||
(mock ((guix git) latest-repository-commit
|
||||
(lambda* (store url #:key ref)
|
||||
(mock ((guix git) update-cached-checkout
|
||||
(lambda* (url #:key ref)
|
||||
(match url
|
||||
("test" (values test-dir 'whatever))
|
||||
(_ (values "/not-important" 'not-important)))))
|
||||
(let ((instances (latest-channel-instances #f (list channel))))
|
||||
(and (eq? 2 (length instances))
|
||||
(lset= eq?
|
||||
'(test test-channel)
|
||||
(map (compose channel-name channel-instance-channel)
|
||||
instances)))))))
|
||||
("test" (values test-dir "caf3cabba9e"))
|
||||
(_ (values (channel-instance-checkout instance--no-deps)
|
||||
"abcde1234")))))
|
||||
(with-store store
|
||||
(let ((instances (latest-channel-instances store (list channel))))
|
||||
(and (eq? 2 (length instances))
|
||||
(lset= eq?
|
||||
'(test test-channel)
|
||||
(map (compose channel-name channel-instance-channel)
|
||||
instances))))))))
|
||||
|
||||
(test-assert "latest-channel-instances excludes duplicate channel dependencies"
|
||||
(let* ((channel (channel
|
||||
(name 'test)
|
||||
(url "test")))
|
||||
(test-dir (channel-instance-checkout instance--with-dupes)))
|
||||
(mock ((guix git) latest-repository-commit
|
||||
(lambda* (store url #:key ref)
|
||||
(mock ((guix git) update-cached-checkout
|
||||
(lambda* (url #:key ref)
|
||||
(match url
|
||||
("test" (values test-dir 'whatever))
|
||||
(_ (values "/not-important" 'not-important)))))
|
||||
(let ((instances (latest-channel-instances #f (list channel))))
|
||||
(and (= 2 (length instances))
|
||||
(lset= eq?
|
||||
'(test test-channel)
|
||||
(map (compose channel-name channel-instance-channel)
|
||||
instances))
|
||||
;; only the most specific channel dependency should remain,
|
||||
;; i.e. the one with a specified commit.
|
||||
(find (lambda (instance)
|
||||
(and (eq? (channel-name
|
||||
(channel-instance-channel instance))
|
||||
'test-channel)
|
||||
(string=? (channel-commit
|
||||
(channel-instance-channel instance))
|
||||
"abc1234")))
|
||||
instances))))))
|
||||
("test" (values test-dir "caf3cabba9e"))
|
||||
(_ (values (channel-instance-checkout instance--no-deps)
|
||||
"abcde1234")))))
|
||||
(with-store store
|
||||
(let ((instances (latest-channel-instances store (list channel))))
|
||||
(and (= 2 (length instances))
|
||||
(lset= eq?
|
||||
'(test test-channel)
|
||||
(map (compose channel-name channel-instance-channel)
|
||||
instances))
|
||||
;; only the most specific channel dependency should remain,
|
||||
;; i.e. the one with a specified commit.
|
||||
(find (lambda (instance)
|
||||
(and (eq? (channel-name
|
||||
(channel-instance-channel instance))
|
||||
'test-channel)
|
||||
(string=? (channel-commit
|
||||
(channel-instance-channel instance))
|
||||
"abc1234")))
|
||||
instances)))))))
|
||||
|
||||
(test-assert "channel-instances->manifest"
|
||||
;; Compute the manifest for a graph of instances and make sure we get a
|
||||
|
|
|
|||
Reference in a new issue