@@ -516,14 +516,20 @@ (define (lookup-snapshot-branch snapshot name)
(_ #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 @@ (define (lookup-origin-revision url tag)
(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 @@ (define-syntax-rule (with-json-result str exp ...)
(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
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 --- guix/swh.scm | 60 ++++++++++++++++++++++------------------- tests/swh.scm | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 107 insertions(+), 27 deletions(-)