#!@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 textual-ports) (system repl server) (gcrypt pk-crypto) (guix pki) (guix-data-service config) (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 '("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-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-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))))) (let ((repl-port (assoc-ref opts 'listen-repl))) (when repl-port (spawn-server (make-tcp-server-socket #:port repl-port)))) (when (assoc-ref opts 'update-database) (let ((command (list (%config 'sqitch) "deploy" "--db-client" (%config 'sqitch-psql) "--chdir" (dirname (%config 'sqitch-plan)) "--plan-file" (%config 'sqitch-plan) (string-append "db:pg://" (%config 'database-user) "@" (if (string=? (%config 'database-host) "localhost") "" ; This means the unix socket ; connection will be used (%config 'database-host)) "/" (%config 'database-name))))) (simple-format #t "running command: ~A\n" (string-join command)) (unless (zero? (apply system* command)) (simple-format (current-error-port) "error: sqitch command failed\n") (exit 1)))) (let ((pid-file (assq-ref opts 'pid-file))) (when pid-file (call-with-output-file pid-file (lambda (port) (simple-format port "~A\n" (getpid)))))) (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))) ;; 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) #:postgresql-statement-timeout (assq-ref opts 'postgresql-statement-timeout))))