Get most of the functionality sort of working

At least working enough to start trying this out, and finding the
problems.

1 files changed, 297 insertions, 0 deletions

diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
new file mode 100644
index 0000000..372dd39
--- /dev/null
+++ b/scripts/nar-herder.in
@@ -0,0 +1,297 @@
+#!@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)))))
+
+(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)))))))))
+              rest))
+            (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))))))