swh: ‘lookup-origin-revision’ handles branches pointing to directories.
Fixes <https://issues.guix.gnu.org/69070>. * guix/swh.scm (branch-target): Add clause for 'directory and 'alias. (lookup-origin-revision): Iterate over all the visits of ORIGIN instead of just the first one. Handle the case where ‘branch-target’ returns something other than a release or revision. * tests/swh.scm ("lookup-origin-revision"): New test. Change-Id: I7f636739a719908763bca1d3e7376341dd62e816
This commit is contained in:
Ludovic Courtès
parent
ed9d7d8431
commit
ddd455c0dd
60
guix/swh.scm
60
guix/swh.scm
@ -516,14 +516,20 @@ could not be found."
|
||||
(_ #f)))))
|
||||
|
||||
(define (branch-target branch)
|
||||
"Return the target of BRANCH, either a <revision> or a <release>."
|
||||
"Return the target of BRANCH: a <revision>, a <release>, or the SWHID of a
|
||||
directory."
|
||||
(match (branch-target-type branch)
|
||||
('release
|
||||
(call (swh-url (branch-target-url branch))
|
||||
json->release))
|
||||
('revision
|
||||
(call (swh-url (branch-target-url branch))
|
||||
json->revision))))
|
||||
json->revision))
|
||||
((or 'directory 'alias)
|
||||
(match (string-tokenize (branch-target-url branch)
|
||||
(char-set-complement (char-set #\/)))
|
||||
((_ ... "directory" id)
|
||||
(string-append "swh:1:dir:" id))))))
|
||||
|
||||
(define (lookup-origin-revision url tag)
|
||||
"Return a <revision> corresponding to the given TAG for the repository
|
||||
@ -537,31 +543,31 @@ URL could not be found."
|
||||
(match (lookup-origin url)
|
||||
(#f #f)
|
||||
(origin
|
||||
(match (filter (lambda (visit)
|
||||
;; Return #f if (visit-snapshot VISIT) would return #f.
|
||||
(and (visit-snapshot-url visit)
|
||||
(eq? 'full (visit-status visit))))
|
||||
(origin-visits origin))
|
||||
((visit . _)
|
||||
(let ((snapshot (visit-snapshot visit)))
|
||||
(match (and=> (find (lambda (branch)
|
||||
(or
|
||||
;; Git specific.
|
||||
(string=? (string-append "refs/tags/" tag)
|
||||
(branch-name branch))
|
||||
;; Hg specific.
|
||||
(string=? tag
|
||||
(branch-name branch))))
|
||||
(snapshot-branches snapshot))
|
||||
branch-target)
|
||||
((? release? release)
|
||||
(release-target release))
|
||||
((? revision? revision)
|
||||
revision)
|
||||
(#f ;tag not found
|
||||
#f))))
|
||||
(()
|
||||
#f)))))
|
||||
(any (lambda (visit)
|
||||
(and (visit-snapshot-url visit)
|
||||
(eq? 'full (visit-status visit))
|
||||
(let ((snapshot (visit-snapshot visit)))
|
||||
(match (and=> (find (lambda (branch)
|
||||
(or
|
||||
;; Git specific.
|
||||
(string=? (string-append "refs/tags/" tag)
|
||||
(branch-name branch))
|
||||
;; Hg specific.
|
||||
(string=? tag
|
||||
(branch-name branch))))
|
||||
(snapshot-branches snapshot))
|
||||
branch-target)
|
||||
((? release? release)
|
||||
(release-target release))
|
||||
((? revision? revision)
|
||||
revision)
|
||||
(_
|
||||
;; Either the branch points to a directory rather than
|
||||
;; a revision (this is the case for visits of type
|
||||
;; 'git-checkout, 'hg-checkout, 'tarball-directory,
|
||||
;; etc.), or TAG was not found.
|
||||
#f)))))
|
||||
(origin-visits origin 30)))))
|
||||
|
||||
(define (release-target release)
|
||||
"Return the revision that is the target of RELEASE."
|
||||
|
||||
@ -109,6 +109,80 @@
|
||||
(directory-entry-length entry)))
|
||||
(lookup-directory "123"))))
|
||||
|
||||
(test-equal "lookup-origin-revision"
|
||||
'("cd86c72084993d9ef26fc9e24b73cea612b8c97b"
|
||||
"d173c707ee88e3c89401ad77fafa65fcd9e9f5be")
|
||||
(let ()
|
||||
;; Make sure that 'lookup-origin-revision' does the job, and in particular
|
||||
;; that it doesn't stop until it has found an actual revision:
|
||||
;; 'git-checkout visits point to directories instead of revisions.
|
||||
;; See <https://issues.guix.gnu.org/69070>.
|
||||
(define visits
|
||||
;; Two visits of differing types: the first visit (type 'git-checkout')
|
||||
;; points to a directory, the second one (type 'git') points to a
|
||||
;; revision.
|
||||
"[ {
|
||||
\"origin\": \"https://example.org/repo.git\",
|
||||
\"visit\": 1,
|
||||
\"type\": \"git-checkout\",
|
||||
\"date\": \"2020-05-17T21:43:45.422977+00:00\",
|
||||
\"status\": \"full\",
|
||||
\"metadata\": {},
|
||||
\"type\": \"git-checkout\",
|
||||
\"origin_visit_url\": \"/visit/42\",
|
||||
\"snapshot_url\": \"/snapshot/1\"
|
||||
}, {
|
||||
\"origin\": \"https://example.org/repo.git\",
|
||||
\"visit\": 2,
|
||||
\"type\": \"git\",
|
||||
\"date\": \"2020-05-17T21:43:49.422977+00:00\",
|
||||
\"status\": \"full\",
|
||||
\"metadata\": {},
|
||||
\"type\": \"git\",
|
||||
\"origin_visit_url\": \"/visit/41\",
|
||||
\"snapshot_url\": \"/snapshot/2\"
|
||||
} ]")
|
||||
(define snapshot-for-git-checkout
|
||||
"{ \"id\": 42,
|
||||
\"branches\": { \"1.3.2\": {
|
||||
\"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\",
|
||||
\"target_type\": \"directory\",
|
||||
\"target_url\": \"/directory/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\"
|
||||
}}
|
||||
}")
|
||||
(define snapshot-for-git
|
||||
"{ \"id\": 42,
|
||||
\"branches\": { \"1.3.2\": {
|
||||
\"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\",
|
||||
\"target_type\": \"revision\",
|
||||
\"target_url\": \"/revision/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\"
|
||||
}}
|
||||
}")
|
||||
(define revision
|
||||
"{ \"author\": {},
|
||||
\"committer\": {},
|
||||
\"committer_date\": \"2018-05-17T21:43:49.422977+00:00\",
|
||||
\"date\": \"2018-05-17T21:43:49.422977+00:00\",
|
||||
\"directory\": \"d173c707ee88e3c89401ad77fafa65fcd9e9f5be\",
|
||||
\"directory_url\": \"/directory/d173c707ee88e3c89401ad77fafa65fcd9e9f5be\",
|
||||
\"id\": \"cd86c72084993d9ef26fc9e24b73cea612b8c97b\",
|
||||
\"merge\": false,
|
||||
\"message\": \"Fix.\",
|
||||
\"parents\": [],
|
||||
\"type\": \"what type?\"
|
||||
}")
|
||||
|
||||
(with-http-server `((200 ,%origin)
|
||||
(200 ,visits)
|
||||
(200 ,snapshot-for-git-checkout)
|
||||
(200 ,snapshot-for-git)
|
||||
(200 ,revision))
|
||||
(parameterize ((%swh-base-url (%local-url)))
|
||||
(let ((revision (lookup-origin-revision "https://example.org/repo.git"
|
||||
"1.3.2")))
|
||||
(list (revision-id revision)
|
||||
(revision-directory revision)))))))
|
||||
|
||||
(test-equal "lookup-directory-by-nar-hash"
|
||||
"swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153"
|
||||
(with-json-result %external-id
|
||||
|
||||
Loading…
Reference in New Issue
Block a user