#!@GUILE@ --no-auto-compile -*- scheme -*- -*- geiser-scheme-implementation: guile -*- !# ;;; Guix Data Service -- Information about Guix over time ;;; Copyright © 2016, 2017 Ricardo Wurmus ;;; Copyright © 2018 Arun Isaac ;;; Copyright © 2019 Christopher Baines ;;; ;;; This file is part of guix-data-service. ;;; ;;; guix-data-service 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. ;;; ;;; guix-data-service 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 ;;; . (use-modules (srfi srfi-1) (srfi srfi-37) (ice-9 match) (ice-9 atomic) (ice-9 threads) (ice-9 textual-ports) (system repl server) (system repl repl) (gcrypt pk-crypto) (guix pki) (guix-data-service utils) (guix-data-service config) (guix-data-service database) (guix-data-service substitutes) (guix-data-service poll-git-repository) (guix-data-service model git-repository) (guix-data-service model guix-revision-package-derivation) (guix-data-service web server) (guix-data-service web controller) (guix-data-service web nar controller)) (define %default-repl-server-port ;; Default port to run REPL server on, if --listen-repl is provided ;; but no port is mentioned 37146) (define %options ;; Specifications of the command-line options (list (option '("listen-repl") #f #t (lambda (opt name arg result) (let ((port (cond (arg => string->number) (else %default-repl-server-port)))) (if port (alist-cons 'listen-repl port (alist-delete 'listen-repl result)) (error "invalid REPL server port" arg))))) (option '("repl") #f #t (lambda (opt name arg result) (alist-cons 'repl #t (alist-delete 'repl result)))) (option '("pid-file") #t #f (lambda (opt name arg result) (alist-cons 'pid-file arg result))) (option '("secret-key-base-file") #t #f (lambda (opt name arg result) (alist-cons 'secret-key-base (string-trim-right (call-with-input-file arg get-string-all)) result))) (option '("narinfo-signing-public-key") #t #f (lambda (opt name arg result) (alist-cons 'narinfo-signing-public-key arg result))) (option '("narinfo-signing-private-key") #t #f (lambda (opt name arg result) (alist-cons 'narinfo-signing-private-key arg result))) (option '("update-database") #f #f (lambda (opt name _ result) (alist-cons 'update-database #t result))) (option '("show-error-details") #f #f (lambda (opt name _ result) (alist-cons 'show-error-details #t result))) (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 '("postgresql-connections") #t #f (lambda (opt name arg result) (alist-cons 'postgresql-connections (string->number arg) (alist-delete 'postgresql-connections result)))) (option '("postgresql-statement-timeout") #t #f (lambda (opt name arg result) (alist-cons 'postgresql-statement-timeout (string->number arg) (alist-delete 'postgresql-statement-timeout result)))))) (define %default-options ;; Alist of default option values `((listen-repl . #f) (narinfo-signing-public-key . ,%public-key-file) (narinfo-signing-private-key . ,%private-key-file) (update-database . #f) (show-error-details . ,(match (getenv "GUIX_DATA_SERVICE_SHOW_ERROR_DETAILS") (#f #f) ("" #f) (_ #t))) (port . 8765) (host . "0.0.0.0") (postgresql-connections . 16) (postgresql-statement-timeout . 60000))) (define (parse-options args) (args-fold args %options (lambda (opt name arg result) (error "unrecognized option" name)) (lambda (arg result) (error "extraneous argument" arg)) %default-options)) (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) (let ((opts (parse-options (cdr (program-arguments))))) (when (assq-ref opts 'repl) ((@@ (ice-9 top-repl) call-with-sigint) (lambda () (with-postgresql-connection-per-thread "repl" start-repl))) (exit 0)) (let ((repl-port (assoc-ref opts 'listen-repl))) (when repl-port (spawn-server (make-tcp-server-socket #:port repl-port)))) (parameterize ((%narinfo-signing-public-key (catch 'system-error (lambda () (and=> (assoc-ref opts 'narinfo-signing-public-key) read-file-sexp)) (lambda (key . args) (simple-format (current-error-port) "warning: failed to load narinfo signing public key from ~A\n" (assoc-ref opts 'narinfo-signing-private-key)) (simple-format (current-error-port) " ~A: ~A\n" key args)))) (%narinfo-signing-private-key (catch 'system-error (lambda () (and=> (assoc-ref opts 'narinfo-signing-private-key) read-file-sexp)) (lambda (key . args) (simple-format (current-error-port) "warning: failed to load narinfo signing private key from ~A\n" (assoc-ref opts 'narinfo-signing-private-key)) (simple-format (current-error-port) " ~A: ~A\n" key args) (display "warning: not signing narinfo files\n" (current-error-port)) #f))) (%show-error-details (assoc-ref opts 'show-error-details))) (let* ((startup-completed (make-atomic-box (if (assoc-ref opts 'update-database) #f #t))) (pid-file (assq-ref opts 'pid-file))) (when pid-file (call-with-output-file pid-file (lambda (port) (simple-format port "~A\n" (getpid))))) (start-substitute-query-threads) (call-with-new-thread (lambda () (with-exception-handler (lambda (exn) (simple-format (current-error-port) "startup failed: ~A\n" exn) (exit 1)) (lambda () (run-sqitch) (for-each (lambda (git-repository-details) (when (fifth git-repository-details) (simple-format #t "starting thread to poll ~A (~A)\n" (second git-repository-details) (third git-repository-details)) (start-thread-to-poll-git-repository (first git-repository-details)))) (with-postgresql-connection "poll-startup" all-git-repositories)) (atomic-box-set! startup-completed #t))))) ;; Provide some visual space between the startup output and the ;; server starting (simple-format #t "\n\nStarting the server on http://~A:~A/\n\n" (assq-ref opts 'host) (assq-ref opts 'port)) (start-guix-data-service-web-server (assq-ref opts 'port) (assq-ref opts 'host) (assq-ref opts 'secret-key-base) startup-completed #:postgresql-statement-timeout (assq-ref opts 'postgresql-statement-timeout) #:postgresql-connections (assq-ref opts 'postgresql-connections)))))