[bug#39547] [PATCH] website: Provide JSON sources list used by Software Heritage.

[Ludovic Courtès]

Hello,

zimoun <address@hidden> skribis:

> Format discussed here <https://forge.softwareheritage.org/D2025#51269>.
>
> * website/apps/packages/builder.scm (sources-json-builder): New procedure.

[...]

> +(define (sources-json-builder)
> +  "Return a JSON page listing all the sources."

Please add a reference to
<https://forge.softwareheritage.org/D2025#51269> here.

> +  (define (origin->json origin)
> +    (define method
> +      (origin-method origin))
> +
> +    (define uri                         ;represented as string
> +      (origin-uri origin))
> +
> +    (define (mirror->url uri)
> +      (uri->string (car (maybe-expand-mirrors uri %mirrors))))
> +
> +    (define (resolve urls)
> +      (let* ((url (car urls))
> +             (uri (string->uri url))
> +             (rest (cdr urls)))
> +        (case (uri-scheme uri)
> +          ((mirror) (mirror->url uri))
> +          ((http) url)
> +          ((https) url)
> +          (else
> +           (if (null? rest)
> +               url
> +               (resolve rest))))))
> +
> +    `((type . ,(cond ((eq? url-fetch method) 'url)
> +                     ((eq? git-fetch method) 'git)
> +                     ((eq? svn-fetch method) 'svn)
> +                     (else                   #nil)))
> +      ,@(cond ((eq? url-fetch method)
> +               `(("url" . ,(match uri
> +                               ((? string? url) (mirror->url (string->uri 
> url)))
> +                               ((urls ...) (resolve urls))))))
> +              ((eq? git-fetch method)
> +               `(("git_url" . ,(git-reference-url uri))))
> +              ((eq? svn-fetch method)
> +               `(("svn_url" . ,(svn-reference-url uri))))
> +              (else '()))
> +      ,@(if (eq? method git-fetch)
> +            `(("git_ref" . ,(git-reference-commit uri)))
> +            '())
> +      ,@(if (eq? method svn-fetch)
> +            `(("svn_revision" . ,(svn-reference-revision
> +                                  uri)))
> +            '())))

Could you, in a first patch, move ‘origin->json’ out of
‘packages-json-builder’, and in a second patch, add mirror-expansion
feature?

For mirror:// expansion, I think you can just write something like:

  (define uris
    (append-map (cut maybe-expand-mirrors <> %mirrors)
                (match url
                  ((_ ...) (map string->uri url))
                  (_       (list (string->uri url))))))

and then pick the first element of the list.

In parallel, I’d recommend suggesting a format change or addition that
would allow us to provide all the URLs.  :-)

With those changes in place, I think we’ll be ready to go!

Thanks for working on it, Simon!

Ludo’.