Christopher Baines
e93b8f948e
Make it similar to the revision page, as some of the information, like the link to the relevant CGit instance might be available.
844 lines
35 KiB
Scheme
844 lines
35 KiB
Scheme
;;; Guix Data Service -- Information about Guix over time
|
|
;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
|
|
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
|
|
;;;
|
|
;;; This program is free software: you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU Affero General Public License
|
|
;;; as published by the Free Software Foundation, either version 3 of
|
|
;;; the License, or (at your option) any later version.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; Affero General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU Affero General Public
|
|
;;; License along with this program. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (guix-data-service web controller)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 vlist)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-11)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (web request)
|
|
#:use-module (web uri)
|
|
#:use-module (texinfo)
|
|
#:use-module (texinfo html)
|
|
#:use-module (texinfo plain-text)
|
|
#:use-module (squee)
|
|
#:use-module (json)
|
|
#:use-module (guix-data-service comparison)
|
|
#:use-module (guix-data-service database)
|
|
#:use-module (guix-data-service model git-branch)
|
|
#:use-module (guix-data-service model git-repository)
|
|
#:use-module (guix-data-service model guix-revision)
|
|
#:use-module (guix-data-service model package)
|
|
#:use-module (guix-data-service model package-derivation)
|
|
#:use-module (guix-data-service model package-metadata)
|
|
#:use-module (guix-data-service model derivation)
|
|
#:use-module (guix-data-service model build-status)
|
|
#:use-module (guix-data-service model build)
|
|
#:use-module (guix-data-service jobs load-new-guix-revision)
|
|
#:use-module (guix-data-service web render)
|
|
#:use-module (guix-data-service web sxml)
|
|
#:use-module (guix-data-service web query-parameters)
|
|
#:use-module (guix-data-service web util)
|
|
#:use-module (guix-data-service web view html)
|
|
#:export (controller))
|
|
|
|
(define cache-control-default-max-age
|
|
(* 60 60 24)) ; One day
|
|
|
|
(define http-headers-for-unchanging-content
|
|
`((cache-control
|
|
. (public
|
|
(max-age . ,cache-control-default-max-age)))))
|
|
|
|
(define-syntax-rule (-> target functions ...)
|
|
(fold (lambda (f val) (and=> val f))
|
|
target
|
|
(list functions ...)))
|
|
|
|
(define (render-with-error-handling page message)
|
|
(apply render-html (page))
|
|
;; (catch #t
|
|
;; (lambda ()
|
|
;; (receive (sxml headers)
|
|
;; (pretty-print (page))
|
|
;; (render-html sxml headers)))
|
|
;; (lambda (key . args)
|
|
;; (format #t "ERROR: ~a ~a\n"
|
|
;; key args)
|
|
;; (render-html (error-page message))))
|
|
)
|
|
|
|
(define (assoc-ref-multiple alist key)
|
|
(filter-map
|
|
(match-lambda
|
|
((k . value)
|
|
(and (string=? k key)
|
|
value)))
|
|
alist))
|
|
|
|
(define (with-base-and-target-commits query-parameters conn f)
|
|
(let* ((base-commit (assoc-ref query-parameters "base_commit"))
|
|
(target-commit (assoc-ref query-parameters "target_commit")))
|
|
|
|
(f base-commit
|
|
(commit->revision-id conn base-commit)
|
|
target-commit
|
|
(commit->revision-id conn target-commit))))
|
|
|
|
(define* (render-view-revision mime-types
|
|
conn
|
|
commit-hash
|
|
#:key path-base
|
|
(header-text
|
|
`("Revision " (samp ,commit-hash))))
|
|
(let ((packages-count
|
|
(count-packages-in-revision conn commit-hash))
|
|
(git-repositories-and-branches
|
|
(git-branches-with-repository-details-for-commit conn commit-hash))
|
|
(derivations-counts
|
|
(count-packages-derivations-in-revision conn commit-hash)))
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
`((packages_count . ,(caar packages-count))
|
|
(derivations_counts . ,(list->vector
|
|
(map (match-lambda
|
|
((system target derivation_count)
|
|
`((system . ,system)
|
|
(target . ,target)
|
|
(derivation_count . ,derivation_count))))
|
|
derivations-counts))))
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
(else
|
|
(render-html
|
|
#:sxml (view-revision
|
|
commit-hash
|
|
packages-count
|
|
git-repositories-and-branches
|
|
derivations-counts
|
|
#:path-base path-base
|
|
#:header-text header-text)
|
|
#:extra-headers http-headers-for-unchanging-content)))))
|
|
|
|
(define (texinfo->variants-alist s)
|
|
(let ((stexi (texi-fragment->stexi s)))
|
|
`((source . ,s)
|
|
(html . ,(with-output-to-string
|
|
(lambda ()
|
|
(sxml->html (stexi->shtml stexi)))))
|
|
(plain . ,(stexi->plain-text stexi)))))
|
|
|
|
(define (render-unknown-revision mime-types conn commit-hash)
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
'((unknown_commit . ,commit-hash))
|
|
#:code 404))
|
|
(else
|
|
(render-html
|
|
#:code 404
|
|
#:sxml (unknown-revision
|
|
commit-hash
|
|
(select-job-for-commit
|
|
conn commit-hash)
|
|
(git-branches-with-repository-details-for-commit conn commit-hash))))))
|
|
|
|
(define* (render-revision-packages mime-types
|
|
conn
|
|
commit-hash
|
|
query-parameters
|
|
#:key
|
|
(path-base "/revision/")
|
|
(header-text
|
|
`("Revision " (samp ,commit-hash)))
|
|
(header-link
|
|
(string-append "/revision/" commit-hash)))
|
|
(if (any-invalid-query-parameters? query-parameters)
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
`((error . "invalid query"))))
|
|
(else
|
|
(render-html
|
|
#:sxml (view-revision-packages commit-hash
|
|
query-parameters
|
|
'()
|
|
'()
|
|
#f))))
|
|
|
|
(let* ((search-query (assq-ref query-parameters 'search_query))
|
|
(limit-results (or (assq-ref query-parameters 'limit_results)
|
|
99999)) ; TODO There shouldn't be a limit
|
|
(fields (assq-ref query-parameters 'field))
|
|
(packages
|
|
(if search-query
|
|
(search-packages-in-revision
|
|
conn
|
|
commit-hash
|
|
search-query
|
|
#:limit-results limit-results)
|
|
(select-packages-in-revision
|
|
conn
|
|
commit-hash
|
|
#:limit-results limit-results
|
|
#:after-name (assq-ref query-parameters 'after_name))))
|
|
(git-repositories
|
|
(git-repositories-containing-commit conn
|
|
commit-hash))
|
|
(show-next-page?
|
|
(and (not search-query)
|
|
(>= (length packages)
|
|
limit-results))))
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
`((revision
|
|
. ((commit . ,commit-hash)))
|
|
(packages
|
|
. ,(list->vector
|
|
(map (match-lambda
|
|
((name version synopsis description home-page
|
|
location-file location-line
|
|
location-column-number licenses)
|
|
`((name . ,name)
|
|
,@(if (member "version" fields)
|
|
`((version . ,version))
|
|
'())
|
|
,@(if (member "synopsis" fields)
|
|
`((synopsis
|
|
. ,(texinfo->variants-alist synopsis)))
|
|
'())
|
|
,@(if (member "description" fields)
|
|
`((description
|
|
. ,(texinfo->variants-alist description)))
|
|
'())
|
|
,@(if (member "home-page" fields)
|
|
`((home-page . ,home-page))
|
|
'())
|
|
,@(if (member "location" fields)
|
|
`((location
|
|
. ((file . ,location-file)
|
|
(line . ,location-line)
|
|
(column . ,location-column-number))))
|
|
'())
|
|
,@(if (member "licenses" fields)
|
|
`((licenses
|
|
. ,(if (string-null? licenses)
|
|
#()
|
|
(json-string->scm licenses))))
|
|
'()))))
|
|
packages))))
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
(else
|
|
(render-html
|
|
#:sxml (view-revision-packages commit-hash
|
|
query-parameters
|
|
packages
|
|
git-repositories
|
|
show-next-page?
|
|
#:path-base path-base
|
|
#:header-text header-text
|
|
#:header-link header-link)
|
|
#:extra-headers http-headers-for-unchanging-content))))))
|
|
|
|
(define* (render-revision-package mime-types
|
|
conn
|
|
commit-hash
|
|
name
|
|
version
|
|
#:key
|
|
(header-text
|
|
`("Revision "
|
|
(samp ,commit-hash)))
|
|
(header-link
|
|
(string-append
|
|
"/revision/" commit-hash)))
|
|
(let ((metadata
|
|
(select-package-metadata-by-revision-name-and-version
|
|
conn
|
|
commit-hash
|
|
name
|
|
version))
|
|
(derivations
|
|
(select-derivations-by-revision-name-and-version
|
|
conn
|
|
commit-hash
|
|
name
|
|
version))
|
|
(git-repositories
|
|
(git-repositories-containing-commit conn
|
|
commit-hash)))
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
`((name . ,name)
|
|
(version . ,version)
|
|
,@(match metadata
|
|
(((synopsis description home-page))
|
|
`((synopsis . ,synopsis)
|
|
(description . ,description)
|
|
(home-page . ,home-page))))
|
|
(derivations . ,(list->vector
|
|
(map (match-lambda
|
|
((system target file-name status)
|
|
`((system . ,system)
|
|
(target . ,target)
|
|
(derivation . ,file-name))))
|
|
derivations))))
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
(else
|
|
(render-html
|
|
#:sxml (view-revision-package-and-version commit-hash
|
|
name
|
|
version
|
|
metadata
|
|
derivations
|
|
git-repositories
|
|
#:header-text header-text
|
|
#:header-link header-link)
|
|
#:extra-headers http-headers-for-unchanging-content)))))
|
|
|
|
(define (render-compare-unknown-commit mime-types
|
|
conn
|
|
base-commit
|
|
base-revision-id
|
|
target-commit
|
|
target-revision-id)
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
'((unknown_commit . #t))))
|
|
(else
|
|
(render-html
|
|
#:sxml (compare-unknown-commit base-commit
|
|
target-commit
|
|
(if base-revision-id #t #f)
|
|
(if target-revision-id #t #f)
|
|
(select-job-for-commit conn
|
|
base-commit)
|
|
(select-job-for-commit conn
|
|
target-commit))))))
|
|
|
|
(define (render-compare mime-types
|
|
conn
|
|
base-commit
|
|
base-revision-id
|
|
target-commit
|
|
target-revision-id)
|
|
(let-values
|
|
(((base-packages-vhash target-packages-vhash)
|
|
(package-data->package-data-vhashes
|
|
(package-differences-data conn
|
|
base-revision-id
|
|
target-revision-id))))
|
|
(let* ((new-packages
|
|
(package-data-vhashes->new-packages base-packages-vhash
|
|
target-packages-vhash))
|
|
(removed-packages
|
|
(package-data-vhashes->removed-packages base-packages-vhash
|
|
target-packages-vhash))
|
|
(version-changes
|
|
(package-data-version-changes base-packages-vhash
|
|
target-packages-vhash))
|
|
(derivation-changes
|
|
(package-data-derivation-changes base-packages-vhash
|
|
target-packages-vhash)))
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
`((new-packages . ,(list->vector new-packages))
|
|
(removed-packages . ,(list->vector removed-packages))
|
|
(version-changes . ,version-changes)
|
|
(derivation-changes . ,derivation-changes))
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
(else
|
|
(render-html
|
|
#:sxml (compare base-commit
|
|
target-commit
|
|
new-packages
|
|
removed-packages
|
|
version-changes
|
|
derivation-changes)
|
|
#:extra-headers http-headers-for-unchanging-content))))))
|
|
|
|
(define (render-compare/derivations mime-types
|
|
conn
|
|
query-parameters)
|
|
(define (derivations->alist derivations)
|
|
(map (match-lambda
|
|
((file-name system target buildstatus)
|
|
`((file_name . ,file-name)
|
|
(system . ,system)
|
|
(target . ,target)
|
|
(build_status . ,(if (string=? buildstatus "")
|
|
"unknown"
|
|
buildstatus)))))
|
|
derivations))
|
|
|
|
(if (any-invalid-query-parameters? query-parameters)
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
'((error . "invalid query"))))
|
|
(else
|
|
(render-html
|
|
#:sxml (compare/derivations
|
|
query-parameters
|
|
(valid-systems conn)
|
|
build-status-strings
|
|
'()
|
|
'()))))
|
|
|
|
(let ((base-commit (assq-ref query-parameters 'base_commit))
|
|
(target-commit (assq-ref query-parameters 'target_commit))
|
|
(systems (assq-ref query-parameters 'system))
|
|
(targets (assq-ref query-parameters 'target))
|
|
(build-statuses (assq-ref query-parameters 'build_status)))
|
|
(let-values
|
|
(((base-packages-vhash target-packages-vhash)
|
|
(package-data->package-data-vhashes
|
|
(package-differences-data conn
|
|
(commit->revision-id conn base-commit)
|
|
(commit->revision-id conn target-commit)))))
|
|
(let ((base-derivations
|
|
(package-data-vhash->derivations-and-build-status
|
|
conn
|
|
base-packages-vhash
|
|
systems
|
|
targets
|
|
build-statuses))
|
|
(target-derivations
|
|
(package-data-vhash->derivations-and-build-status
|
|
conn
|
|
target-packages-vhash
|
|
systems
|
|
targets
|
|
build-statuses)))
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
`((base . ((commit . ,base-commit)
|
|
(derivations . ,(list->vector
|
|
(derivations->alist
|
|
base-derivations)))))
|
|
(target . ((commit . ,target-commit)
|
|
(derivations . ,(list->vector
|
|
(derivations->alist
|
|
target-derivations))))))
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
(else
|
|
(render-html
|
|
#:sxml (compare/derivations
|
|
query-parameters
|
|
(valid-systems conn)
|
|
build-status-strings
|
|
base-derivations
|
|
target-derivations)
|
|
#:extra-headers http-headers-for-unchanging-content))))))))
|
|
|
|
(define (render-compare/packages mime-types
|
|
conn
|
|
base-commit
|
|
base-revision-id
|
|
target-commit
|
|
target-revision-id)
|
|
(define (package-data-vhash->json vh)
|
|
(delete-duplicates
|
|
(vhash-fold (lambda (name data result)
|
|
(cons `((name . ,name)
|
|
(version . ,(car data)))
|
|
result))
|
|
'()
|
|
vh)))
|
|
|
|
(let-values
|
|
(((base-packages-vhash target-packages-vhash)
|
|
(package-data->package-data-vhashes
|
|
(package-differences-data conn
|
|
base-revision-id
|
|
target-revision-id))))
|
|
(case (most-appropriate-mime-type
|
|
'(application/json text/html)
|
|
mime-types)
|
|
((application/json)
|
|
(render-json
|
|
`((base
|
|
. ((commit . ,base-commit)
|
|
(packages . ,(list->vector
|
|
(package-data-vhash->json base-packages-vhash)))))
|
|
(target
|
|
. ((commit . ,target-commit)
|
|
(packages . ,(list->vector
|
|
(package-data-vhash->json target-packages-vhash))))))
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
(else
|
|
(render-html
|
|
#:sxml (compare/packages
|
|
base-commit
|
|
target-commit
|
|
base-packages-vhash
|
|
target-packages-vhash)
|
|
#:extra-headers http-headers-for-unchanging-content)))))
|
|
|
|
(define (render-derivation conn derivation-file-name)
|
|
(let ((derivation (select-derivation-by-file-name conn
|
|
derivation-file-name)))
|
|
(if derivation
|
|
(let ((derivation-inputs (select-derivation-inputs-by-derivation-id
|
|
conn
|
|
(first derivation)))
|
|
(derivation-outputs (select-derivation-outputs-by-derivation-id
|
|
conn
|
|
(first derivation)))
|
|
(builds (select-builds-with-context-by-derivation-id
|
|
conn
|
|
(first derivation))))
|
|
(render-html
|
|
#:sxml (view-derivation derivation
|
|
derivation-inputs
|
|
derivation-outputs
|
|
builds)
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
|
|
#f ;; TODO
|
|
)))
|
|
|
|
(define (render-store-item conn filename)
|
|
(let ((derivation (select-derivation-by-output-filename conn filename)))
|
|
(match derivation
|
|
(()
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"Store item not found"
|
|
"No derivation found producing this output")
|
|
#:code 404))
|
|
(derivations
|
|
(render-html
|
|
#:sxml (view-store-item filename
|
|
derivations
|
|
(map (lambda (derivation)
|
|
(match derivation
|
|
((file-name output-id rest ...)
|
|
(select-derivations-using-output
|
|
conn output-id))))
|
|
derivations))
|
|
#:extra-headers http-headers-for-unchanging-content)))))
|
|
|
|
(define (render-jobs mime-types conn)
|
|
(render-html
|
|
#:sxml (view-jobs
|
|
(select-jobs-and-events conn))))
|
|
|
|
(define (parse-commit conn)
|
|
(lambda (s)
|
|
(if (guix-commit-exists? conn s)
|
|
s
|
|
(make-invalid-query-parameter
|
|
s "unknown commit"))))
|
|
|
|
(define (parse-system s)
|
|
s)
|
|
|
|
(define (parse-build-status s)
|
|
s)
|
|
|
|
(define (controller request method-and-path-components mime-types body)
|
|
(match method-and-path-components
|
|
((GET "assets" rest ...)
|
|
(or (render-static-asset (string-join rest "/")
|
|
(request-headers request))
|
|
(not-found (request-uri request))))
|
|
((GET "healthcheck")
|
|
(let ((database-status
|
|
(catch
|
|
#t
|
|
(lambda ()
|
|
(with-postgresql-connection
|
|
(lambda (conn)
|
|
(number?
|
|
(string->number
|
|
(first
|
|
(count-guix-revisions conn)))))))
|
|
(lambda (key . args)
|
|
#f))))
|
|
(render-json
|
|
`((status . ,(if database-status
|
|
"ok"
|
|
"not ok")))
|
|
#:code (if (eq? database-status
|
|
#t)
|
|
200
|
|
500))))
|
|
(_
|
|
(with-postgresql-connection
|
|
(lambda (conn)
|
|
(controller-with-database-connection request
|
|
method-and-path-components
|
|
mime-types
|
|
body
|
|
conn))))))
|
|
|
|
(define (controller-with-database-connection request
|
|
method-and-path-components
|
|
mime-types
|
|
body
|
|
conn)
|
|
(define query-parameters
|
|
(-> request
|
|
request-uri
|
|
uri-query
|
|
parse-query-string))
|
|
|
|
(define path
|
|
(uri-path (request-uri request)))
|
|
|
|
(match method-and-path-components
|
|
((GET)
|
|
(render-html
|
|
#:sxml (index
|
|
(map
|
|
(lambda (git-repository-details)
|
|
(cons
|
|
git-repository-details
|
|
(map
|
|
(match-lambda
|
|
((id job-id commit source)
|
|
(list id
|
|
job-id
|
|
commit
|
|
source
|
|
(git-branches-for-commit conn commit))))
|
|
(guix-revisions-and-jobs-for-git-repository
|
|
conn
|
|
(car git-repository-details)))))
|
|
(all-git-repositories conn)))))
|
|
((GET "builds")
|
|
(render-html
|
|
#:sxml (view-builds (select-build-stats conn)
|
|
(select-builds-with-context conn))))
|
|
((GET "statistics")
|
|
(render-html
|
|
#:sxml (view-statistics (count-guix-revisions conn)
|
|
(count-derivations conn))))
|
|
((GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash)
|
|
(render-view-revision mime-types
|
|
conn
|
|
commit-hash
|
|
#:path-base path)
|
|
(render-unknown-revision mime-types
|
|
conn
|
|
commit-hash)))
|
|
((GET "revision" commit-hash "packages")
|
|
(if (guix-commit-exists? conn commit-hash)
|
|
(let ((parsed-query-parameters
|
|
(guard-against-mutually-exclusive-query-parameters
|
|
(parse-query-parameters
|
|
request
|
|
`((after_name ,identity)
|
|
(field ,identity #:multi-value
|
|
#:default ("version" "synopsis"))
|
|
(search_query ,identity)
|
|
(limit_results ,parse-result-limit
|
|
#:no-default-when (all_results)
|
|
#:default 100)
|
|
(all_results ,parse-checkbox-value)))
|
|
;; You can't specify a search query, but then also limit the
|
|
;; results by filtering for after a particular package name
|
|
'((after_name search_query)
|
|
(limit_results all_results)))))
|
|
|
|
(render-revision-packages mime-types
|
|
conn
|
|
commit-hash
|
|
parsed-query-parameters
|
|
#:path-base path))
|
|
(render-unknown-revision mime-types
|
|
conn
|
|
commit-hash)))
|
|
((GET "revision" commit-hash "package" name version)
|
|
(if (guix-commit-exists? conn commit-hash)
|
|
(render-revision-package mime-types
|
|
conn
|
|
commit-hash
|
|
name
|
|
version)
|
|
(render-unknown-revision mime-types
|
|
conn
|
|
commit-hash)))
|
|
((GET "branches")
|
|
(render-html
|
|
#:sxml (view-branches
|
|
(all-branches-with-most-recent-commit conn))))
|
|
((GET "branch" branch-name)
|
|
(let ((parsed-query-parameters
|
|
(parse-query-parameters
|
|
request
|
|
`((after_date ,parse-datetime)
|
|
(before_date ,parse-datetime)
|
|
(limit_results ,parse-result-limit #:default 100)))))
|
|
(render-html
|
|
#:sxml (if (any-invalid-query-parameters? parsed-query-parameters)
|
|
(view-branch branch-name parsed-query-parameters '())
|
|
(view-branch
|
|
branch-name
|
|
parsed-query-parameters
|
|
(most-recent-commits-for-branch
|
|
conn
|
|
branch-name
|
|
#:limit (assq-ref parsed-query-parameters 'limit_results)
|
|
#:after-date (assq-ref parsed-query-parameters
|
|
'after_date)
|
|
#:before-date (assq-ref parsed-query-parameters
|
|
'before_date)))))))
|
|
((GET "branch" branch-name "latest-processed-revision")
|
|
(let ((commit-hash
|
|
(latest-processed-commit-for-branch conn branch-name)))
|
|
(if commit-hash
|
|
(render-view-revision mime-types
|
|
conn
|
|
commit-hash
|
|
#:path-base path
|
|
#:header-text
|
|
`("Latest processed revision for branch "
|
|
(samp ,branch-name)))
|
|
(render-unknown-revision mime-types
|
|
conn
|
|
commit-hash))))
|
|
((GET "branch" branch-name "latest-processed-revision" "packages")
|
|
(let ((commit-hash
|
|
(latest-processed-commit-for-branch conn branch-name)))
|
|
(if commit-hash
|
|
(let ((parsed-query-parameters
|
|
(guard-against-mutually-exclusive-query-parameters
|
|
(parse-query-parameters
|
|
request
|
|
`((after_name ,identity)
|
|
(field ,identity #:multi-value
|
|
#:default ("version" "synopsis"))
|
|
(search_query ,identity)
|
|
(limit_results ,parse-result-limit
|
|
#:no-default-when (all_results)
|
|
#:default 100)
|
|
(all_results ,parse-checkbox-value)))
|
|
;; You can't specify a search query, but then also limit the
|
|
;; results by filtering for after a particular package name
|
|
'((after_name search_query)
|
|
(limit_results all_results)))))
|
|
|
|
(render-revision-packages mime-types
|
|
conn
|
|
commit-hash
|
|
parsed-query-parameters
|
|
#:path-base path
|
|
#:header-text
|
|
`("Latest processed revision for branch "
|
|
(samp ,branch-name))
|
|
#:header-link
|
|
(string-append
|
|
"/branch/" branch-name
|
|
"/latest-processed-revision")))
|
|
(render-unknown-revision mime-types
|
|
conn
|
|
commit-hash))))
|
|
((GET "branch" branch-name "latest-processed-revision" "package" name version)
|
|
(let ((commit-hash
|
|
(latest-processed-commit-for-branch conn branch-name)))
|
|
(if commit-hash
|
|
(render-revision-package mime-types
|
|
conn
|
|
commit-hash
|
|
name
|
|
version
|
|
#:header-text
|
|
`("Latest processed revision for branch "
|
|
(samp ,branch-name))
|
|
#:header-link
|
|
(string-append
|
|
"/branch/" branch-name
|
|
"/latest-processed-revision"))
|
|
(render-unknown-revision mime-types
|
|
conn
|
|
commit-hash))))
|
|
((GET "gnu" "store" filename)
|
|
;; These routes are a little special, as the extensions aren't used for
|
|
;; content negotiation, so just use the path from the request
|
|
(let ((path (uri-path (request-uri request))))
|
|
(if (string-suffix? ".drv" path)
|
|
(render-derivation conn path)
|
|
(render-store-item conn path))))
|
|
((GET "compare")
|
|
(with-base-and-target-commits
|
|
query-parameters conn
|
|
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
|
(if (not (and base-revision-id target-revision-id))
|
|
(render-compare-unknown-commit mime-types
|
|
conn
|
|
base-commit
|
|
base-revision-id
|
|
target-commit
|
|
target-revision-id)
|
|
(render-compare mime-types
|
|
conn
|
|
base-commit
|
|
base-revision-id
|
|
target-commit
|
|
target-revision-id)))))
|
|
((GET "compare" "derivations")
|
|
(let* ((parsed-query-parameters
|
|
(parse-query-parameters
|
|
request
|
|
`((base_commit ,(parse-commit conn) #:required)
|
|
(target_commit ,(parse-commit conn) #:required)
|
|
(system ,parse-system #:multi-value)
|
|
(target ,parse-system #:multi-value)
|
|
(build_status ,parse-build-status #:multi-value)))))
|
|
(render-compare/derivations mime-types
|
|
conn
|
|
parsed-query-parameters)))
|
|
((GET "compare" "packages")
|
|
(with-base-and-target-commits
|
|
query-parameters conn
|
|
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
|
(if (not (and base-revision-id target-revision-id))
|
|
(render-compare-unknown-commit mime-types
|
|
conn
|
|
base-commit
|
|
base-revision-id
|
|
target-commit
|
|
target-revision-id)
|
|
(render-compare/packages mime-types
|
|
conn
|
|
base-commit
|
|
base-revision-id
|
|
target-commit
|
|
target-revision-id)))))
|
|
((GET "jobs")
|
|
(render-jobs mime-types
|
|
conn))
|
|
((GET path ...)
|
|
(not-found (request-uri request)))))
|