Add lots more functionality

1 files changed, 410 insertions, 0 deletions

diff --git a/guix-qa-frontpage/view/util.scm b/guix-qa-frontpage/view/util.scm
new file mode 100644
index 0000000..784e499
--- /dev/null
+++ b/guix-qa-frontpage/view/util.scm
@@ -0,0 +1,410 @@
+;;; Guix QA Frontpage
+;;;
+;;; Copyright © 2022 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program 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
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-qa-frontpage view util)
+  #:use-module (guix-data-service config)
+  #:use-module (guix-data-service web query-parameters)
+  #:use-module (guix-data-service web util)
+  #:use-module (guix-data-service web html-utils)
+  #:use-module ((guix-data-service web render) #:prefix guix-data-service:)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (web uri)
+  #:use-module (texinfo)
+  #:use-module (texinfo html)
+  #:use-module (json)
+  #:export (layout
+            header
+            form-horizontal-control
+
+            display-possible-store-item
+            display-store-item
+            display-store-item-short
+
+            table/branches-with-most-recent-commits
+
+            render-html
+
+            general-not-found
+            error-page
+
+            static-asset-from-store-renderer
+            static-asset-from-directory-renderer))
+
+(define* (layout #:key
+                 (head '())
+                 (body '())
+                 title
+                 description)
+  `((doctype "html")
+    (html
+     (@ (lang "en"))
+     (head
+      (title ,(if title
+                  (string-append title " — Guix Quality Assurance")
+                  "Guix Quality Assurance"))
+      (meta (@ (http-equiv "Content-Type")
+               (content "text/html; charset=UTF-8")))
+      (meta (@ (name "viewport")
+               (content "width=device-width, initial-scale=1")))
+      ,@(if description
+            `((meta
+               (@ (name "description")
+                  (content ,description))))
+            '())
+      (link
+       (@ (rel "stylesheet")
+          (media "screen")
+          (type "text/css")
+          (href "/assets/css/mvp.css")))
+      (style
+          "
+:root {
+  --justify-important: left;
+}
+
+header, main {
+    padding: 1rem;
+}
+
+header {
+    border-bottom: 2px dashed orange;
+}
+
+.row {
+    display: flex;
+
+    border-bottom: 2px dashed orange;
+}
+
+.two-element-row section {
+    width: 50%;
+}
+
+.row section {
+    flex-grow: 1;
+
+    padding-left: 10px;
+
+    margin-top: 10px;
+    margin-bottom: 10px;
+}
+
+.row section:not(:last-child) {
+    border-right: 2px dashed orange;
+}
+
+")
+      ,@head)
+     (body (header
+            (h1 "Guix QA"))
+           ,@body
+           (footer
+            (p "Copyright © 2016—2020 by the GNU Guix community."
+               (br)
+               "Now with even more " (span (@ (class "lambda")) "λ") "! ")
+            (p "This is free software.  Download the "
+               (a (@ (href "https://git.savannah.gnu.org/cgit/guix/data-service.git/"))
+                  "source code here") "."))))))
+
+(define* (form-horizontal-control label query-parameters
+                                  #:key
+                                  name
+                                  help-text
+                                  required?
+                                  options
+                                  (allow-selecting-multiple-options #t)
+                                  font-family
+                                  (type "text")
+                                  (null-string-value "none"))
+  (define (value->text value)
+    (match value
+      (#f "")
+      ((? date? date)
+       (date->string date "~1 ~3"))
+      (other other)))
+
+  (let* ((input-id    (hyphenate-words
+                       (string-downcase label)))
+         (help-span-id (string-append
+                        input-id "-help-text"))
+         (input-name (or name
+                         (underscore-join-words
+                          (string-downcase label))))
+         (has-error? (let ((val
+                            (assq-ref query-parameters
+                                      (string->symbol input-name))))
+                       (if (list? val)
+                           (any invalid-query-parameter? val)
+                           (invalid-query-parameter? val))))
+         (show-help-span?
+          (or help-text has-error? required?)))
+    (if (string=? type "hidden")
+        `(input (@ (class "form-control")
+                   (id ,input-id)
+                   (type ,type)
+                   (name ,input-name)
+                   ,@(match (assq (string->symbol input-name)
+                                  query-parameters)
+                       (#f '())
+                       ((_key . value)
+                        `((value ,(value->text value)))))))
+        `(div
+          (@ (class ,(string-append
+                      "form-group form-group-lg"
+                      (if has-error? " has-error" ""))))
+          (label (@ (for ,input-id)
+                    (class "col-sm-2 control-label"))
+                 ,label)
+          (div
+           (@ (class "col-sm-9"))
+           ,(if options
+                `(select (@ (class "form-control")
+                            (style ,(if font-family
+                                        (string-append
+                                         "font-family: " font-family ";")
+                                        ""))
+                            ,@(if allow-selecting-multiple-options
+                                  '((multiple #t))
+                                  '())
+                            (id ,input-id)
+                            ,@(if show-help-span?
+                                  `((aria-describedby ,help-span-id))
+                                  '())
+
+                            (name ,input-name))
+                   ,@(let ((selected-options
+                            (match (assq (string->symbol input-name)
+                                         query-parameters)
+                              ((_key . value)
+                               (if (not allow-selecting-multiple-options)
+                                   (list value)
+                                   value))
+                              (_ '()))))
+
+                       (map (match-lambda
+                              ((option-label . option-value)
+                               `(option
+                                 (@ ,@(if (member (if (and
+                                                       (string? option-value)
+                                                       (string=? option-value
+                                                                 null-string-value))
+                                                      ""
+                                                      option-value)
+                                                  selected-options)
+                                          '((selected ""))
+                                          '())
+                                    (value ,option-value))
+                                 ,(value->text option-label)))
+                              (option-value
+                               `(option
+                                 (@ ,@(if (member (if (and
+                                                       (string? option-value)
+                                                       (string=? option-value
+                                                                 null-string-value))
+                                                      ""
+                                                      option-value)
+                                                  selected-options)
+                                          '((selected ""))
+                                          '()))
+                                 ,(value->text option-value))))
+                            options)))
+                `(input (@ (class "form-control")
+                           (style ,(if font-family
+                                       (string-append
+                                        "font-family: " font-family ";")
+                                       ""))
+                           (id ,input-id)
+                           (type ,type)
+                           ,@(if required?
+                                 '((required #t))
+                                 '())
+                           ,@(if show-help-span?
+                                 `((aria-describedby ,help-span-id))
+                                 '())
+                           (name ,input-name)
+                           ,@(match (assq (string->symbol input-name)
+                                          query-parameters)
+                               (#f '())
+                               ((_key . ($ <invalid-query-parameter> value))
+                                (if (string=? type "checkbox")
+                                    (if value
+                                        '((checked #t))
+                                        '())
+                                    `((value ,(value->text value)))))
+                               ((_key . value)
+                                (if (string=? type "checkbox")
+                                    (if value
+                                        '((checked #t))
+                                        '())
+                                    `((value ,(value->text value)))))))))
+           ,@(if show-help-span?
+                 `((span (@ (id ,help-span-id)
+                            (class "help-block"))
+                         ,@(if has-error?
+                               (let* ((val
+                                       (assq-ref query-parameters
+                                                 (string->symbol input-name)))
+                                      (messages
+                                       (map invalid-query-parameter-message
+                                            (if (list? val)
+                                                val
+                                                (list val)))))
+                                 `((p
+                                    ,@(if (null? messages)
+                                          '(string "Error: invalid value")
+                                          (map
+                                           (lambda (message)
+                                             `(strong
+                                               (@ (style "display: block;"))
+                                               "Error: "
+                                               ,@(if (list? message)
+                                                     message
+                                                     (list message))))
+                                           (remove (lambda (v)
+                                                     (eq? #f v))
+                                                   messages))))))
+                               '())
+                         ,@(if required? '((strong "Required. ")) '())
+                         ,@(if help-text
+                               (list help-text)
+                               '())))
+                 '()))))))
+
+(define render-html
+  guix-data-service:render-html)
+
+(define (general-not-found header-text body)
+  (layout
+   #:body
+   `((div
+      (@ (class "container"))
+      (h1 ,header-text)
+      (p ,body)))))
+
+(define* (error-page #:optional error)
+  (layout
+   #:body
+   `((div (@ (class "container"))
+          (h1 "An error occurred")
+          (p "Sorry about that!")
+          ,@(if error
+                (match error
+                  ((key . args)
+                   `((b ,key)
+                     (pre ,args))))
+                '())))))
+
+(define file-mime-types
+  '(("css" . (text/css))
+    ("js"  . (text/javascript))
+    ("svg" . (image/svg+xml))
+    ("png" . (image/png))
+    ("gif" . (image/gif))
+    ("woff" . (application/font-woff))
+    ("ttf"  . (application/octet-stream))
+    ("html" . (text/html))))
+
+(define (static-asset-from-store-renderer assets-directory)
+  (define last-modified
+    ;; Use the process start time as the last modified time, as the file
+    ;; metadata in the store is normalised.
+    (current-time))
+
+  (define files
+    (file-system-fold
+     (const #t)                         ; enter
+     (lambda (filename stat result)
+       (let ((relative-filename (string-drop filename
+                                             (+ 1 ; to account for the /
+                                                (string-length
+                                                 assets-directory)))))
+         (cons (cons relative-filename
+                     (call-with-input-file filename
+                       get-bytevector-all))
+               result)))
+     (lambda (name stat result) result) ; down
+     (lambda (name stat result) result) ; up
+     (lambda (name stat result) result) ; skip
+     (lambda (name stat errno result)
+       (error name))
+     '()
+     assets-directory))
+
+  (define (send-file path contents)
+    (list `((content-type
+             . ,(assoc-ref file-mime-types
+                           (file-extension path)))
+            (last-modified . ,(time-utc->date last-modified))
+            (cache-control . (public
+                              ;; Set the max-age at 5 minutes, as the files
+                              ;; could change when the code changes
+                              (max-age . ,(* 60 5)))))
+          contents))
+
+  (lambda (path headers)
+    (and=> (assoc-ref files path)
+           (lambda (contents)
+             (cond ((assoc-ref headers 'if-modified-since)
+                    =>
+                    (lambda (client-date)
+                      (if (time>? last-modified
+                                  (date->time-utc client-date))
+                          (send-file path contents)
+                          (list (build-response #:code 304) ; "Not Modified"
+                                #f))))
+                   (else
+                    (send-file path contents)))))))
+
+(define (static-asset-from-directory-renderer assets-directory)
+  (lambda (path headers)
+    (render-static-file assets-directory path headers)))
+
+(define %not-slash
+  (char-set-complement (char-set #\/)))
+
+(define (render-static-file root path headers)
+  (let ((file-name (string-append root "/" path)))
+    (if (not (any (cut string-contains <> "..")
+                  (string-tokenize path %not-slash)))
+        (let* ((stat (stat file-name #f))
+               (modified (and stat
+                              (make-time time-utc 0 (stat:mtime stat)))))
+          (define (send-file)
+            (list `((content-type
+                     . ,(assoc-ref file-mime-types
+                                   (file-extension file-name)))
+                    (last-modified . ,(time-utc->date modified)))
+                  (call-with-input-file file-name get-bytevector-all)))
+
+          (if (and stat (not (eq? 'directory (stat:type stat))))
+              (cond ((assoc-ref headers 'if-modified-since)
+                     =>
+                     (lambda (client-date)
+                       (if (time>? modified (date->time-utc client-date))
+                           (send-file)
+                           (list (build-response #:code 304) ;"Not Modified"
+                                 #f))))
+                    (else
+                     (send-file)))
+              #f))
+        #f)))