path: root/scripts/nar-herder.in

#!@GUILE@ --no-auto-compile
-*- scheme -*-
-*- geiser-scheme-implementation: guile -*-
!#
;;; Nar Herder
;;;
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of the nar-herder.
;;;
;;; The Nar Herder is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; The Nar Herder 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
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with the guix-data-service.  If not, see
;;; <http://www.gnu.org/licenses/>.

(setvbuf (current-output-port) 'line)
(setvbuf (current-error-port) 'line)

(let ((columns (string->number (or (getenv "COLUMNS") ""))))
  (setenv "COLUMNS"
          (number->string
           (if columns
               (max 256 columns)
               256))))

(use-modules (srfi srfi-1)
             (srfi srfi-19)
             (srfi srfi-37)
             (srfi srfi-43)
             (ice-9 ftw)
             (ice-9 match)
             (ice-9 format)
             (web uri)
             (web client)
             (web response)
             (oop goops)
             (logging logger)
             (logging port-log)
             (fibers)
             (fibers conditions)
             (fibers web server)
             ((guix ui) #:select (read/eval))
             (guix progress)
             (guix narinfo)
             (guix derivations)
             ((guix build utils) #:select (dump-port))
             (nar-herder utils)
             (nar-herder database)
             (nar-herder storage)
             (nar-herder mirror)
             (nar-herder server))

(define %base-options
  (list (option '("database") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'database
                              arg
                              result)))
        (option '("database-dump") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'database-dump
                              arg
                              result)))))

(define %base-option-defaults
  ;; Alist of default option values
  `((database . ,(string-append (getcwd) "/nar_herder.db"))
    (database-dump . ,(string-append (getcwd) "/nar_herder_dump.db"))))

(define %server-options
  (list (option '("port") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'port
                              (string->number arg)
                              (alist-delete 'port result))))
        (option '("host") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'host
                              arg
                              (alist-delete 'host result))))
        (option '("storage") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'storage
                              arg
                              (alist-delete 'storage result))))
        (option '("storage-limit") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'storage-limit
                              (if (string=? arg "none")
                                  "none"
                                  (string->number arg))
                              (alist-delete 'storage-limit result))))

        ;; stored-on=https://other-nar-herder-server
        ;; stored-on=https://other-nar-herder-server&stored-on=https://different-server
        (option '("storage-nar-removal-criteria") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'storage-nar-removal-criteria
                              (match (string-split arg #\=)
                                ((sym rest ...)
                                 (cons (string->symbol sym) rest)))
                              result)))

        (option '("mirror") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'mirror
                              arg
                              (alist-delete 'mirror result))))))

(define %server-option-defaults
  '((port                                 . 8080)
    (host                                 . "0.0.0.0")

    (storage-limit                        . "none")))

(define (parse-options options defaults args)
  (args-fold
   args options
   (lambda (opt name arg result)
     (error "unrecognized option" name))
   (lambda (arg result)
     (alist-cons
      'arguments
      (cons arg
            (or (assoc-ref result 'arguments)
                '()))
      (alist-delete 'arguments result)))
   defaults))

(match (cdr (program-arguments))
  (("import" rest ...)
   (let* ((opts (parse-options %base-options
                               %base-option-defaults
                               rest))
          (database (setup-database
                     (assq-ref opts 'database))))
     (let* ((narinfos
             (append-map
              (lambda (file-or-dir)
                (let ((s (stat file-or-dir)))
                  (match (stat:type s)
                    ('regular (list file-or-dir))
                    ('directory
                     (let ((dir file-or-dir))
                       (map
                        (lambda (nar-filename)
                          (string-append dir
                                         (if (string-suffix? "/" dir)
                                             ""
                                             "/")
                                         nar-filename))
                        (scandir file-or-dir
                                 (lambda (name)
                                   (string-suffix? ".narinfo" name)))))))))
              (assq-ref opts 'arguments)))
            (len (length narinfos))
            (progress
             (progress-reporter/bar len
                                    (format #f "importing ~a narinfos"
                                            len)
                                    (current-error-port))))

       (call-with-progress-reporter progress
         (lambda (report)
           (for-each (lambda (narinfo)
                       (database-insert-narinfo
                        database
                        (call-with-input-file narinfo
                          (lambda (port)
                            ;; Set url to a dummy value as this doesn't
                            ;; matter
                            (read-narinfo port "https://narherderdummyvalue"))))

                       (report))
                     narinfos))))))
  (("run-server" rest ...)
   (simple-format (current-error-port) "locale is ~A\n" (check-locale!))

   (let* ((opts (parse-options (append %base-options
                                       %server-options)
                               (append %base-option-defaults
                                       %server-option-defaults)
                               rest))
          (unknown-arguments
           (or (assq-ref opts 'arguments)
               '()))
          (lgr (make <logger>))
          (port-log (make <port-log>
                      #:port (current-output-port)
                      #:formatter
                      (lambda (lvl time str)
                        (format #f "~a (~5a): ~a~%"
                                (strftime "%F %H:%M:%S" (localtime time))
                                lvl
                                str)))))

     (define (download-database)
       (let ((database-uri
              (string->uri
               (string-append (assq-ref opts 'mirror)
                              "/latest-database-dump"))))
         (call-with-values
             (lambda ()
               (http-get database-uri
                         #:decode-body? #f
                         #:streaming? #t))
           (lambda (response body)
             (when (not (= (response-code response) 200))
               (error "unable to fetch database from mirror"))

             (call-with-output-file (assq-ref opts 'database)
               (lambda (output-port)
                 (dump-port body output-port)))

             (simple-format (current-error-port)
                            "finished downloading the database\n")))))

     (add-handler! lgr port-log)
     (open-log! lgr)
     (set-default-logger! lgr)

     (unless (null? unknown-arguments)
       (simple-format (current-error-port)
                      "unknown arguments: ~A\n"
                      unknown-arguments)
       (exit 1))

     (unless (or (assq-ref opts 'mirror)
                 (assq-ref opts 'storage))
       (simple-format (current-error-port)
                      "error: you must specify --mirror or --storage\n")
       (exit 1))

     (and=>
      (assq-ref opts 'mirror)
      (lambda (mirror)
        (let ((database-file (assq-ref opts 'database)))
          (if (file-exists? database-file)
              (begin
                ;; TODO Open the database, and check if the
                ;; latest changes in the database are visible on
                ;; the source to mirror. If they're not, then
                ;; delete the database and download it to get
                ;; back in sync

                #f)
              (download-database)))))

     (let ((database (setup-database (assq-ref opts 'database)))
           (canonical-storage (and=> (assq-ref opts 'storage)
                                     canonicalize-path)))
       (and=> (assq-ref opts 'pid-file)
              (lambda (pid-file)
                (call-with-output-file pid-file
                  (lambda (port)
                    (simple-format port "~A\n" (getpid))))))

       (when (not (file-exists? (assq-ref opts 'database-dump)))
         (simple-format (current-error-port)
                        "dumping database...\n")
         (dump-database database (assq-ref opts 'database-dump)))

       (and=> (assq-ref opts 'mirror)
              (lambda (mirror)
                (start-fetch-changes-thread database mirror)

                (when (assq-ref opts 'storage)
                  (start-mirroring-thread database
                                          mirror
                                          (assq-ref opts 'storage-limit)
                                          canonical-storage))))


       (when (and (assq-ref opts 'storage)
                  (number? (assq-ref opts 'storage-limit)))
         (start-nar-removal-thread database
                                   canonical-storage
                                   (assq-ref opts 'storage-limit)
                                   (filter-map
                                    (match-lambda
                                      ((key . val)
                                       (if (eq? key 'storage-nar-removal-criteria)
                                           val
                                           #f)))
                                    opts)))

       (simple-format (current-error-port)
                      "starting server\n")
       (run-server
        (make-request-handler database
                              canonical-storage)
        #:host (assq-ref opts 'host)
        #:port (assq-ref opts 'port))))))