;;; Guix Data Service -- Information about Guix over time ;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus ;;; Copyright © 2019, 2020, 2021, 2022, 2023 Christopher Baines ;;; ;;; 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 ;;; . (define-module (guix-data-service web controller) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 threads) #:use-module (ice-9 pretty-print) #:use-module (ice-9 textual-ports) #:use-module (ice-9 string-fun) #: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 utils) #: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) #:use-module (guix-data-service web package controller) #:export (%show-error-details handle-static-assets make-render-metrics controller background-connection-pool connection-pool reserved-connection-pool)) (define background-connection-pool (make-parameter #f)) (define connection-pool (make-parameter #f)) (define reserved-connection-pool (make-parameter #f)) (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 (make-render-metrics registry) (let* ((revisions-count-metric (make-gauge-metric registry "revision_count")) (load-new-guix-revision-job-count (make-gauge-metric registry "load_new_guix_revision_job_count" #:labels '(repository_label completed))) (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))) (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)))) 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)))) pg-stat-indexes-fields)) (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)) (resource-pools `(("normal" . ,(connection-pool)) ("reserved" . ,(reserved-connection-pool)) ("background" . ,(background-connection-pool)))) (resource-pool-metrics `((resources . ,(make-gauge-metric registry "resource_pool_resources_total" #:labels '(pool_name))) (available . ,(make-gauge-metric registry "resource_pool_resources_available_total" #:labels '(pool_name))) (waiters . ,(make-gauge-metric registry "resource_pool_waiters_total" #:labels '(pool_name))) (checkout-failure-count . ,(make-gauge-metric registry "resource_pool_checkout_failures_total" #:labels '(pool_name))))) (gc-metrics-updater (get-gc-metrics-updater registry)) (process-metrics-updater (get-process-metrics-updater registry)) (guix-metrics-updater (get-guix-metrics-updater registry))) (define guile-time-metrics-updater (let ((internal-real-time (make-gauge-metric registry "guile_internal_real_time")) (internal-run-time (make-gauge-metric registry "guile_internal_run_time"))) (lambda () (metric-set internal-real-time (get-internal-real-time)) (metric-set internal-run-time (get-internal-run-time))))) (define (with-statement-timeout conn proc) (with-postgresql-transaction conn (lambda (conn) (exec-query conn (simple-format #f "SET statement_timeout = ~A" 6000)) (proc conn)) #:always-rollback? #t)) (lambda () (letpar& ((metric-values (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception fetching table size metrics: ~A\n" exn) #f) (lambda () (call-with-resource-from-pool (reserved-connection-pool) (lambda (conn) (with-statement-timeout conn fetch-high-level-table-size-metrics)))) #:unwind? #t)) (guix-revisions-count (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception counting guix revisions: ~A\n" exn) #f) (lambda () (call-with-resource-from-pool (reserved-connection-pool) (lambda (conn) (with-statement-timeout conn count-guix-revisions)))) #:unwind? #t)) (pg-stat-user-tables-metrics (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception fetching pg_stat user table metrics: ~A\n" exn) #f) (lambda () (call-with-resource-from-pool (reserved-connection-pool) (lambda (conn) (with-statement-timeout conn fetch-pg-stat-user-tables-metrics)))) #:unwind? #t)) (pg-stat-user-indexes-metrics (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception fetching pg_stat user indexes metrics: ~A\n" exn) #f) (lambda () (call-with-resource-from-pool (reserved-connection-pool) (lambda (conn) (with-statement-timeout conn fetch-pg-stat-user-indexes-metrics)))) #:unwind? #t)) (pg-stats-metric-values (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception fetching pg_stats metrics: ~A\n" exn) #f) (lambda () (call-with-resource-from-pool (reserved-connection-pool) (lambda (conn) (with-statement-timeout conn fetch-pg-stats-metrics)))) #:unwind? #t)) (load-new-guix-revision-job-metrics (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception fetching load_new_guix_revision_job metrics: ~A\n" exn) #f) (lambda () (call-with-resource-from-pool (reserved-connection-pool) (lambda (conn) (with-statement-timeout conn select-load-new-guix-revision-job-metrics)))) #:unwind? #t))) (for-each (match-lambda ((name . pool) (for-each (match-lambda ((stat . value) (metric-set (assq-ref resource-pool-metrics stat) value #:label-values `((pool_name . ,name))))) (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception fetching resource pool stats: ~A\n" exn) '()) (lambda () (resource-pool-stats pool)) #:unwind? #t)))) resource-pools) (for-each (match-lambda ((name tablespace row-estimate table-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) (tablespace . ,tablespace))) (metric-set table-toast-bytes-metric toast-bytes #:label-values `((name . ,name) (tablespace . ,tablespace))))) (or metric-values '())) (when guix-revisions-count (metric-set revisions-count-metric guix-revisions-count)) (for-each (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))) (or pg-stat-user-tables-metrics '())) (for-each (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))) (or pg-stat-user-indexes-metrics '())) (for-each (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))) (or pg-stats-metric-values '())) (for-each (match-lambda ((repository-label state count) (metric-set load-new-guix-revision-job-count count #:label-values `((repository_label . ,repository-label) (state . ,state))))) (or load-new-guix-revision-job-metrics '())) (gc-metrics-updater) (process-metrics-updater) (guix-metrics-updater) (guile-time-metrics-updater) (list (build-response #:code 200 #:headers '((content-type . (text/plain)))) (call-with-output-string (lambda (port) (write-metrics registry port)))))))) (define (render-derivation derivation-file-name) (letpar& ((derivation (with-resource-from-pool (connection-pool) conn (select-derivation-by-file-name conn derivation-file-name)))) (if derivation (letpar& ((derivation-inputs (with-resource-from-pool (connection-pool) conn (select-derivation-inputs-by-derivation-id conn (first derivation)))) (derivation-outputs (with-resource-from-pool (connection-pool) conn (select-derivation-outputs-by-derivation-id conn (first derivation)))) (builds (with-resource-from-pool (connection-pool) conn (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 derivation-file-name) (let ((derivation (with-resource-from-pool (connection-pool) conn (select-derivation-by-file-name conn derivation-file-name)))) (if derivation (letpar& ((derivation-inputs (with-resource-from-pool (connection-pool) conn (select-derivation-inputs-by-derivation-id conn (first derivation)))) (derivation-outputs (with-resource-from-pool (connection-pool) conn (select-derivation-outputs-by-derivation-id conn (first derivation)))) (derivation-sources (with-resource-from-pool (connection-pool) conn (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 derivation-file-name) (let ((derivation (with-resource-from-pool (connection-pool) conn (select-derivation-by-file-name conn derivation-file-name)))) (if derivation (letpar& ((derivation-inputs (with-resource-from-pool (connection-pool) conn (select-derivation-inputs-by-derivation-id conn (first derivation)))) (derivation-outputs (with-resource-from-pool (connection-pool) conn (select-derivation-outputs-by-derivation-id conn (first derivation)))) (derivation-sources (with-resource-from-pool (connection-pool) conn (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 filename) (let ((narinfos (with-resource-from-pool (connection-pool) conn (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 filename) (letpar& ((derivation (with-resource-from-pool (connection-pool) conn (select-derivation-by-output-filename conn filename)))) (match derivation (() (match (with-resource-from-pool (connection-pool) conn (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 (with-resource-from-pool (connection-pool) conn (select-derivation-source-file-nar-details-by-file-name conn filename))) #:extra-headers http-headers-for-unchanging-content)))) (derivations (letpar& ((nars (with-resource-from-pool (connection-pool) conn (select-nars-for-output conn filename))) (builds (with-resource-from-pool (connection-pool) 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 (with-resource-from-pool (connection-pool) conn (select-derivation-by-output-filename conn filename)))) (match derivation (() (match (with-resource-from-pool (connection-pool) conn (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)))) (with-resource-from-pool (connection-pool) conn (select-derivation-source-file-nar-details-by-file-name conn filename)))))))))) (derivations (letpar& ((nars (with-resource-from-pool (connection-pool) 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) `((filename . ,filename)))) 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 startup-completed? render-metrics) (define (running-controller-thunk) (actual-controller request method-and-path-components mime-types body secret-key-base render-metrics)) (define (startup-controller-thunk) (or (base-controller request method-and-path-components #f) (render-html #:sxml (server-starting-up-page) #:code 503))) (with-exception-handler (lambda (exn) (case (most-appropriate-mime-type mime-types '(text/html application/json)) ((application/json) (render-json `((error . ,(if (%show-error-details) (simple-format #f "~A" exn) #f))) #:code 500)) (else (render-html #:sxml (error-page (if (%show-error-details) exn #f)) #:code 500)))) (lambda () (with-throw-handler #t (if startup-completed? running-controller-thunk startup-controller-thunk) (lambda (key . args) (match method-and-path-components ((method path-components ...) (simple-format (current-error-port) "error: when processing: /~A ~A\n ~A ~A\n" method (string-join path-components "/") key args))) (let* ((stack (make-stack #t 4)) (backtrace (call-with-output-string (lambda (port) (display "\nBacktrace:\n" port) (display-backtrace stack port) (newline port) (newline port))))) (display backtrace (current-error-port)))))) #:unwind? #t)) (define* (base-controller request method-and-path-components startup-completed?) (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? (count-guix-revisions conn))))) (lambda (key . args) #f)))) (render-json `((status . ,(if database-status "ok" "not ok"))) #:code (if (eq? database-status #t) 200 (if startup-completed? 500 503))))) (('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)))) ((method path ...) #f))) (define (actual-controller request method-and-path-components mime-types body secret-key-base render-metrics) (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 (base-controller request method-and-path-components #t) (match method-and-path-components (('GET) (render-html #:sxml (index (with-resource-from-pool (connection-pool) 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 "metrics") (parameterize ((resource-pool-default-timeout 6)) (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 (with-resource-from-pool (connection-pool) 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)))))