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 (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 ((guix build syscalls)
                #:select (set-thread-name))
  #: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 model guix-revision-package-derivation)
  #: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)
  ;; The fibers web server uses a 1024 byte buffer, so increase this
  (setvbuf (request-port request)
           'block
           (expt 2 16))
  (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)

  (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)))

       (call-with-new-thread
        (lambda ()
          (run-fibers
           (lambda ()
             (let* ((current (current-scheduler))
                    (schedulers
                     (cons current (scheduler-remote-peers current))))

               (set! request-scheduler current)

               (for-each
                (lambda (i sched)
                  (spawn-fiber
                   (lambda ()
                     (catch 'system-error
                       (lambda ()
                         (set-thread-name
                          (string-append "rp " (number->string i))))
                       (const #t)))
                   sched))
                (iota (length schedulers))
                schedulers))

             (wait finished?))
           #:hz 0
           #:parallelism 4)))

       (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 request-scheduler)
            (sleep 0.1))
          (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
                    ((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"))
                       #: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"))
                       #:scheduler priority-scheduler))

                     (resource-pool-default-timeout 5))

                  (let ((resource-pool-checkout-failures-metric
                         (make-counter-metric registry
                                              "resource_pool_checkout_timeouts_total"
                                              #:labels '(pool_name))))
                    (%resource-pool-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 ()
                     (with-resource-from-pool (connection-pool) conn
                       (backfill-guix-revision-package-derivation-distribution-counts
                        conn)))
                   request-scheduler)

                  (let ((render-metrics (make-render-metrics registry)))
                    (run-server/patched
                     (lambda (request body)
                       (metric-increment requests-metric)

                       (let ((reply (make-channel)))
                         (spawn-fiber
                          (lambda ()
                            (call-with-values
                                (lambda ()
                                  (handler request finished? body controller
                                           secret-key-base
                                           startup-completed
                                           render-metrics))
                              (lambda vals
                                (put-message reply vals))))
                          request-scheduler
                          #:parallel? #t)

                         (apply values (get-message reply))))
                     #: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?)))