Christopher Baines
961441cab0
Insert the build ids to a table and remove the ids once processed. If the data service is restarted and the in memory queue is lost, process all the items from the database queue.
375 lines
16 KiB
Scheme
375 lines
16 KiB
Scheme
;;; Guix Data Service -- Information about Guix over time
|
|
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
|
|
;;; Copyright © 2019, 2020, 2022, 2023 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 server)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-11)
|
|
#:use-module (srfi srfi-71)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 threads)
|
|
#:use-module (web http)
|
|
#:use-module (web request)
|
|
#:use-module (web uri)
|
|
#:use-module (system repl error-handling)
|
|
#:use-module (ice-9 atomic)
|
|
#:use-module (fibers)
|
|
#:use-module (fibers channels)
|
|
#:use-module (fibers scheduler)
|
|
#:use-module (fibers conditions)
|
|
#:use-module (knots)
|
|
#:use-module (knots web-server)
|
|
#:use-module (knots thread-pool)
|
|
#:use-module (knots resource-pool)
|
|
#:use-module (prometheus)
|
|
#:use-module (guix-data-service utils)
|
|
#:use-module (guix-data-service database)
|
|
#:use-module (guix-data-service web controller)
|
|
#:use-module (guix-data-service web util)
|
|
#:use-module (guix-data-service web render)
|
|
#:use-module (guix-data-service web view html)
|
|
#:use-module (guix-data-service model build-status)
|
|
#:use-module (guix-data-service model blocked-builds)
|
|
#:use-module (guix-data-service model guix-revision-package-derivation)
|
|
#:use-module (guix-data-service model build-background-processing-queue)
|
|
#:export (%guix-data-service-metrics-registry
|
|
|
|
start-guix-data-service-web-server))
|
|
|
|
(define (check-startup-completed startup-completed)
|
|
(if (atomic-box-ref startup-completed)
|
|
(begin
|
|
;; Just in case this atomic-box-ref is expensive, only do it when
|
|
;; necessary
|
|
(set! check-startup-completed (const #t))
|
|
#t)
|
|
#f))
|
|
|
|
(define (handler request finished?
|
|
body controller secret-key-base startup-completed
|
|
render-metrics)
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(with-exception-handler
|
|
(lambda _ #f)
|
|
(lambda ()
|
|
(simple-format (current-error-port)
|
|
"exception when logging: ~A\n" exn))
|
|
#:unwind? #t)
|
|
;; If we can't log, exit
|
|
(signal-condition! finished?))
|
|
(lambda ()
|
|
(display
|
|
(format #f "~a ~a\n"
|
|
(request-method request)
|
|
(uri-path (request-uri request)))))
|
|
#:unwind? #t)
|
|
(apply values
|
|
(let-values (((request-components mime-types)
|
|
(request->path-components-and-mime-type request)))
|
|
(controller request
|
|
(cons (request-method request)
|
|
request-components)
|
|
mime-types
|
|
body
|
|
secret-key-base
|
|
(check-startup-completed startup-completed)
|
|
render-metrics))))
|
|
|
|
(define %guix-data-service-metrics-registry
|
|
(make-parameter #f))
|
|
|
|
(define* (start-guix-data-service-web-server port host secret-key-base
|
|
startup-completed
|
|
#:key postgresql-statement-timeout
|
|
postgresql-connections)
|
|
(define registry
|
|
(make-metrics-registry #:namespace "guixdataservice"))
|
|
|
|
(%database-metrics-registry registry)
|
|
|
|
(%guix-data-service-metrics-registry registry)
|
|
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(simple-format #t "failed increasing open file limit: ~A\n" exn))
|
|
(lambda ()
|
|
(setrlimit 'nofile 4096 4096))
|
|
#:unwind? #t)
|
|
|
|
(let ((finished? (make-condition))
|
|
(priority-scheduler #f)
|
|
(request-scheduler #f))
|
|
(call-with-sigint
|
|
(lambda ()
|
|
(call-with-new-thread
|
|
(lambda ()
|
|
(run-fibers
|
|
(lambda ()
|
|
(let* ((current (current-scheduler))
|
|
(schedulers
|
|
(cons current (scheduler-remote-peers current))))
|
|
|
|
(set! priority-scheduler current)
|
|
|
|
(for-each
|
|
(lambda (i sched)
|
|
(spawn-fiber
|
|
(lambda ()
|
|
(catch 'system-error
|
|
(lambda ()
|
|
(set-thread-name
|
|
(string-append "priority " (number->string i))))
|
|
(const #t)))
|
|
sched))
|
|
(iota (length schedulers))
|
|
schedulers))
|
|
|
|
(wait finished?))
|
|
#:hz 0
|
|
#:parallelism 1)))
|
|
|
|
(run-fibers
|
|
(lambda ()
|
|
(let* ((current (current-scheduler))
|
|
(schedulers
|
|
(cons current (scheduler-remote-peers current))))
|
|
(for-each
|
|
(lambda (i sched)
|
|
(spawn-fiber
|
|
(lambda ()
|
|
(catch 'system-error
|
|
(lambda ()
|
|
(set-thread-name
|
|
(string-append "server " (number->string i))))
|
|
(const #t)))
|
|
sched))
|
|
(iota (length schedulers))
|
|
schedulers))
|
|
|
|
(while (not priority-scheduler)
|
|
(sleep 0.1))
|
|
|
|
(let ((requests-metric
|
|
(make-counter-metric registry "requests_total")))
|
|
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(simple-format
|
|
(current-error-port)
|
|
"\n
|
|
error: guix-data-service could not start: ~A
|
|
|
|
Check if it's already running, or whether another process is using that
|
|
port. Also, the port used can be changed by passing the --port option.\n"
|
|
exn)
|
|
(primitive-exit 1))
|
|
(lambda ()
|
|
(parameterize
|
|
((background-connection-pool
|
|
(make-resource-pool
|
|
(lambda ()
|
|
(open-postgresql-connection
|
|
"background"
|
|
postgresql-statement-timeout))
|
|
4
|
|
#:name "background"
|
|
#:idle-seconds 5
|
|
#:destructor
|
|
(lambda (conn)
|
|
(close-postgresql-connection conn "background"))
|
|
#:scheduler priority-scheduler))
|
|
|
|
(connection-pool
|
|
(make-resource-pool
|
|
(lambda ()
|
|
(open-postgresql-connection
|
|
"web"
|
|
postgresql-statement-timeout))
|
|
(floor (/ postgresql-connections 2))
|
|
#:name "web"
|
|
#:idle-seconds 30
|
|
#:destructor
|
|
(lambda (conn)
|
|
(close-postgresql-connection conn "web"))
|
|
#:default-max-waiters 300
|
|
#:default-checkout-timeout (/ postgresql-statement-timeout
|
|
1000)
|
|
#:scheduler priority-scheduler))
|
|
|
|
(reserved-connection-pool
|
|
(make-resource-pool
|
|
(lambda ()
|
|
(open-postgresql-connection
|
|
"web-reserved"
|
|
postgresql-statement-timeout))
|
|
(floor (/ postgresql-connections 2))
|
|
#:name "web-reserved"
|
|
#:idle-seconds 600
|
|
#:destructor
|
|
(lambda (conn)
|
|
(close-postgresql-connection conn "web-reserved"))
|
|
#:default-checkout-timeout 6
|
|
#:scheduler priority-scheduler)))
|
|
|
|
(let ((resource-pool-checkout-failures-metric
|
|
(make-counter-metric registry
|
|
"resource_pool_checkout_timeouts_total"
|
|
#:labels '(pool_name))))
|
|
(resource-pool-default-timeout-handler
|
|
(lambda (pool proc timeout)
|
|
(let ((pool-name
|
|
(cond
|
|
((eq? pool (connection-pool)) "normal")
|
|
((eq? pool (reserved-connection-pool)) "reserved")
|
|
(else #f))))
|
|
(when pool-name
|
|
(metric-increment
|
|
resource-pool-checkout-failures-metric
|
|
#:label-values `((pool_name . ,pool-name))))))))
|
|
|
|
(spawn-fiber
|
|
(lambda ()
|
|
(while (not (check-startup-completed startup-completed))
|
|
(sleep 1))
|
|
|
|
(call-with-resource-from-pool (background-connection-pool)
|
|
(lambda (conn)
|
|
(let ((build-ids
|
|
(select-background-processing-build-ids conn)))
|
|
(unless (null? build-ids)
|
|
(simple-format #t "processing ~A builds from the background queue\n"
|
|
(length build-ids)))
|
|
(for-each
|
|
(lambda (build-id)
|
|
(let ((status (select-latest-build-status-by-build-id
|
|
conn
|
|
build-id)))
|
|
(cond
|
|
((string=? status "succeeded")
|
|
(handle-removing-blocking-build-entries-for-successful-builds
|
|
conn
|
|
(list build-id)))
|
|
((string=? status "scheduled")
|
|
(handle-blocked-builds-entries-for-scheduled-builds
|
|
conn
|
|
(list build-id)))
|
|
((member status '("failed"
|
|
"failed-dependency"
|
|
"canceled"))
|
|
(handle-populating-blocked-builds-for-build-failures
|
|
conn
|
|
(list build-id)))))
|
|
(delete-background-processing-entries-for-build-ids
|
|
conn
|
|
build-id))
|
|
build-ids)))))
|
|
#:parallel? #t)
|
|
|
|
(spawn-fiber
|
|
(lambda ()
|
|
(while (not (check-startup-completed startup-completed))
|
|
(sleep 1))
|
|
|
|
(with-resource-from-pool (background-connection-pool) conn
|
|
(backfill-guix-revision-package-derivation-distribution-counts
|
|
conn)))
|
|
#:parallel? #t)
|
|
|
|
(let ((render-metrics (make-render-metrics registry)))
|
|
(run-knots-web-server
|
|
(lambda (request)
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(when (resource-pool-timeout-error? exn)
|
|
(spawn-fiber
|
|
(lambda ()
|
|
(let* ((pool (resource-pool-timeout-error-pool exn))
|
|
(stats (resource-pool-stats pool)))
|
|
(simple-format (current-error-port)
|
|
"resource pool timeout error: ~A, ~A\n"
|
|
pool
|
|
stats)))))
|
|
|
|
(let ((path-components
|
|
mime-types
|
|
(request->path-components-and-mime-type request))
|
|
(pool-exn?
|
|
(or (resource-pool-timeout-error? exn)
|
|
(resource-pool-too-many-waiters-error? exn))))
|
|
(case (most-appropriate-mime-type
|
|
mime-types
|
|
'(text/html application/json))
|
|
((application/json)
|
|
(apply
|
|
values
|
|
(render-json `((error . ,(if (%show-error-details)
|
|
(simple-format #f "~A" exn)
|
|
#f)))
|
|
#:code (if pool-exn?
|
|
503
|
|
500))))
|
|
(else
|
|
(apply
|
|
values
|
|
(render-html #:sxml (error-page
|
|
(if (%show-error-details)
|
|
exn
|
|
#f))
|
|
#:code (if pool-exn?
|
|
503
|
|
500)))))))
|
|
(lambda ()
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(let* ((error-string
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(simple-format
|
|
port
|
|
"exception when processing: ~A ~A\n"
|
|
(request-method request)
|
|
(uri-path (request-uri request)))
|
|
(print-backtrace-and-exception/knots
|
|
exn
|
|
#:port port)))))
|
|
(display error-string
|
|
(current-error-port)))
|
|
|
|
(raise-exception exn))
|
|
(lambda ()
|
|
(metric-increment requests-metric)
|
|
|
|
(let ((body (read-request-body request)))
|
|
(handler request finished? body controller
|
|
secret-key-base
|
|
startup-completed
|
|
render-metrics)))))
|
|
#:unwind? #t))
|
|
#:connection-buffer-size (expt 2 16)
|
|
#:host host
|
|
#:port port)))
|
|
#:unwind? #t)))
|
|
|
|
;; Guile sometimes just seems to stop listening on the port, so try
|
|
;; and detect this and quit
|
|
(spawn-port-monitoring-fiber port finished?)
|
|
|
|
(wait finished?))
|
|
#:hz 0
|
|
#:parallelism 4))
|
|
finished?)))
|