242 lines
9.4 KiB
Plaintext
242 lines
9.4 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 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)))))
|
|
|
|
(call-with-new-thread
|
|
(lambda ()
|
|
(with-postgresql-connection-per-thread
|
|
"backfill"
|
|
(lambda ()
|
|
(backfill-guix-revision-package-derivation-distribution-counts)))))
|
|
|
|
(start-substitute-query-threads)
|
|
|
|
(call-with-new-thread
|
|
(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)))))
|