#!@GUILE@ --no-auto-compile -*- scheme -*- -*- geiser-scheme-implementation: guile -*- !# ;;; Nar Herder ;;; ;;; Copyright © 2020 Christopher Baines ;;; ;;; 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 ;;; . (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 )) (port-log (make #: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 () (simple-format (current-error-port) "starting downloading the database\n") (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))))))