#!@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 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 '("thread-pool-threads") #t #f (lambda (opt name arg result) (alist-cons 'thread-pool-threads (string->number arg) (alist-delete 'thread-pool-threads 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") (thread-pool-threads . 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)) (%thread-pool-threads (assoc-ref opts 'thread-pool-threads)) (%thread-pool-idle-seconds 60) (%thread-pool-idle-thunk (lambda () (close-thread-postgresql-connection)))) (let* ((startup-completed (make-atomic-box (if (assoc-ref opts 'update-database) #f #t))) (server-thread (call-with-new-thread (lambda () (with-postgresql-connection-per-thread "web" (lambda () ;; 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)) #:statement-timeout (assq-ref opts 'postgresql-statement-timeout))))) (pid-file (assq-ref opts 'pid-file))) (call-with-new-thread (lambda () (with-postgresql-connection-per-thread "backfill" (lambda () (backfill-guix-revision-package-derivation-distribution-counts))))) (when pid-file (call-with-output-file pid-file (lambda (port) (simple-format port "~A\n" (getpid))))) (when (assoc-ref opts 'update-database) (let ((command (list (%config 'sqitch) "deploy" "--db-client" (%config 'sqitch-psql) ;; For some reason, sqitch behaves differently when the ;; guix-data-service is packaged, and when it's not, so try ;; and hack around this here. "--chdir" (let ((base (dirname (%config 'sqitch-plan)))) (if (string-prefix? "/gnu" (%config 'sqitch-plan)) base (dirname base))) "--plan-file" (%config 'sqitch-plan) "--mode" "change" ; this helps when migrations don't ; have the revert bit implemented (let* ((database-config (get-database-config)) (params (string-join (map (match-lambda ((key . val) (string-append key "=" val))) (filter (match-lambda ((key . _) (not (member key '("user" "host" "dbname"))))) database-config)) "&"))) (string-append "db:pg://" (assoc-ref database-config "user") "@" (if (string=? (assoc-ref database-config "host") "localhost") "" ; This means the unix socket ; connection will be used (assoc-ref database-config "host")) "/" (assoc-ref database-config "dbname") (if (string-null? params) "" "?") params))))) (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)) (atomic-box-set! startup-completed #t))) (start-substitute-query-thread) (join-thread server-thread))))