path: root/scripts/guix-qa-frontpage.in

#!@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)
             (prometheus)
             (guix-qa-frontpage database)
             (guix-qa-frontpage issue)
             (guix-qa-frontpage branch)
             (guix-qa-frontpage patchwork)
             (guix-qa-frontpage manage-builds)
             (guix-qa-frontpage git-repository)
             (guix-qa-frontpage manage-patch-branches)
             (guix-qa-frontpage server))

(unless (getenv "GC_RETRY_SIGNALS")
  (begin
    (setenv "GC_RETRY_SIGNALS" "0")
    (apply execlp (car (command-line)) (command-line))))

(define doc-dir
  (let ((install-dir
         "@prefix@/share/doc/guix-qa-frontpage")
        (dev-dir
         (getcwd)))
    (if (file-exists? install-dir)
        install-dir
        dev-dir)))

(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 '("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 '("database") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'database
                              arg
                              result)))
        (option '("submit-builds") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'submit-builds #t result)))
        (option '("manage-patch-branches") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'manage-patch-branches #t result)))))

(define %default-repl-server-port
  ;; Default port to run REPL server on, if --listen-repl is provided
  ;; but no port is mentioned
  37146)

(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)))
    (database . ,(string-append (getcwd)
                                "/guix_qa_frontpage.db"))
    (submit-builds . #f)
    (manage-patch-branches . #f)))

(define %submit-build-options
  (list (option '("database") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'database
                              arg
                              result)))
        (option '("priority") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'priority
                              (string->number arg)
                              result)))
        (option '("system") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'systems
                              (cons arg
                                    (or (assq-ref result
                                                  'systems)
                                        '()))
                              (alist-delete 'systems
                                            result))))))

(define %submit-build-default-options
  `((database . ,(string-append (getcwd)
                                "/guix_qa_frontpage.db"))))

(define (parse-options options defaults args)
  (args-fold
   args options
   (lambda (opt name arg result)
     (error "unrecognized option" name))
   (lambda (arg result)
     (error "extraneous argument" arg))
   defaults))

(define patch-issues-to-show 150)

(setvbuf (current-output-port) 'line)
(setvbuf (current-error-port) 'line)

(match (cdr (program-arguments))
  (("submit-issue-builds" issue-number-str rest ...)
   (parameterize
       ((%git-repository-location (string-append (getcwd) "/guix.git")))
     (let* ((opts (parse-options
                   %submit-build-options
                   %submit-build-default-options
                   rest))
            (metrics-registry (make-metrics-registry
                               #:namespace
                               "guixqafrontpage"))
            (database
             (setup-database (assq-ref opts 'database)
                             metrics-registry)))

       (submit-builds-for-issue
        database
        "http://127.0.0.1:8746"
        "https://data.qa.guix.gnu.org"
        issue-number-str
        #:priority
        (or (assq-ref opts 'priority)
            (lambda (change)
              (if (member (assoc-ref change "system")
                          '("x86_64-linux" "aarch64-linux"))
                  550
                  350)))))))

  (("submit-branch-builds" branch-name rest ...)
   (parameterize
       ((%git-repository-location (string-append (getcwd) "/guix.git")))
     (let* ((opts (parse-options
                   %submit-build-options
                   %submit-build-default-options
                   rest))
            (metrics-registry (make-metrics-registry
                               #:namespace
                               "guixqafrontpage"))
            (database
             (setup-database (assq-ref opts 'database)
                             metrics-registry)))

       (submit-builds-for-branch
        database
        "http://127.0.0.1:8746"
        "https://data.qa.guix.gnu.org"
        branch-name
        #:priority
        (or (assq-ref opts 'priority)
            default-branch-priority-for-change)
        #:systems
        (or (assq-ref opts 'systems)
            %systems-to-submit-builds-for)))))

  (("create-issue-branch" issue rest ...)
   (parameterize
       ((%git-repository-location (string-append (getcwd) "/guix.git")))
     (let* ((opts (parse-options
                   %submit-build-options
                   %submit-build-default-options
                   rest))
            (metrics-registry (make-metrics-registry
                               #:namespace
                               "guixqafrontpage"))
            (database
             (setup-database (assq-ref opts 'database)
                             metrics-registry))
            (issue-number
             (string->number issue))
            (all-patchwork-series
             (with-sqlite-cache
              database
              'latest-patchwork-series-by-issue
              latest-patchwork-series-by-issue
              #:args `(#:count ,patch-issues-to-show)
              #:ttl 600)))

       (create-branch-for-issue
        database
        issue-number
        (assq-ref all-patchwork-series
                  issue-number)))))

  ((args ...)
   (let ((opts (parse-options
                %options
                %default-options
                args)))
     (when (assq-ref opts 'repl)
       ((@@ (ice-9 top-repl) call-with-sigint)
        start-repl)
       (exit 0))

     (let ((repl-port (assoc-ref opts 'listen-repl)))
       (when repl-port
         (spawn-server (make-tcp-server-socket #:port repl-port))))

     (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))

     (with-fluids ((%file-port-name-canonicalization 'none))
       (parameterize
           ((%git-repository-location (string-append (getcwd) "/guix.git")))
         (let* ((metrics-registry (make-metrics-registry
                                   #:namespace
                                   "guixqafrontpage"))
                (database
                 (setup-database (assq-ref opts 'database)
                                 metrics-registry)))

           (when (assq-ref opts 'manage-patch-branches)
             (start-manage-patch-branches-thread database
                                                 metrics-registry
                                                 #:series-count patch-issues-to-show))

           (start-guix-qa-frontpage
            (assq-ref opts 'port)
            (assq-ref opts 'host)
            (assq-ref opts 'assets-directory)
            database
            metrics-registry
            #:controller-args `(#:doc-dir ,doc-dir
                                #:patch-issues-to-show ,patch-issues-to-show)
            #:submit-builds? (assq-ref opts 'submit-builds)
            #:patch-issues-to-show patch-issues-to-show
            #:generate-reproducible.json #t)))))))