Initial commit

1 files changed, 106 insertions, 0 deletions

diff --git a/scripts/guix-qa-frontpage.in b/scripts/guix-qa-frontpage.in
new file mode 100644
index 0000000..b692e5a
--- /dev/null
+++ b/scripts/guix-qa-frontpage.in
@@ -0,0 +1,106 @@
+#!@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 textual-ports)
+             (system repl server)
+             (system repl repl)
+             (gcrypt pk-crypto)
+             (guix pki)
+             (guix-qa-frontpage server))
+
+(define %options
+  ;; Specifications of the command-line options
+  (list (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 '("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))))))
+
+(define %default-options
+  ;; Alist of default option values
+  `((port              . 8765)
+    (host              . "0.0.0.0")
+
+    (assets-directory  . ,(let ((install-dir
+                                 "@prefix@/share/guix-qa-frontpage/assets")
+                                (dev-dir
+                                 (string-append (getcwd) "/assets")))
+                            (if (file-exists? install-dir)
+                                install-dir
+                                dev-dir)))))
+
+(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 ((pid-file (assq-ref opts 'pid-file)))
+    (when pid-file
+      (call-with-output-file pid-file
+        (lambda (port)
+          (simple-format port "~A\n" (getpid))))))
+
+  ;; 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-qa-frontpage-web-server
+   (assq-ref opts 'port)
+   (assq-ref opts 'host)
+   (assq-ref opts 'assets-directory)))