path: root/nar-herder/server.scm

;;; Nar Herder
;;;
;;; Copyright © 2021 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 (nar-herder server)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 binary-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (web uri)
  #:use-module (web response)
  #:use-module (web request)
  #:use-module (logging logger)
  #:use-module (fibers)
  #:use-module (prometheus)
  #:use-module (json)
  #:use-module ((system foreign)
                #:select (bytevector->pointer pointer->bytevector))
  #:use-module (guix store)
  #:use-module (guix base32)
  #:use-module (guix serialization)
  #:use-module ((guix utils)
                #:select (decompressed-port))
  #:use-module ((guix build utils)
                #:select (dump-port))
  #:use-module (nar-herder database)
  #:use-module (nar-herder storage)
  #:use-module (ice-9 textual-ports)
  #:export (%compression-options

            make-request-handler))

(define %compression-options
  '(gzip lzip zstd none))

(define* (render-json json #:key (extra-headers '())
                      (code 200))
  (values (build-response
           #:code code
           #:headers (append extra-headers
                             '((content-type . (application/json
                                                (charset . "utf-8")))
                               (vary . (accept)))))
          (call-with-encoded-output-string
           "utf-8"
           (lambda (port)
             (scm->json json port)))))

(define (parse-query-string query)
  (let lp ((lst (map uri-decode (string-split query (char-set #\& #\=)))))
    (match lst
      ((key value . rest)
       (cons (cons key value) (lp rest)))
      (("") '())
      (() '()))))

(define (get-gc-metrics-updater registry)
  (define metrics
    `((gc-time-taken
       . ,(make-gauge-metric registry "guile_gc_time_taken"))
      (heap-size
       . ,(make-gauge-metric registry "guile_heap_size"))
      (heap-free-size
       . ,(make-gauge-metric registry "guile_heap_free_size"))
      (heap-total-allocated
       . ,(make-gauge-metric registry "guile_heap_total_allocated"))
      (heap-allocated-since-gc
       . ,(make-gauge-metric registry "guile_allocated_since_gc"))
      (protected-objects
       . ,(make-gauge-metric registry "guile_gc_protected_objects"))
      (gc-times
       . ,(make-gauge-metric registry "guile_gc_times"))))

  (lambda ()
    (let ((stats (gc-stats)))
      (for-each
       (match-lambda
         ((name . metric)
          (let ((value (assq-ref stats name)))
            (metric-set metric value))))
       metrics))))

(define (get-port-metrics-updater registry)
  (let ((ports-metric
         (make-gauge-metric registry "guile_ports_total"))
        (fds-metric
         (make-gauge-metric registry "file_descriptors_total")))
    (lambda ()
      (let ((count 0))
        (port-for-each
         (lambda _
           (set! count (+ 1 count))))

        (metric-set ports-metric count))

      (metric-set
       fds-metric
       (length
        ;; In theory 'scandir' cannot return #f, but in practice,
        ;; we've seen it before.
        (or (scandir "/proc/self/fd"
                     (lambda (file)
                       (not (member file '("." "..")))))
            '()))))))

(define (serve-fixed-output-file input compression proc)
  ;; TODO It's hard with fold-archive from (guix serialization) to
  ;; read just the singular file from the archive, so the following
  ;; procedures allow to just read the parts prior to the file, which
  ;; includes the file length

  (define (sub-bytevector bv len)
    (define max (bytevector-length bv))
    (cond ((= len max) bv)
          ((< len max)
           ;; Yes, this is safe because the result of each conversion procedure
           ;; has its life cycle synchronized with that of its argument.
           (pointer->bytevector (bytevector->pointer bv) len))
          (else
           (error "sub-bytevector called to get a super bytevector"))))

  (define (read-long-long p)
    (let ((b (get-bytevector-n p 8)))
      (bytevector-u64-ref b 0 (endianness little))))

  (define (read-int p)
    (let ((b (get-bytevector-n p 8)))
      (bytevector-u32-ref b 0 (endianness little))))

  (define (read-byte-string p)
    (let* ((len (read-int p))
           (m   (modulo len 8))
           (pad (if (zero? m) 0 (- 8 m)))
           (bv  (get-bytevector-n p (+ len pad))))
      (sub-bytevector bv len)))

  (define (read-string p)
    (utf8->string (read-byte-string p)))

  (let*-values (((port pids)
                 (decompressed-port
                  (string->symbol compression)
                  input)))

    ;; The decompressor can be an external program, so wait for it to
    ;; exit
    (every (compose zero? cdr waitpid) pids)

    (match (list
            (read-string port)
            (read-string port)
            (read-string port)
            (read-string port)

            (match (read-string port)
              ("contents" 'regular)
              ("executable"
               (match (list (read-string port) (read-string port))
                 (("" "contents") 'executable))))

            (read-long-long port))
      (("nix-archive-1" "(" "type" "regular" type size)

       (proc port size)))))

(define (add-cached-compressions-to-narinfo
         database
         narinfo-id
         initial-narinfo-contents)
  (let ((cached-nar-strings
         (map (lambda (cached-nar-details)
                (let ((compression
                       (symbol->string
                        (assq-ref cached-nar-details 'compression))))
                  (string-append
                   "URL: nar/" compression "/"
                   (store-path-base
                    (assq-ref cached-nar-details 'store-path))
                   "\n"
                   "Compression: " compression "\n"
                   "FileSize: " (number->string
                                 (assq-ref cached-nar-details 'size)))))
              (database-select-cached-narinfo-files-by-narinfo-id
               database
               narinfo-id))))
    (string-append
     initial-narinfo-contents
     (string-join
      cached-nar-strings
      "\n"))))

(define* (make-request-handler database storage-root
                               #:key ttl negative-ttl logger
                               metrics-registry
                               maybe-trigger-creation-of-compressed-nars)
  (define hostname
    (gethostname))

  (define (narinfo? str)
    (and
     (= (string-length str) 40)
     (string-suffix? ".narinfo" str)))

  (define gc-metrics-updater
    (get-gc-metrics-updater metrics-registry))

  (define port-metrics-updater
    (get-port-metrics-updater metrics-registry))

  (define guile-time-metrics-updater
    (let ((internal-real-time
           (make-gauge-metric metrics-registry "guile_internal_real_time"))
          (internal-run-time
           (make-gauge-metric metrics-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 requests-total-metric
    (make-counter-metric metrics-registry
                         "server_requests_total"))

  (define* (increment-request-metric category response-code #:key (labels '()))
    (metric-increment
     requests-total-metric
     #:label-values `((category . ,category)
                      (response_code . ,response-code)
                      ,@labels)))

  (define %compression-strings
    (map symbol->string
         %compression-options))

  (lambda (request body)
    (log-msg logger
             'DEBUG
             (request-method request)
             " "
             (uri-path (request-uri request)))

    (match (cons (request-method request)
                 (split-and-decode-uri-path
                  (uri-path (request-uri request))))
      (((or 'HEAD 'GET) (? narinfo? narinfo))
       (let ((base-narinfo-contents
              narinfo-id
              (database-select-narinfo-contents-by-hash
               database
               (string-take narinfo 32))))

         (increment-request-metric "narinfo"
                                   (if base-narinfo-contents
                                       "200"
                                       "404"))

         (if base-narinfo-contents
             (let ((narinfo-contents
                    (add-cached-compressions-to-narinfo
                     database
                     narinfo-id
                     base-narinfo-contents)))

               (values `((content-type . (text/plain))
                         ,@(if ttl
                               `((cache-control (max-age . ,ttl)))
                               '()))
                       narinfo-contents))
             (values (build-response #:code 404
                                     #:headers (if negative-ttl
                                                   `((cache-control
                                                      (max-age . ,negative-ttl)))
                                                   '()))
                     "404"))))
      (((or 'HEAD 'GET) (? narinfo? narinfo) "info")
       (let ((narinfo-contents
              (database-select-narinfo-contents-by-hash
               database
               (string-take narinfo 32))))

         (increment-request-metric "narinfo/info"
                                   (if narinfo-contents
                                       "200"
                                       "404"))

         (if narinfo-contents
             (render-json
              `((stored . ,(store-item-in-local-storage?
                            database
                            storage-root
                            (string-take narinfo 32)))))
             (values (build-response #:code 404)
                     "404"))))
      (((or 'HEAD 'GET) "nar" compression filename)
       (let* ((hash (and (>= (string-length filename) 32)
                         (string-take filename 32)))
              (narinfo
               (and hash
                    (database-select-narinfo-by-hash
                     database
                     hash)))
              (narinfo-files
               (and=> (assq-ref narinfo 'id)
                      (lambda (id)
                        (database-select-narinfo-files-by-narinfo-id
                         database
                         id))))
              (narinfo-file-for-compression
               (find (lambda (file)
                       (and (string=? (assq-ref file 'compression)
                                      compression)
                            (string=?
                             (last (string-split (assq-ref file 'url)
                                                 #\/))
                             (uri-encode filename))))
                     (or narinfo-files '())))
              (compression-symbol
               (if (member
                    compression
                    %compression-strings
                    string=?)
                   (string->symbol compression)
                   #f)))

         (if narinfo-file-for-compression
             (let ((loop?
                    (any
                     (lambda (via)
                       (string=? (last (string-split via #\space))
                                 hostname))
                     (request-via request))))

               (when (and (not loop?)
                          maybe-trigger-creation-of-compressed-nars)
                 (spawn-fiber
                  (lambda ()
                    (maybe-trigger-creation-of-compressed-nars
                     (assq-ref narinfo 'id)))
                  #:parallel? #t))

               (when loop?
                 (log-msg logger 'WARN
                          (request-method request)
                          " "
                          (uri-path (request-uri request))
                          ": loop detected (" hostname "): "
                          (string-join (request-via request) ", ")))

               (increment-request-metric
                (string-append "nar/"
                               compression)
                (if loop?
                    "500"
                    "200")
                #:labels
                (let ((system (assq-ref narinfo 'system)))
                  (if (string? system)
                      `((system . ,system))
                      '())))

               (if loop?
                   (values (build-response #:code 500)
                           (simple-format #f "loop detected (~A): ~A\n"
                                          hostname
                                          (request-via request)))
                   (values (build-response
                            #:code 200
                            #:headers `((X-Accel-Redirect
                                         . ,(string-append
                                             "/internal/nar/"
                                             compression "/"
                                             (uri-encode filename)))))
                           #f)))
             (let ((cached-narinfo-file
                    (and compression-symbol
                         (database-select-cached-narinfo-file-by-hash
                          database
                          hash
                          compression))))

               (when (or cached-narinfo-file
                         ;; Check for a common compression to avoid lots of
                         ;; metrics being generated if compression is random
                         compression-symbol)
                 (increment-request-metric
                  (string-append "nar/"
                                 compression)
                  (if cached-narinfo-file "200" "404")
                  #:labels
                  (if cached-narinfo-file
                      (let ((system (assq-ref narinfo 'system)))
                        (if (string? system)
                            `((system . ,system))
                            '()))
                      '())))

               (if cached-narinfo-file
                   (values (build-response
                            #:code 200
                            #:headers `((X-Accel-Redirect
                                         . ,(string-append
                                             "/internal/cached-nar/"
                                             compression "/"
                                             (uri-encode filename)))))
                           #f)
                   (values (build-response #:code 404)
                           "404"))))))
      (((or 'HEAD 'GET) "file" name algo hash)
       (guard (c ((invalid-base32-character? c)
                  (values (build-response #:code 404)
                          (if (eq? (request-method request) 'HEAD)
                              #f
                              "404"))))
         (let ((hash-bytevector (nix-base32-string->bytevector hash)))
           (if (and (string=? algo "sha256") (= 32 (bytevector-length
                                                    hash-bytevector)))
               (let* ((store-path
                       (fixed-output-path name hash-bytevector
                                          #:hash-algo
                                          (string->symbol algo)
                                          #:recursive? #f))
                      (store-path-hash
                       (store-path-hash-part store-path))
                      (narinfo-files
                       (database-select-narinfo-files
                        database
                        store-path-hash))
                      (selected-narinfo-file
                       ;; TODO Select intelligently
                       (if (null? narinfo-files)
                           #f
                           (first narinfo-files)))
                      (filename
                       (and selected-narinfo-file
                            (let ((filename
                                   (string-append
                                    storage-root
                                    (uri-decode
                                     (assq-ref selected-narinfo-file 'url)))))
                              (and (file-exists? filename)
                                   filename)))))

                 (increment-request-metric
                  "file"
                  (if filename "200" "404"))

                 (if filename
                     (serve-fixed-output-file
                      (open-input-file filename)
                      (assq-ref selected-narinfo-file
                                'compression)
                      (lambda (nar-port bytes)
                        (values `((content-type   . (application/octet-stream
                                                     (charset . "ISO-8859-1")))
                                  (content-length . ,bytes))
                                (if (eq? (request-method request) 'HEAD)
                                    #f
                                    (lambda (output-port)
                                      (dump-port nar-port
                                                 output-port
                                                 bytes)

                                      (close-port output-port))))))

                     (values (build-response #:code 404)
                             (if (eq? (request-method request) 'HEAD)
                                 #f
                                 "404"))))
               (begin
                 (increment-request-metric "file" "404")

                 (values (build-response #:code 404)
                         (if (eq? (request-method request) 'HEAD)
                             #f
                             "404")))))))

      (((or 'HEAD 'GET) "recent-changes")
       (let ((query-parameters
              (or (and=> (uri-query (request-uri request))
                         parse-query-string)
                  '())))

         (increment-request-metric "recent-changes" "200")

         (render-json
          `((recent_changes . ,(list->vector
                                (database-select-recent-changes
                                 database
                                 (or
                                  (assoc-ref query-parameters "since")
                                  "1970-01-01 00:00:01"))))))))
      (((or 'HEAD 'GET) "latest-database-dump")

       (increment-request-metric "latest-database-dump" "200")

       (values (build-response
                #:code 200
                #:headers '((X-Accel-Redirect . "/internal/database/nar_herder_dump.db")))
               #f))
      (((or 'HEAD 'GET) "metrics")
       (gc-metrics-updater)
       (port-metrics-updater)
       (guile-time-metrics-updater)
       (increment-request-metric "metrics" "200")

       (values (build-response
                #:code 200
                #:headers '((content-type . (text/plain))
                            (vary . (accept))))
               (call-with-output-string
                 (lambda (port)
                   (write-metrics metrics-registry port)))))
      (_
       (increment-request-metric "unhandled" "404")

       (values (build-response #:code 404)
               "404")))))