me
/
guix
Archived
1
0
Fork 0
Code

channels: Make 'validate-pull' call right after clone/pull. 

This should come before patching, authentication, etc.

* guix/channels.scm (latest-channel-instance): Add #:validate-pull
parameter and honor it.  Return a single value: the instance.
(ensure-forward-channel-update): Change 'instance' parameter to 'commit'
and adjust accordingly.
(latest-channel-instances): Adjust to 'latest-channel-instance' changes.
* guix/scripts/pull.scm (warn-about-backward-updates): Change 'instance'
parameter to 'commit' and adjust accordingly.
* tests/channels.scm ("latest-channel-instances #:validate-pull"):
Likewise.
master
Ludovic Courtès 2020-06-08 22:46:06 +02:00
parent 43badf261f
commit 5bafc70d1e
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 26 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
guix/channels.scm
View File

@ -375,9 +375,12 @@ commits ~a to ~a (~h new commits)...~%")
(define* (latest-channel-instance store channel (define* (latest-channel-instance store channel
#:key (patches %patches) #:key (patches %patches)
starting-commit) starting-commit
"Return two values: the latest channel instance for CHANNEL, and its (validate-pull
relation to STARTING-COMMIT when provided." ensure-forward-channel-update))
"Return the latest channel instance for CHANNEL. When STARTING-COMMIT is
true, call VALIDATE-PULL with CHANNEL, STARTING-COMMIT, the target commit, and
their relation."
(define (dot-git? file stat) (define (dot-git? file stat)
(and (string=? (basename file) ".git") (and (string=? (basename file) ".git")
(eq? 'directory (stat:type stat)))) (eq? 'directory (stat:type stat))))
@ -386,6 +389,9 @@ relation to STARTING-COMMIT when provided."
(update-cached-checkout (channel-url channel) (update-cached-checkout (channel-url channel)
#:ref (channel-reference channel) #:ref (channel-reference channel)
#:starting-commit starting-commit))) #:starting-commit starting-commit)))
(when relation
(validate-pull channel starting-commit commit relation))
(if (channel-introduction channel) (if (channel-introduction channel)
(authenticate-channel channel checkout commit) (authenticate-channel channel checkout commit)
;; TODO: Warn for all the channels once the authentication interface ;; TODO: Warn for all the channels once the authentication interface
@ -403,12 +409,11 @@ cannot be authenticated~%")
(let* ((name (url+commit->name (channel-url channel) commit)) (let* ((name (url+commit->name (channel-url channel) commit))
(checkout (add-to-store store name #t "sha256" checkout (checkout (add-to-store store name #t "sha256" checkout
#:select? (negate dot-git?)))) #:select? (negate dot-git?))))
(values (channel-instance channel commit checkout) (channel-instance channel commit checkout))))
relation))))
(define (ensure-forward-channel-update channel start instance relation) (define (ensure-forward-channel-update channel start commit relation)
"Raise an error if RELATION is not 'ancestor, meaning that START is not an "Raise an error if RELATION is not 'ancestor, meaning that START is not an
ancestor of the commit in INSTANCE, unless CHANNEL specifies a commit. ancestor of COMMIT, unless CHANNEL specifies a commit.
This procedure implements a channel update policy meant to be used as a This procedure implements a channel update policy meant to be used as a
#:validate-pull argument." #:validate-pull argument."
@ -422,8 +427,7 @@ This procedure implements a channel update policy meant to be used as a
(format #f (G_ "\ (format #f (G_ "\
aborting update of channel '~a' to commit ~a, which is not a descendant of ~a") aborting update of channel '~a' to commit ~a, which is not a descendant of ~a")
(channel-name channel) (channel-name channel)
(channel-instance-commit instance) commit start))))
start))))
;; If the user asked for a specific commit, they might want ;; If the user asked for a specific commit, they might want
;; that to happen nevertheless, so tell them about the ;; that to happen nevertheless, so tell them about the
@ -482,14 +486,13 @@ depending on the policy it implements."
(G_ "Updating channel '~a' from Git repository at '~a'...~%") (G_ "Updating channel '~a' from Git repository at '~a'...~%")
(channel-name channel) (channel-name channel)
(channel-url channel)) (channel-url channel))
(let*-values (((current) (let* ((current (current-commit (channel-name channel)))
(current-commit (channel-name channel))) (instance
((instance relation)
(latest-channel-instance store channel (latest-channel-instance store channel
#:validate-pull
validate-pull
#:starting-commit #:starting-commit
current))) current)))
(when relation
(validate-pull channel current instance relation))
(let-values (((new-instances new-channels) (let-values (((new-instances new-channels)
(loop (channel-instance-dependencies instance) (loop (channel-instance-dependencies instance)

10
guix/scripts/pull.scm
View File

@ -195,20 +195,18 @@ Download and deploy the latest version of Guix.\n"))
%standard-build-options)) %standard-build-options))
(define (warn-about-backward-updates channel start instance relation) (define (warn-about-backward-updates channel start commit relation)
"Warn about non-forward updates of CHANNEL from START to INSTANCE, without "Warn about non-forward updates of CHANNEL from START to COMMIT, without
aborting." aborting."
(match relation (match relation
((or 'ancestor 'self) ((or 'ancestor 'self)
#t) #t)
('descendant ('descendant
(warning (G_ "rolling back channel '~a' from ~a to ~a~%") (warning (G_ "rolling back channel '~a' from ~a to ~a~%")
(channel-name channel) start (channel-name channel) start commit))
(channel-instance-commit instance)))
('unrelated ('unrelated
(warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%") (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%")
(channel-name channel) start (channel-name channel) start commit))))
(channel-instance-commit instance)))))
(define* (display-profile-news profile #:key concise? (define* (display-profile-news profile #:key concise?
current-is-newer?) current-is-newer?)

4
tests/channels.scm
View File

@ -212,12 +212,12 @@
(commit (oid->string (commit-id commit2))))) (commit (oid->string (commit-id commit2)))))
(old (channel (inherit spec) (old (channel (inherit spec)
(commit (oid->string (commit-id commit1)))))) (commit (oid->string (commit-id commit1))))))
(define (validate-pull channel current instance relation) (define (validate-pull channel current commit relation)
(return (and (eq? channel old) (return (and (eq? channel old)
(string=? (oid->string (commit-id commit2)) (string=? (oid->string (commit-id commit2))
current) current)
(string=? (oid->string (commit-id commit1)) (string=? (oid->string (commit-id commit1))
(channel-instance-commit instance)) commit)
relation))) relation)))
(with-store store (with-store store