506 lines
21 KiB
Scheme
506 lines
21 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 (ice-9 textual-ports)
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-11)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (system repl error-handling)
|
|
#:use-module (web request)
|
|
#:use-module (web response)
|
|
#:use-module (web uri)
|
|
#:use-module (texinfo)
|
|
#:use-module (texinfo html)
|
|
#:use-module (squee)
|
|
#:use-module (json)
|
|
#:use-module (prometheus)
|
|
#:use-module (guix-data-service config)
|
|
#:use-module (guix-data-service comparison)
|
|
#:use-module (guix-data-service database)
|
|
#:use-module (guix-data-service metrics)
|
|
#: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 nar)
|
|
#: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 model lint-checker)
|
|
#:use-module (guix-data-service model lint-warning)
|
|
#:use-module (guix-data-service model utils)
|
|
#: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 build controller)
|
|
#:use-module (guix-data-service web dumps controller)
|
|
#:use-module (guix-data-service web revision controller)
|
|
#:use-module (guix-data-service web nar controller)
|
|
#:use-module (guix-data-service web jobs controller)
|
|
#:use-module (guix-data-service web view html)
|
|
#:use-module (guix-data-service web build-server controller)
|
|
#:use-module (guix-data-service web compare controller)
|
|
#:use-module (guix-data-service web revision controller)
|
|
#:use-module (guix-data-service web repository controller)
|
|
#:export (%show-error-details
|
|
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-metrics
|
|
(let* ((registry (make-metrics-registry
|
|
#:namespace "guixdataservice"))
|
|
(table-row-estimate-metric (make-gauge-metric registry
|
|
"table_row_estimate"
|
|
#:labels '(name)))
|
|
(table-bytes-metric (make-gauge-metric registry
|
|
"table_bytes"
|
|
#:labels '(name)))
|
|
(table-index-bytes-metric (make-gauge-metric registry
|
|
"table_index_bytes"
|
|
#:labels '(name)))
|
|
(table-toast-bytes-metric (make-gauge-metric registry
|
|
"table_toast_bytes"
|
|
#:labels '(name))))
|
|
(lambda (conn)
|
|
(let ((metric-values (fetch-high-level-table-size-metrics conn)))
|
|
(for-each (match-lambda
|
|
((name row-estimate table-bytes index-bytes toast-bytes)
|
|
|
|
(metric-set table-row-estimate-metric
|
|
row-estimate
|
|
#:label-values `((name . ,name)))
|
|
(metric-set table-bytes-metric
|
|
table-bytes
|
|
#:label-values `((name . ,name)))
|
|
(metric-set table-index-bytes-metric
|
|
index-bytes
|
|
#:label-values `((name . ,name)))
|
|
(metric-set table-toast-bytes-metric
|
|
toast-bytes
|
|
#:label-values `((name . ,name)))))
|
|
metric-values))
|
|
|
|
(list (build-response
|
|
#:code 200
|
|
#:headers '((content-type . (text/plain))))
|
|
(lambda (port)
|
|
(write-metrics registry port))))))
|
|
|
|
(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-file-name
|
|
conn
|
|
(second derivation))))
|
|
(render-html
|
|
#:sxml (view-derivation derivation
|
|
derivation-inputs
|
|
derivation-outputs
|
|
builds)
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"Derivation not found"
|
|
"No derivation found with this file name.")
|
|
#:code 404))))
|
|
|
|
(define (render-json-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)))
|
|
(derivation-sources (select-derivation-sources-by-derivation-id
|
|
conn
|
|
(first derivation))))
|
|
(render-json
|
|
`((inputs . ,(list->vector
|
|
(map
|
|
(match-lambda
|
|
((filename outputs)
|
|
`((filename . ,filename)
|
|
(out_name
|
|
. ,(list->vector
|
|
(map
|
|
(lambda (output)
|
|
(assoc-ref output "output_name"))
|
|
(vector->list outputs)))))))
|
|
derivation-inputs)))
|
|
(outputs . ,(list->vector
|
|
(map
|
|
(match-lambda
|
|
((output-name path hash-algorithm hash recursive?)
|
|
`((output-name . ,output-name)
|
|
(path . ,path)
|
|
(hash-algorithm . ,hash-algorithm)
|
|
(recursive? . ,recursive?))))
|
|
derivation-outputs)))
|
|
(sources . ,(list->vector derivation-sources))
|
|
,@(match derivation
|
|
((_ _ builder args env-var system)
|
|
`((system . ,system)
|
|
(builder . ,builder)
|
|
(arguments . ,(list->vector args))
|
|
(environment-variables
|
|
. ,(map (lambda (var)
|
|
(cons (assq-ref var 'key)
|
|
(assq-ref var 'value)))
|
|
env-var))))))))
|
|
(render-json '((error . "invalid path"))))))
|
|
|
|
(define (render-formatted-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)))
|
|
(derivation-sources (select-derivation-sources-by-derivation-id
|
|
conn
|
|
(first derivation))))
|
|
(render-html
|
|
#:sxml (view-formatted-derivation derivation
|
|
derivation-inputs
|
|
derivation-outputs
|
|
derivation-sources)
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"Derivation not found"
|
|
"No derivation found with this file name.")
|
|
#:code 404))))
|
|
|
|
(define (render-narinfos conn filename)
|
|
(let ((narinfos (select-nars-for-output
|
|
conn
|
|
(string-append "/gnu/store/" filename))))
|
|
(if (null? narinfos)
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"No nars found"
|
|
"No nars found for this output name.")
|
|
#:code 404)
|
|
|
|
(render-html
|
|
#:sxml (view-narinfos narinfos)))))
|
|
|
|
(define (render-store-item conn filename)
|
|
(let ((derivation (select-derivation-by-output-filename conn filename)))
|
|
(match derivation
|
|
(()
|
|
(match (select-derivation-source-file-by-store-path conn filename)
|
|
(()
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"Store item not found"
|
|
"No derivation found producing this output")
|
|
#:code 404))
|
|
((id)
|
|
(render-html
|
|
#:sxml (view-derivation-source-file
|
|
filename
|
|
(select-derivation-source-file-nar-details-by-file-name conn
|
|
filename))
|
|
#:extra-headers http-headers-for-unchanging-content))))
|
|
(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)
|
|
(select-nars-for-output conn
|
|
filename)
|
|
(select-builds-with-context-by-derivation-output
|
|
conn filename)))))))
|
|
|
|
(define (render-json-store-item conn filename)
|
|
(let ((derivation (select-derivation-by-output-filename conn filename)))
|
|
(match derivation
|
|
(()
|
|
(match (select-derivation-source-file-by-store-path conn filename)
|
|
(()
|
|
(render-json '((error . "store item not found"))))
|
|
((id)
|
|
(render-json
|
|
`((derivation-source-file
|
|
. ,(list->vector
|
|
(map
|
|
(match-lambda
|
|
((key . value)
|
|
`((,key . ,value))))
|
|
(select-derivation-source-file-nar-details-by-file-name
|
|
conn
|
|
filename)))))))))
|
|
(derivations
|
|
(render-json
|
|
`((nars . ,(list->vector
|
|
(map
|
|
(match-lambda
|
|
((_ hash _ urls signatures)
|
|
`((hash . ,hash)
|
|
(urls
|
|
. ,(list->vector
|
|
(map
|
|
(lambda (url-data)
|
|
`((size . ,(assoc-ref url-data "size"))
|
|
(compression . ,(assoc-ref url-data "compression"))
|
|
(url . ,(assoc-ref url-data "url"))))
|
|
urls)))
|
|
(signatures
|
|
. ,(list->vector
|
|
(map
|
|
(lambda (signature)
|
|
`((version . ,(assoc-ref signature "version"))
|
|
(host-name . ,(assoc-ref signature "host_name"))))
|
|
signatures))))))
|
|
(select-nars-for-output conn filename))))
|
|
(derivations
|
|
. ,(list->vector
|
|
(map
|
|
(match-lambda
|
|
((filename output-id)
|
|
`((filename . ,filename)
|
|
(derivations-using-store-item
|
|
. ,(list->vector
|
|
(map car (select-derivations-using-output
|
|
conn output-id)))))))
|
|
derivations)))))))))
|
|
|
|
(define handle-static-assets
|
|
(if assets-dir-in-store?
|
|
(static-asset-from-store-renderer)
|
|
render-static-asset))
|
|
|
|
(define %show-error-details
|
|
(make-parameter #f))
|
|
|
|
(define* (controller request method-and-path-components
|
|
mime-types body
|
|
secret-key-base
|
|
#:key postgresql-statement-timeout)
|
|
(define (controller-thunk)
|
|
(match method-and-path-components
|
|
(('GET "assets" rest ...)
|
|
(or (handle-static-assets (string-join rest "/")
|
|
(request-headers request))
|
|
(not-found (request-uri request))))
|
|
(('GET "healthcheck")
|
|
(let ((database-status
|
|
(catch
|
|
#t
|
|
(lambda ()
|
|
(with-postgresql-connection
|
|
"web healthcheck"
|
|
(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))))
|
|
(('GET "README")
|
|
(let ((filename (string-append (%config 'doc-dir) "/README.html")))
|
|
(if (file-exists? filename)
|
|
(render-html
|
|
#:sxml (readme (call-with-input-file filename
|
|
get-string-all)))
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"README not found"
|
|
"The README.html file does not exist")
|
|
#:code 404))))
|
|
(_
|
|
(with-postgresql-connection
|
|
"web"
|
|
(lambda (conn)
|
|
(controller-with-database-connection request
|
|
method-and-path-components
|
|
mime-types
|
|
body
|
|
conn
|
|
secret-key-base))
|
|
#:statement-timeout postgresql-statement-timeout))))
|
|
(call-with-error-handling
|
|
controller-thunk
|
|
#:on-error 'backtrace
|
|
#:post-error (lambda args
|
|
(render-html #:sxml (error-page
|
|
(if (%show-error-details)
|
|
args
|
|
#f))
|
|
#:code 500))))
|
|
|
|
(define (controller-with-database-connection request
|
|
method-and-path-components
|
|
mime-types
|
|
body
|
|
conn
|
|
secret-key-base)
|
|
(define path
|
|
(uri-path (request-uri request)))
|
|
|
|
(define (delegate-to f)
|
|
(or (f request
|
|
method-and-path-components
|
|
mime-types
|
|
body
|
|
conn)
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"Page not found"
|
|
"")
|
|
#:code 404)))
|
|
|
|
(define (delegate-to-with-secret-key-base f)
|
|
(or (f request
|
|
method-and-path-components
|
|
mime-types
|
|
body
|
|
conn
|
|
secret-key-base)
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"Page not found"
|
|
"")
|
|
#:code 404)))
|
|
|
|
(match method-and-path-components
|
|
(('GET)
|
|
(render-html
|
|
#:sxml (index
|
|
(map
|
|
(lambda (git-repository-details)
|
|
(cons
|
|
git-repository-details
|
|
(all-branches-with-most-recent-commit
|
|
conn (first git-repository-details))))
|
|
(all-git-repositories conn)))))
|
|
(('GET "builds")
|
|
(delegate-to build-controller))
|
|
(('GET "statistics")
|
|
(render-html
|
|
#:sxml (view-statistics (count-guix-revisions conn)
|
|
(count-derivations conn))))
|
|
(('GET "metrics")
|
|
(render-metrics conn))
|
|
(('GET "revision" args ...)
|
|
(delegate-to revision-controller))
|
|
(('GET "repositories")
|
|
(delegate-to repository-controller))
|
|
(('GET "repository" _ ...)
|
|
(delegate-to repository-controller))
|
|
(('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 "gnu" "store" filename "formatted")
|
|
(if (string-suffix? ".drv" filename)
|
|
(render-formatted-derivation conn
|
|
(string-append "/gnu/store/" filename))
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"Not a derivation"
|
|
"The formatted display is only for derivations, where the filename ends in .drv")
|
|
#:code 404)))
|
|
(('GET "gnu" "store" filename "plain")
|
|
(if (string-suffix? ".drv" filename)
|
|
(let ((raw-drv
|
|
(select-serialized-derivation-by-file-name
|
|
conn
|
|
(string-append "/gnu/store/" filename))))
|
|
(if raw-drv
|
|
(render-text raw-drv)
|
|
(not-found (request-uri request))))
|
|
(not-found (request-uri request))))
|
|
(('GET "gnu" "store" filename "narinfos")
|
|
(render-narinfos conn filename))
|
|
(('GET "gnu" "store" filename "json")
|
|
(if (string-suffix? ".drv" filename)
|
|
(render-json-derivation conn
|
|
(string-append "/gnu/store/" filename))
|
|
(render-json-store-item conn (string-append "/gnu/store/" filename))))
|
|
(('GET "build-servers")
|
|
(delegate-to-with-secret-key-base build-server-controller))
|
|
(('GET "dumps" _ ...)
|
|
(delegate-to dumps-controller))
|
|
(((or 'GET 'POST) "build-server" _ ...)
|
|
(delegate-to-with-secret-key-base build-server-controller))
|
|
(('GET "compare" _ ...) (delegate-to compare-controller))
|
|
(('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
|
|
(('GET "jobs" _ ...) (delegate-to jobs-controller))
|
|
(('GET "job" job-id) (delegate-to jobs-controller))
|
|
(('GET _ ...) (delegate-to nar-controller))
|
|
((method path ...)
|
|
(render-html
|
|
#:sxml (general-not-found
|
|
"Page not found"
|
|
"")
|
|
#:code 404))))
|