2019-02-06 17:14:44 +01:00
|
|
|
;;; Guix Data Service -- Information about Guix over time
|
|
|
|
;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
|
2023-01-01 13:27:34 +01:00
|
|
|
;;; Copyright © 2019, 2020, 2021, 2022, 2023 Christopher Baines <mail@cbaines.net>
|
2019-02-06 17:14:44 +01:00
|
|
|
;;;
|
|
|
|
;;; 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)
|
2019-02-26 00:44:32 +01:00
|
|
|
#:use-module (ice-9 vlist)
|
2020-10-03 22:35:31 +02:00
|
|
|
#:use-module (ice-9 threads)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (ice-9 pretty-print)
|
2019-09-23 17:44:16 +02:00
|
|
|
#:use-module (ice-9 textual-ports)
|
2020-10-01 22:43:41 +02:00
|
|
|
#:use-module (ice-9 string-fun)
|
2019-11-24 13:59:09 +01:00
|
|
|
#:use-module (rnrs bytevectors)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (srfi srfi-1)
|
|
|
|
#:use-module (srfi srfi-11)
|
|
|
|
#:use-module (srfi srfi-26)
|
2020-03-14 13:46:02 +01:00
|
|
|
#:use-module (system repl error-handling)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (web request)
|
2019-11-24 13:59:09 +01:00
|
|
|
#:use-module (web response)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (web uri)
|
2019-05-16 23:28:16 +02:00
|
|
|
#:use-module (texinfo)
|
|
|
|
#:use-module (texinfo html)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (squee)
|
2019-05-16 23:28:16 +02:00
|
|
|
#:use-module (json)
|
2020-09-06 14:14:31 +02:00
|
|
|
#:use-module (prometheus)
|
2020-10-03 22:35:31 +02:00
|
|
|
#:use-module (guix-data-service utils)
|
2019-09-23 17:44:16 +02:00
|
|
|
#:use-module (guix-data-service config)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (guix-data-service comparison)
|
2019-06-06 21:39:06 +02:00
|
|
|
#:use-module (guix-data-service database)
|
2020-09-06 14:14:31 +02:00
|
|
|
#:use-module (guix-data-service metrics)
|
2019-05-05 21:06:28 +02:00
|
|
|
#:use-module (guix-data-service model git-branch)
|
2019-05-05 14:35:48 +02:00
|
|
|
#:use-module (guix-data-service model git-repository)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (guix-data-service model guix-revision)
|
2019-12-02 13:30:36 +01:00
|
|
|
#:use-module (guix-data-service model nar)
|
2019-03-06 23:59:27 +01:00
|
|
|
#:use-module (guix-data-service model package)
|
2019-03-11 23:11:14 +01:00
|
|
|
#:use-module (guix-data-service model package-derivation)
|
|
|
|
#:use-module (guix-data-service model package-metadata)
|
2019-03-07 09:43:16 +01:00
|
|
|
#:use-module (guix-data-service model derivation)
|
2019-03-17 23:44:09 +01:00
|
|
|
#:use-module (guix-data-service model build-status)
|
2019-03-06 23:59:27 +01:00
|
|
|
#:use-module (guix-data-service model build)
|
2019-08-31 13:42:54 +02:00
|
|
|
#:use-module (guix-data-service model lint-checker)
|
2019-09-01 13:59:45 +02:00
|
|
|
#:use-module (guix-data-service model lint-warning)
|
2019-09-07 17:19:34 +02:00
|
|
|
#:use-module (guix-data-service model utils)
|
2019-02-24 17:47:29 +01:00
|
|
|
#:use-module (guix-data-service jobs load-new-guix-revision)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (guix-data-service web render)
|
2019-05-16 23:28:16 +02:00
|
|
|
#:use-module (guix-data-service web sxml)
|
2019-05-11 17:44:17 +02:00
|
|
|
#:use-module (guix-data-service web query-parameters)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (guix-data-service web util)
|
2019-11-24 21:42:37 +01:00
|
|
|
#:use-module (guix-data-service web build controller)
|
2020-02-23 00:24:24 +01:00
|
|
|
#:use-module (guix-data-service web dumps controller)
|
2019-10-14 18:55:08 +02:00
|
|
|
#:use-module (guix-data-service web revision controller)
|
2019-12-26 10:25:27 +01:00
|
|
|
#:use-module (guix-data-service web nar controller)
|
2019-10-13 22:10:10 +02:00
|
|
|
#:use-module (guix-data-service web jobs controller)
|
2019-02-06 17:14:44 +01:00
|
|
|
#:use-module (guix-data-service web view html)
|
2019-11-24 13:59:09 +01:00
|
|
|
#:use-module (guix-data-service web build-server controller)
|
2019-10-14 20:24:14 +02:00
|
|
|
#:use-module (guix-data-service web compare controller)
|
2019-10-14 18:55:08 +02:00
|
|
|
#:use-module (guix-data-service web revision controller)
|
2019-10-14 19:28:25 +02:00
|
|
|
#:use-module (guix-data-service web repository controller)
|
2021-03-14 22:48:43 +01:00
|
|
|
#:use-module (guix-data-service web package controller)
|
2020-03-14 13:46:02 +01:00
|
|
|
#:export (%show-error-details
|
2022-06-17 13:55:05 +02:00
|
|
|
handle-static-assets
|
2023-01-01 13:27:34 +01:00
|
|
|
make-render-metrics
|
2020-03-14 13:46:02 +01:00
|
|
|
controller))
|
2019-02-06 17:14:44 +01:00
|
|
|
|
2019-05-18 21:25:34 +02:00
|
|
|
(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)))))
|
|
|
|
|
2019-02-06 17:14:44 +01:00
|
|
|
(define-syntax-rule (-> target functions ...)
|
|
|
|
(fold (lambda (f val) (and=> val f))
|
|
|
|
target
|
|
|
|
(list functions ...)))
|
|
|
|
|
2023-01-01 13:27:34 +01:00
|
|
|
(define (make-render-metrics registry)
|
|
|
|
(let* ((revisions-count-metric (make-gauge-metric registry
|
2020-09-20 19:39:46 +02:00
|
|
|
"revision_count"))
|
|
|
|
|
2020-09-20 20:13:23 +02:00
|
|
|
(load-new-guix-revision-job-count (make-gauge-metric
|
|
|
|
registry
|
|
|
|
"load_new_guix_revision_job_count"
|
|
|
|
#:labels '(repository_label
|
|
|
|
completed)))
|
|
|
|
|
2020-09-06 14:14:31 +02:00
|
|
|
(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"
|
2020-10-01 22:43:41 +02:00
|
|
|
#:labels '(name)))
|
|
|
|
|
|
|
|
(pg-stat-fields '(seq-scan seq-tup-read idx-scan idx-tup-fetch
|
|
|
|
n-tup-ins n-tup-upd n-tup-del
|
|
|
|
n-tup-hot-upd n-live-tup n-dead-tup
|
|
|
|
n-mod-since-analyze last-vacuum
|
|
|
|
last-autovacuum last-analyze last-autoanalyze
|
|
|
|
vacuum-count autovacuum-count
|
|
|
|
analyze-count autoanalyze-count))
|
|
|
|
|
|
|
|
(pg-stat-metrics (map (lambda (field)
|
|
|
|
(cons
|
|
|
|
field
|
|
|
|
(make-gauge-metric
|
|
|
|
registry
|
|
|
|
(string-append "pg_stat_"
|
|
|
|
(string-replace-substring
|
|
|
|
(symbol->string field)
|
|
|
|
"-"
|
|
|
|
"_"))
|
|
|
|
#:labels '(name))))
|
2020-10-09 20:42:14 +02:00
|
|
|
pg-stat-fields))
|
|
|
|
|
|
|
|
(pg-stat-indexes-fields '(idx-scan idx-tup-read
|
|
|
|
idx-tup-fetch bytes))
|
|
|
|
|
|
|
|
(pg-stat-indexes-metrics (map (lambda (field)
|
|
|
|
(cons
|
|
|
|
field
|
|
|
|
(make-gauge-metric
|
|
|
|
registry
|
|
|
|
(string-append
|
|
|
|
"pg_stat_indexes_"
|
|
|
|
(string-replace-substring
|
|
|
|
(symbol->string field)
|
|
|
|
"-"
|
|
|
|
"_"))
|
|
|
|
#:labels '(name))))
|
2022-10-09 12:13:28 +02:00
|
|
|
pg-stat-indexes-fields))
|
|
|
|
|
2022-11-29 12:09:55 +01:00
|
|
|
(pg-stats-fields '(null-frac n-distinct correlation))
|
|
|
|
|
|
|
|
(pg-stats-metrics (map (lambda (field)
|
|
|
|
(cons
|
|
|
|
field
|
|
|
|
(make-gauge-metric
|
|
|
|
registry
|
|
|
|
(string-append
|
|
|
|
"pg_stats_"
|
|
|
|
(string-replace-substring
|
|
|
|
(symbol->string field)
|
|
|
|
"-"
|
|
|
|
"_"))
|
|
|
|
#:labels '(table column))))
|
|
|
|
pg-stats-fields))
|
|
|
|
|
2022-10-09 12:13:28 +02:00
|
|
|
(gc-metrics-updater
|
|
|
|
(get-gc-metrics-updater registry)))
|
|
|
|
|
2020-10-03 22:35:31 +02:00
|
|
|
(lambda ()
|
|
|
|
(letpar& ((metric-values
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
fetch-high-level-table-size-metrics))
|
|
|
|
(guix-revisions-count
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
count-guix-revisions))
|
|
|
|
(pg-stat-user-tables-metrics
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
fetch-pg-stat-user-tables-metrics))
|
2020-10-09 20:42:14 +02:00
|
|
|
(pg-stat-user-indexes-metrics
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
fetch-pg-stat-user-indexes-metrics))
|
2022-11-29 12:09:55 +01:00
|
|
|
(pg-stats-metric-values
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
fetch-pg-stats-metrics))
|
2020-10-03 22:35:31 +02:00
|
|
|
(load-new-guix-revision-job-metrics
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
select-load-new-guix-revision-job-metrics)))
|
|
|
|
|
2020-09-06 14:14:31 +02:00
|
|
|
(for-each (match-lambda
|
2020-10-09 20:35:31 +02:00
|
|
|
((name tablespace row-estimate
|
2020-10-09 20:42:14 +02:00
|
|
|
table-bytes toast-bytes)
|
2020-09-06 14:14:31 +02:00
|
|
|
|
|
|
|
(metric-set table-row-estimate-metric
|
|
|
|
row-estimate
|
|
|
|
#:label-values `((name . ,name)))
|
|
|
|
(metric-set table-bytes-metric
|
|
|
|
table-bytes
|
2020-10-09 20:35:31 +02:00
|
|
|
#:label-values `((name . ,name)
|
|
|
|
(tablespace . ,tablespace)))
|
2020-09-06 14:14:31 +02:00
|
|
|
(metric-set table-toast-bytes-metric
|
|
|
|
toast-bytes
|
2020-10-09 20:35:31 +02:00
|
|
|
#:label-values `((name . ,name)
|
|
|
|
(tablespace . ,tablespace)))))
|
2020-10-03 22:35:31 +02:00
|
|
|
metric-values)
|
|
|
|
|
|
|
|
(metric-set revisions-count-metric
|
|
|
|
guix-revisions-count)
|
|
|
|
|
|
|
|
(map (lambda (field-values)
|
|
|
|
(let ((name (assq-ref field-values 'name)))
|
|
|
|
(for-each
|
|
|
|
(match-lambda
|
|
|
|
(('name . _) #f)
|
|
|
|
((field . value)
|
|
|
|
(let ((metric (or (assq-ref pg-stat-metrics field)
|
|
|
|
(error field))))
|
|
|
|
(metric-set metric
|
|
|
|
value
|
|
|
|
#:label-values `((name . ,name))))))
|
|
|
|
field-values)))
|
|
|
|
pg-stat-user-tables-metrics)
|
|
|
|
|
2020-10-09 20:42:14 +02:00
|
|
|
(map (lambda (field-values)
|
|
|
|
(let ((name (assq-ref field-values 'name))
|
|
|
|
(table-name (assq-ref field-values 'table-name))
|
|
|
|
(tablespace (assq-ref field-values 'tablespace)))
|
|
|
|
(for-each
|
|
|
|
(match-lambda
|
|
|
|
(('name . _) #f)
|
|
|
|
(('table-name . _) #f)
|
|
|
|
(('tablespace . _) #f)
|
|
|
|
((field . value)
|
|
|
|
(let ((metric (or (assq-ref pg-stat-indexes-metrics field)
|
|
|
|
(error field))))
|
|
|
|
(metric-set metric
|
|
|
|
value
|
|
|
|
#:label-values
|
|
|
|
`((name . ,name)
|
|
|
|
(table . ,table-name)
|
|
|
|
,@(if (eq? field 'bytes)
|
|
|
|
`((tablespace . ,tablespace))
|
|
|
|
'()))))))
|
|
|
|
field-values)))
|
|
|
|
pg-stat-user-indexes-metrics)
|
|
|
|
|
2022-11-29 12:09:55 +01:00
|
|
|
(map (lambda (field-values)
|
|
|
|
(let ((table (assq-ref field-values 'table-name))
|
|
|
|
(column (assq-ref field-values 'column-name)))
|
|
|
|
(for-each
|
|
|
|
(match-lambda
|
|
|
|
(('table-name . _) #f)
|
|
|
|
(('column-name . _) #f)
|
|
|
|
((_ . #f) #f)
|
|
|
|
((field . value)
|
|
|
|
(let ((metric (or (assq-ref pg-stats-metrics field)
|
|
|
|
(error field))))
|
|
|
|
(metric-set metric
|
|
|
|
value
|
|
|
|
#:label-values `((table . ,table)
|
|
|
|
(column . ,column))))))
|
|
|
|
field-values)))
|
|
|
|
pg-stats-metric-values)
|
|
|
|
|
2020-10-03 22:35:31 +02:00
|
|
|
(for-each (match-lambda
|
2020-10-09 21:19:28 +02:00
|
|
|
((repository-label state count)
|
2020-10-03 22:35:31 +02:00
|
|
|
(metric-set
|
|
|
|
load-new-guix-revision-job-count
|
|
|
|
count
|
|
|
|
#:label-values
|
|
|
|
`((repository_label . ,repository-label)
|
2020-10-09 21:19:28 +02:00
|
|
|
(state . ,state)))))
|
2020-10-03 22:35:31 +02:00
|
|
|
load-new-guix-revision-job-metrics)
|
|
|
|
|
2022-10-09 12:13:28 +02:00
|
|
|
(gc-metrics-updater)
|
|
|
|
|
2020-10-03 22:35:31 +02:00
|
|
|
(list (build-response
|
|
|
|
#:code 200
|
|
|
|
#:headers '((content-type . (text/plain))))
|
2023-02-09 11:39:24 +01:00
|
|
|
(call-with-output-string
|
|
|
|
(lambda (port)
|
|
|
|
(write-metrics registry port))))))))
|
2020-10-03 22:35:31 +02:00
|
|
|
|
|
|
|
(define (render-derivation derivation-file-name)
|
|
|
|
(letpar& ((derivation
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-by-file-name conn derivation-file-name)))))
|
|
|
|
|
2019-03-07 09:43:16 +01:00
|
|
|
(if derivation
|
2020-10-03 22:35:31 +02:00
|
|
|
(letpar& ((derivation-inputs
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-inputs-by-derivation-id
|
|
|
|
conn
|
|
|
|
(first derivation)))))
|
|
|
|
(derivation-outputs
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-outputs-by-derivation-id
|
2019-03-08 00:50:51 +01:00
|
|
|
conn
|
2020-10-03 22:35:31 +02:00
|
|
|
(first derivation)))))
|
|
|
|
(builds
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-builds-with-context-by-derivation-file-name
|
|
|
|
conn
|
|
|
|
(second derivation))))))
|
2019-05-18 21:08:34 +02:00
|
|
|
(render-html
|
|
|
|
#:sxml (view-derivation derivation
|
|
|
|
derivation-inputs
|
|
|
|
derivation-outputs
|
2019-05-18 21:25:34 +02:00
|
|
|
builds)
|
|
|
|
#:extra-headers http-headers-for-unchanging-content))
|
|
|
|
|
2019-08-05 20:45:10 +02:00
|
|
|
(render-html
|
|
|
|
#:sxml (general-not-found
|
|
|
|
"Derivation not found"
|
|
|
|
"No derivation found with this file name.")
|
|
|
|
#:code 404))))
|
2019-03-07 09:43:16 +01:00
|
|
|
|
2020-10-03 22:35:31 +02:00
|
|
|
(define (render-json-derivation derivation-file-name)
|
|
|
|
(let ((derivation
|
|
|
|
(parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-by-file-name conn
|
|
|
|
derivation-file-name))))))
|
|
|
|
(if derivation
|
|
|
|
(letpar& ((derivation-inputs
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-inputs-by-derivation-id
|
|
|
|
conn
|
|
|
|
(first derivation)))))
|
|
|
|
(derivation-outputs
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-outputs-by-derivation-id
|
|
|
|
conn
|
|
|
|
(first derivation)))))
|
|
|
|
(derivation-sources
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-sources-by-derivation-id
|
|
|
|
conn
|
|
|
|
(first derivation))))))
|
2020-08-26 13:47:48 +02:00
|
|
|
(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"))))))
|
|
|
|
|
2020-10-03 22:35:31 +02:00
|
|
|
(define (render-formatted-derivation derivation-file-name)
|
|
|
|
(let ((derivation
|
|
|
|
(parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-by-file-name conn
|
|
|
|
derivation-file-name))))))
|
2019-11-09 21:50:53 +01:00
|
|
|
(if derivation
|
2020-10-03 22:35:31 +02:00
|
|
|
(letpar& ((derivation-inputs
|
2020-10-04 12:29:51 +02:00
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-inputs-by-derivation-id
|
|
|
|
conn
|
|
|
|
(first derivation)))))
|
2020-10-03 22:35:31 +02:00
|
|
|
(derivation-outputs
|
2020-10-04 12:29:51 +02:00
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-outputs-by-derivation-id
|
|
|
|
conn
|
|
|
|
(first derivation)))))
|
2020-10-03 22:35:31 +02:00
|
|
|
(derivation-sources
|
2020-10-04 12:29:51 +02:00
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-sources-by-derivation-id
|
|
|
|
conn
|
|
|
|
(first derivation))))))
|
2019-11-09 21:50:53 +01:00
|
|
|
(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))))
|
|
|
|
|
2020-10-03 22:35:31 +02:00
|
|
|
(define (render-narinfos filename)
|
|
|
|
(let ((narinfos
|
|
|
|
(parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-nars-for-output
|
|
|
|
conn
|
|
|
|
(string-append "/gnu/store/" filename)))))))
|
2019-12-02 13:30:36 +01:00
|
|
|
(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)))))
|
|
|
|
|
2020-10-03 22:35:31 +02:00
|
|
|
(define (render-store-item filename)
|
|
|
|
(letpar& ((derivation
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-by-output-filename conn filename)))))
|
2019-03-08 00:50:51 +01:00
|
|
|
(match derivation
|
|
|
|
(()
|
2020-10-03 22:35:31 +02:00
|
|
|
(match (parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-source-file-by-store-path conn filename))))
|
2019-11-14 22:32:47 +01:00
|
|
|
(()
|
|
|
|
(render-html
|
|
|
|
#:sxml (general-not-found
|
|
|
|
"Store item not found"
|
|
|
|
"No derivation found producing this output")
|
|
|
|
#:code 404))
|
|
|
|
((id)
|
|
|
|
(render-html
|
2019-12-30 13:32:20 +01:00
|
|
|
#:sxml (view-derivation-source-file
|
|
|
|
filename
|
2020-10-03 22:35:31 +02:00
|
|
|
(parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-source-file-nar-details-by-file-name
|
|
|
|
conn
|
|
|
|
filename)))))
|
2019-11-14 22:32:47 +01:00
|
|
|
#:extra-headers http-headers-for-unchanging-content))))
|
2019-03-11 23:11:14 +01:00
|
|
|
(derivations
|
2021-05-17 19:35:19 +02:00
|
|
|
(letpar& ((nars
|
2020-10-03 22:35:31 +02:00
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-nars-for-output conn filename))))
|
|
|
|
(builds
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-builds-with-context-by-derivation-output
|
|
|
|
conn
|
|
|
|
filename)))))
|
|
|
|
(render-html
|
|
|
|
#:sxml (view-store-item filename
|
|
|
|
derivations
|
|
|
|
nars
|
|
|
|
builds)))))))
|
|
|
|
|
|
|
|
(define (render-json-store-item filename)
|
|
|
|
(let ((derivation
|
|
|
|
(parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-by-output-filename conn filename))))))
|
2020-08-26 14:03:08 +02:00
|
|
|
(match derivation
|
|
|
|
(()
|
2020-10-03 22:35:31 +02:00
|
|
|
(match (parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-source-file-by-store-path conn filename))))
|
2020-08-26 14:03:08 +02:00
|
|
|
(()
|
|
|
|
(render-json '((error . "store item not found"))))
|
|
|
|
((id)
|
|
|
|
(render-json
|
|
|
|
`((derivation-source-file
|
|
|
|
. ,(list->vector
|
|
|
|
(map
|
|
|
|
(match-lambda
|
|
|
|
((key . value)
|
|
|
|
`((,key . ,value))))
|
2020-10-03 22:35:31 +02:00
|
|
|
(parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-derivation-source-file-nar-details-by-file-name
|
|
|
|
conn
|
|
|
|
filename))))))))))))
|
2020-08-26 14:03:08 +02:00
|
|
|
(derivations
|
2020-10-03 22:35:31 +02:00
|
|
|
(letpar& ((nars
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(select-nars-for-output conn filename)))))
|
|
|
|
(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))))))
|
|
|
|
nars)))
|
|
|
|
(derivations
|
|
|
|
. ,(list->vector
|
|
|
|
(map
|
|
|
|
(match-lambda
|
|
|
|
((filename output-id)
|
2021-05-17 19:35:19 +02:00
|
|
|
`((filename . ,filename))))
|
|
|
|
derivations))))))))))
|
2020-08-26 14:03:08 +02:00
|
|
|
|
2019-10-06 15:23:15 +02:00
|
|
|
(define handle-static-assets
|
|
|
|
(if assets-dir-in-store?
|
|
|
|
(static-asset-from-store-renderer)
|
|
|
|
render-static-asset))
|
|
|
|
|
2020-03-14 13:46:02 +01:00
|
|
|
(define %show-error-details
|
|
|
|
(make-parameter #f))
|
|
|
|
|
2020-04-24 10:00:20 +02:00
|
|
|
(define* (controller request method-and-path-components
|
|
|
|
mime-types body
|
2022-06-17 13:55:05 +02:00
|
|
|
secret-key-base
|
2023-01-01 13:27:34 +01:00
|
|
|
startup-completed?
|
|
|
|
render-metrics)
|
2022-06-17 13:55:05 +02:00
|
|
|
(define (running-controller-thunk)
|
2020-10-03 22:35:31 +02:00
|
|
|
(actual-controller request
|
|
|
|
method-and-path-components
|
|
|
|
mime-types
|
|
|
|
body
|
2023-01-01 13:27:34 +01:00
|
|
|
secret-key-base
|
|
|
|
render-metrics))
|
2020-10-03 22:35:31 +02:00
|
|
|
|
2022-06-17 13:55:05 +02:00
|
|
|
(define (startup-controller-thunk)
|
|
|
|
(or
|
2022-07-15 10:24:46 +02:00
|
|
|
(base-controller request method-and-path-components #f)
|
2022-06-17 13:55:05 +02:00
|
|
|
(render-html
|
|
|
|
#:sxml (server-starting-up-page)
|
|
|
|
#:code 503)))
|
|
|
|
|
2020-03-14 13:46:02 +01:00
|
|
|
(call-with-error-handling
|
2022-06-17 13:55:05 +02:00
|
|
|
(if startup-completed?
|
|
|
|
running-controller-thunk
|
|
|
|
startup-controller-thunk)
|
2020-03-14 13:46:02 +01:00
|
|
|
#:on-error 'backtrace
|
|
|
|
#:post-error (lambda args
|
|
|
|
(render-html #:sxml (error-page
|
|
|
|
(if (%show-error-details)
|
|
|
|
args
|
|
|
|
#f))
|
|
|
|
#:code 500))))
|
2019-06-06 21:39:06 +02:00
|
|
|
|
2022-07-15 10:24:46 +02:00
|
|
|
(define* (base-controller request method-and-path-components
|
|
|
|
startup-completed?)
|
2019-05-11 23:56:25 +02:00
|
|
|
(match method-and-path-components
|
2020-10-03 22:35:31 +02:00
|
|
|
(('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? (count-guix-revisions conn)))))
|
|
|
|
(lambda (key . args)
|
|
|
|
#f))))
|
|
|
|
(render-json
|
|
|
|
`((status . ,(if database-status
|
|
|
|
"ok"
|
|
|
|
"not ok")))
|
|
|
|
#:code (if (eq? database-status
|
|
|
|
#t)
|
|
|
|
200
|
2022-07-15 10:24:46 +02:00
|
|
|
(if startup-completed?
|
|
|
|
500
|
|
|
|
503)))))
|
2020-10-03 22:35:31 +02:00
|
|
|
(('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))))
|
2022-06-17 13:55:05 +02:00
|
|
|
((method path ...) #f)))
|
|
|
|
|
|
|
|
(define (actual-controller request
|
|
|
|
method-and-path-components
|
|
|
|
mime-types
|
|
|
|
body
|
2023-01-01 13:27:34 +01:00
|
|
|
secret-key-base
|
|
|
|
render-metrics)
|
2022-06-17 13:55:05 +02:00
|
|
|
(define path
|
|
|
|
(uri-path (request-uri request)))
|
|
|
|
|
|
|
|
(define (delegate-to f)
|
|
|
|
(or (f request
|
|
|
|
method-and-path-components
|
|
|
|
mime-types
|
|
|
|
body)
|
|
|
|
(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
|
|
|
|
secret-key-base)
|
|
|
|
(render-html
|
|
|
|
#:sxml (general-not-found
|
|
|
|
"Page not found"
|
|
|
|
"")
|
|
|
|
#:code 404)))
|
|
|
|
|
|
|
|
(or
|
2022-07-15 10:24:46 +02:00
|
|
|
(base-controller request method-and-path-components #t)
|
2022-06-17 13:55:05 +02:00
|
|
|
(match method-and-path-components
|
|
|
|
(('GET)
|
|
|
|
(render-html
|
|
|
|
#:sxml (index
|
|
|
|
(parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(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")
|
|
|
|
(letpar& ((guix-revisions-count
|
|
|
|
(with-thread-postgresql-connection count-guix-revisions))
|
|
|
|
(count-derivations
|
|
|
|
(with-thread-postgresql-connection count-derivations)))
|
|
|
|
|
|
|
|
(render-html
|
|
|
|
#:sxml (view-statistics guix-revisions-count
|
|
|
|
count-derivations))))
|
|
|
|
(('GET "metrics")
|
|
|
|
(render-metrics))
|
|
|
|
(('GET "revision" args ...)
|
|
|
|
(delegate-to revision-controller))
|
|
|
|
(('GET "repositories")
|
|
|
|
(delegate-to repository-controller))
|
|
|
|
(('GET "repository" _ ...)
|
|
|
|
(delegate-to repository-controller))
|
|
|
|
(('GET "package" _ ...)
|
|
|
|
(delegate-to package-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 (uri-decode path))
|
|
|
|
(render-store-item (uri-decode path)))))
|
|
|
|
(('GET "gnu" "store" filename "formatted")
|
|
|
|
(if (string-suffix? ".drv" filename)
|
|
|
|
(render-formatted-derivation (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
|
|
|
|
(parallel-via-thread-pool-channel
|
|
|
|
(with-thread-postgresql-connection
|
|
|
|
(lambda (conn)
|
|
|
|
(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 filename))
|
|
|
|
(('GET "gnu" "store" filename "json")
|
|
|
|
(if (string-suffix? ".drv" filename)
|
|
|
|
(render-json-derivation (string-append "/gnu/store/" filename))
|
|
|
|
(render-json-store-item (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)))))
|