;;; 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 (ice-9 match)
  #:use-module (web uri)
  #:use-module (web response)
  #:use-module (web request)
  #:use-module (logging logger)
  #:use-module (prometheus)
  #:use-module (json)
  #:use-module (nar-herder database)
  #:use-module (nar-herder storage)
  #: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* (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 "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")))))