;;; 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 mirror)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-43)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 exceptions)
  #:use-module (rnrs bytevectors)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (prometheus)
  #:use-module (logging logger)
  #:use-module (json)
  #:use-module (guix narinfo)
  #:use-module ((guix store) #:select (store-path-hash-part))
  #:use-module (nar-herder utils)
  #:use-module (nar-herder database)
  #:use-module (nar-herder storage)
  #:export (start-fetch-changes-thread))

(define (start-fetch-changes-thread database storage-root
                                    mirror metrics-registry)
  (define nar-files-metric
    (or (metrics-registry-fetch-metric metrics-registry
                                       "nar_files_total")
        (make-gauge-metric metrics-registry
                           "nar_files_total"
                           #:labels '(stored))))

  (define (request-recent-changes)
    (define latest-recent-change
      (database-select-latest-recent-change-datetime database))

    (define processed-recent-changes
      ;; Strip datetimes, as these could differ from the mirrors
      ;; datetimes (since a mirror will often record different change
      ;; datetimes, since it's delayed in making changes
      (map strip-change-datetime
           (database-select-recent-changes database latest-recent-change)))

    (define (strip-change-datetime change)
      `((change . ,(assq-ref change 'change))
        (data   . ,(assq-ref change 'data))))

    (define uri
      (string->uri
       (string-append mirror "/recent-changes"
                      (if latest-recent-change
                          (string-append "?since=" (uri-encode
                                                    latest-recent-change))
                          ""))))

    (call-with-values
        (lambda ()
          (retry-on-error
           (lambda ()
             (http-get uri #:decode-body? #f))
           #:times 3
           #:delay 15))
      (lambda (response body)
        (if (= (response-code response) 200)
            (let* ((json-body (json-string->scm
                               (utf8->string body)))
                   (recent-changes
                    (assoc-ref json-body "recent_changes")))

              (log-msg 'INFO "queried for recent changes since "
                       latest-recent-change)
              (log-msg 'INFO "got " (vector-length recent-changes) " changes")

              ;; Switch to symbol keys and standardise the key order
              (vector-map!
               (lambda (_ change-details)
                 `((datetime . ,(assoc-ref change-details "datetime"))
                   (change   . ,(assoc-ref change-details "change"))
                   (data     . ,(assoc-ref change-details "data"))))
               recent-changes)

              (vector-for-each
               (lambda (_ change-details)
                 ;; Guard against processing changes that have already
                 ;; been processed
                 (unless (member (strip-change-datetime change-details)
                                 processed-recent-changes)
                   (let ((change (assq-ref change-details 'change)))
                     (cond
                      ((string=? change "addition")
                       (let ((narinfo
                              (call-with-input-string
                                  (assq-ref change-details 'data)
                                (lambda (port)
                                  (read-narinfo port
                                                "https://narherderdummyvalue")))))
                         (log-msg 'INFO "processing addition change for "
                                  (uri-path (first (narinfo-uris narinfo)))
                                  " (" (assq-ref change-details 'datetime) ")")
                         (database-insert-narinfo database
                                                  narinfo
                                                  #:change-datetime
                                                  (assq-ref change-details
                                                            'datetime))

                         (let ((new-files-count (length (narinfo-uris narinfo))))
                           (metric-increment nar-files-metric
                                             #:by new-files-count
                                             ;; TODO This should be
                                             ;; checked, rather than
                                             ;; assumed to be false
                                             #:label-values '((stored . "false"))))))
                      ((string=? change "removal")
                       (let ((store-path (assq-ref change-details 'data)))
                         (log-msg 'INFO "processing removal change for "
                                  store-path
                                  " (" (assq-ref change-details 'datetime) ")")

                         (when storage-root
                           (remove-nar-files-by-hash
                            database
                            storage-root
                            metrics-registry
                            (store-path-hash-part store-path)))

                         (database-remove-narinfo database
                                                  store-path
                                                  #:change-datetime
                                                  (assq-ref change-details
                                                            'datetime))))
                      (else
                       (error "unimplemented"))))))
               recent-changes))
            (raise-exception
             (make-exception-with-message
              (simple-format #f "unknown response: ~A\n  code: ~A response: ~A"
                             (uri->string uri)
                             (response-code response)
                             (utf8->string body))))))))

  (call-with-new-thread
   (lambda ()
     ;; This will initialise the nar_files_total metric
     (get-nar-files database storage-root metrics-registry)

     (while #t
       (with-exception-handler
           (lambda (exn)
             (log-msg 'ERROR "fetching changes failed " exn))
         request-recent-changes
         #:unwind? #t)

       (sleep 60)))))