me
/
guix
Archived
1
0
Fork 0
Code

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
master
Ludovic Courtès 2024-02-20 16:52:34 +01:00
parent ed9d7d8431
commit ddd455c0dd
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 107 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
guix/swh.scm
View File

@ -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."

74
tests/swh.scm
View File

@ -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