guix-data-service/guix-data-service/web/server.scm

;;; 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?)))