;;; 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 (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 (guix-data-service config)
#: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 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 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 (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 (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-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)
#: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)))))))
(define handle-static-assets
(if assets-dir-in-store?
(static-asset-from-store-renderer)
render-static-asset))
(define (controller request method-and-path-components
mime-types body
secret-key-base)
(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))))))
(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)
(not-found (request-uri request))))
(define (delegate-to-with-secret-key-base f)
(or (f request
method-and-path-components
mime-types
body
conn
secret-key-base)
(not-found (request-uri request))))
(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 "revision" args ...)
(delegate-to revision-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))
(not-found (request-uri request))))
(('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))
(((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 "jobs" "queue") (delegate-to jobs-controller))
(('GET "job" job-id) (delegate-to jobs-controller))
(('GET _ ...) (delegate-to nar-controller))
((method path ...)
(not-found (request-uri request)))))