289 lines
12 KiB
Plaintext
289 lines
12 KiB
Plaintext
#!@GUILE@ --no-auto-compile
|
|
-*- scheme -*-
|
|
-*- geiser-scheme-implementation: guile -*-
|
|
!#
|
|
;;; Guix Data Service -- Information about Guix over time
|
|
;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
|
|
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
|
|
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
|
|
;;;
|
|
;;; 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
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
(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))))
|