;;; 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 (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 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)
  (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)))
    (call-with-sigint
     (lambda ()
       (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 "fibers " (number->string i))))
                    (const #t)))
                sched))
             (iota (length schedulers))
             schedulers))

          (parameterize
              ((connection-pool
                (make-resource-pool
                 (lambda ()
                   (open-postgresql-connection
                    "web"
                    postgresql-statement-timeout))
                 (floor (/ postgresql-connections 2))
                 #:idle-seconds 30
                 #:destructor
                 (lambda (conn)
                   (close-postgresql-connection conn "web"))))

               (reserved-connection-pool
                (make-resource-pool
                 (lambda ()
                   (open-postgresql-connection
                    "web-reserved"
                    postgresql-statement-timeout))
                 (floor (/ postgresql-connections 2))
                 #:idle-seconds 600
                 #:destructor
                 (lambda (conn)
                   (close-postgresql-connection conn "web-reserved"))))

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

            (let ((render-metrics
                   (make-render-metrics registry))
                  (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 ()
                  (run-server/patched
                   (lambda (request body)
                     (metric-increment requests-metric)

                     (handler request finished? body controller
                              secret-key-base
                              startup-completed
                              render-metrics))
                   #: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?))
        #:parallelism 4))
     finished?)))