diff --git a/guix/swh.scm b/guix/swh.scm index c7c1c873a2..a65635b1db 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2018, 2019, 2020, 2021, 2023 Ludovic Courtès ;;; Copyright © 2020 Jakub Kądziołka ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Simon Tournier @@ -75,8 +75,10 @@ (define-module (guix swh) revision-id revision-date revision-directory + revision-parents lookup-revision lookup-origin-revision + lookup-subversion-revision content? content-checksums @@ -207,6 +209,14 @@ (define string* ((? null?) #f) ;Guile-JSON 3.x ('null #f))) ;Guile-JSON 4.x +(define pair-vector->alist + (match-lambda + ('null '()) + ((= vector->list lst) + (map (match-lambda + (#(key value) (cons key value))) + lst)))) + (define %allow-request? ;; Takes a URL and method (e.g., the 'http-get' procedure) and returns true ;; to keep going. This can be used to disallow requests when @@ -346,7 +356,14 @@ (define-json-mapping make-revision revision? (id revision-id) (date revision-date "date" (maybe-null string->date*)) (directory revision-directory) - (directory-url revision-directory-url "directory_url")) + (directory-url revision-directory-url "directory_url") + (parents-ids revision-parent-ids "parents" + (lambda (vector) + (map (lambda (alist) + (assoc-ref alist "id")) + (vector->list vector)))) + (extra-headers revision-extra-headers ;alist--e.g., with "svn_revision" + "extra_headers" pair-vector->alist)) ;; (define-json-mapping make-content content? @@ -524,6 +541,50 @@ (define (lookup-origin-revision url tag) (() #f))))) +(define (revision-parents revision) + "Return the parent revision(s) of REVISION." + (filter-map lookup-revision (revision-parent-ids revision))) + +(define (lookup-subversion-revision-in-history revision revision-number) + "Look for Subversion REVISION-NUMBER starting from REVISION and going back +in history." + (let loop ((revision revision)) + (let ((number (and=> (assoc-ref (revision-extra-headers revision) + "svn_revision") + string->number))) + (and number + (cond ((= number revision-number) + ;; Found it! + revision) + ((< number revision-number) + ;; REVISION is ancestor of REVISION-NUMBER, so stop here. + #f) + (else + ;; Check the parent(s) of REVISION. + (any loop (revision-parents revision)))))))) + +(define (lookup-subversion-revision url revision-number) + "Return either #f or the revision of the Subversion repository once +available at URL with the given REVISION-NUMBER." + (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)) + (() + #f) + ((visit . _) + (any (lambda (branch) + (match (branch-target branch) + ((? revision? revision) + (lookup-subversion-revision-in-history revision + revision-number)) + (_ #f))) + (snapshot-branches (visit-snapshot visit)))))))) + (define (release-target release) "Return the revision that is the target of RELEASE." (match (release-target-type release)