aboutsummaryrefslogtreecommitdiff
path: root/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'scripts')
-rw-r--r--scripts/nar-herder.in297
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))))))
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-21 18:47:26 +0000