;;; 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 (ice-9 match)
  #: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 (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 (make-request-handler))

(define* (render-json json #:key (extra-headers '())
                      (code 200))
  (values (build-response
           #:code code
           #:headers (append extra-headers
                             '((content-type . (application/json))
                               (vary . (accept)))))
          (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 (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* (make-request-handler database storage-root
                               #:key ttl negative-ttl logger
                               metrics-registry)
  (define (narinfo? str)
    (and
     (= (string-length str) 40)
     (string-suffix? ".narinfo" str)))

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

  (define requests-total-metric
    (make-counter-metric metrics-registry
                         "server_requests_total"))

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

  (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))))
      (('GET (? narinfo? narinfo))
       (let ((narinfo-contents
              (database-select-narinfo-contents-by-hash
               database
               (string-take narinfo 32))))

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

         (if 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"))))
      (('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"))))
      (('GET "nar" compression filename)
       (let* ((hash (string-take filename 32))
              (narinfo-files
               (database-select-narinfo-files
                database
                hash))
              (narinfo-file-for-compression
               (find (lambda (file)
                       (string=? (assq-ref file 'compression)
                                 compression))
                     narinfo-files)))

         (when (or narinfo-file-for-compression
                   ;; Check for a common compression to avoid lots of
                   ;; metrics being generated if compression is random
                   (member compression '("gzip" "lzip" "zstd")))
           (increment-request-metric
            (string-append "nar/"
                           compression)
            (if narinfo-file-for-compression "200" "404")))

         (if narinfo-file-for-compression
             (values (build-response
                      #:code 200
                      #:headers `((X-Accel-Redirect
                                   . ,(string-append
                                       "/internal/nar/"
                                       compression "/"
                                       (uri-encode filename)))))
                     #f)
             (values (build-response #:code 404)
                     "404"))))
      (('GET "file" name algo hash)
       (guard (c ((invalid-base32-character? c)
                  (values (build-response #:code 404)
                          "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
                       (first narinfo-files)))

                 (increment-request-metric
                  "file"
                  (if selected-narinfo-file "200" "404"))

                 (if selected-narinfo-file
                     (let* ((url
                             (assq-ref selected-narinfo-file 'url))
                            (filename
                             (string-append storage-root
                                            (uri-decode url))))

                       (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))
                                  (lambda (output-port)
                                    (dump-port nar-port
                                               output-port
                                               bytes)

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

                     (values (build-response #:code 404)
                             "404")))
               (begin
                 (increment-request-metric "file" "404")

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

      (('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"))))))))
      (('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))
      (('GET "metrics")
       (gc-metrics-updater)
       (increment-request-metric "metrics" "200")

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

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