ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-25 12:09:15 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

channels: Add mechanism to patch checkouts of the 'guix channel.

Browse source 
* 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 2020-05-06 22:45:31 +02:00
parent 4ba425060a
commit 053b10c3ef
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 79 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
guix/channels.scm
View file

@ -199,13 +199,45 @@ (define (channel-instance-dependencies instance)
channel INSTANCE." channel INSTANCE."
(channel-metadata-dependencies (channel-instance-metadata 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." "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) (let-values (((checkout commit)
(latest-repository-commit store (channel-url channel) (update-cached-checkout (channel-url channel)
#:ref (channel-reference #:ref (channel-reference channel))))
channel)))) (when (guix-channel? channel)
(channel-instance channel commit checkout))) ;; 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 '())) (define* (latest-channel-instances store channels #:optional (previous-channels '()))
"Return a list of channel instances corresponding to the latest checkouts of "Return a list of channel instances corresponding to the latest checkouts of
@ -337,12 +369,18 @@ (define (guile-2.2.4)
'guile-2.2.4)) 'guile-2.2.4))
(define %quirks (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 ;; 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 ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See
;; <https://bugs.gnu.org/37506> ;; <https://bugs.gnu.org/37506>
`((,syscalls-reexports-local-variables? . ,guile-2.2.4))) `((,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)) (define* (guile-for-source source #:optional (quirks %quirks))
"Return the Guile package to use when building SOURCE or #f if the default "Return the Guile package to use when building SOURCE or #f if the default
'%guile-for-build' should be good enough." '%guile-for-build' should be good enough."

1
guix/git.scm
View file

@ -40,6 +40,7 @@ (define-module (guix git)
with-repository with-repository
update-cached-checkout update-cached-checkout
url+commit->name
latest-repository-commit latest-repository-commit
commit-difference commit-difference

64
tests/channels.scm
View file

@ -135,44 +135,48 @@ (define channel-metadata-dependencies
(name 'test) (name 'test)
(url "test"))) (url "test")))
(test-dir (channel-instance-checkout instance--simple))) (test-dir (channel-instance-checkout instance--simple)))
(mock ((guix git) latest-repository-commit (mock ((guix git) update-cached-checkout
(lambda* (store url #:key ref) (lambda* (url #:key ref)
(match url (match url
("test" (values test-dir 'whatever)) ("test" (values test-dir "caf3cabba9e"))
(_ (values "/not-important" 'not-important))))) (_ (values (channel-instance-checkout instance--no-deps)
(let ((instances (latest-channel-instances #f (list channel)))) "abcde1234")))))
(and (eq? 2 (length instances)) (with-store store
(lset= eq? (let ((instances (latest-channel-instances store (list channel))))
'(test test-channel) (and (eq? 2 (length instances))
(map (compose channel-name channel-instance-channel) (lset= eq?
instances))))))) '(test test-channel)
(map (compose channel-name channel-instance-channel)
instances))))))))
(test-assert "latest-channel-instances excludes duplicate channel dependencies" (test-assert "latest-channel-instances excludes duplicate channel dependencies"
(let* ((channel (channel (let* ((channel (channel
(name 'test) (name 'test)
(url "test"))) (url "test")))
(test-dir (channel-instance-checkout instance--with-dupes))) (test-dir (channel-instance-checkout instance--with-dupes)))
(mock ((guix git) latest-repository-commit (mock ((guix git) update-cached-checkout
(lambda* (store url #:key ref) (lambda* (url #:key ref)
(match url (match url
("test" (values test-dir 'whatever)) ("test" (values test-dir "caf3cabba9e"))
(_ (values "/not-important" 'not-important))))) (_ (values (channel-instance-checkout instance--no-deps)
(let ((instances (latest-channel-instances #f (list channel)))) "abcde1234")))))
(and (= 2 (length instances)) (with-store store
(lset= eq? (let ((instances (latest-channel-instances store (list channel))))
'(test test-channel) (and (= 2 (length instances))
(map (compose channel-name channel-instance-channel) (lset= eq?
instances)) '(test test-channel)
;; only the most specific channel dependency should remain, (map (compose channel-name channel-instance-channel)
;; i.e. the one with a specified commit. instances))
(find (lambda (instance) ;; only the most specific channel dependency should remain,
(and (eq? (channel-name ;; i.e. the one with a specified commit.
(channel-instance-channel instance)) (find (lambda (instance)
'test-channel) (and (eq? (channel-name
(string=? (channel-commit (channel-instance-channel instance))
(channel-instance-channel instance)) 'test-channel)
"abc1234"))) (string=? (channel-commit
instances)))))) (channel-instance-channel instance))
"abc1234")))
instances)))))))
(test-assert "channel-instances->manifest" (test-assert "channel-instances->manifest"
;; Compute the manifest for a graph of instances and make sure we get a ;; Compute the manifest for a graph of instances and make sure we get a