Initial commit

3 files changed, 620 insertions, 0 deletions

diff --git a/bffe/view/activity.scm b/bffe/view/activity.scm
new file mode 100644
index 0000000..484aa36
--- /dev/null
+++ b/bffe/view/activity.scm
@@ -0,0 +1,338 @@
+(define-module (bffe view activity)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (bffe view util)
+  #:use-module ((guix store) #:select (%store-prefix))
+  #:export (activity))
+
+(define (activity title state)
+  (define categorised-agents
+    (let ((categories
+           '(("x86_64-linux" "i686-linux")
+             ("aarch64-linux" "armhf-linux")
+             ("powerpc64le-linux")
+             ("i586-gnu"))))
+      (map
+       (lambda (systems)
+         (cons systems
+               (sort
+                (filter
+                 (lambda (agent)
+                   (not
+                    (null?
+                     (lset-intersection
+                      string=?
+                      (vector->list
+                       (assoc-ref agent "requested_systems"))
+                      systems))))
+                 (vector->list
+                  (assoc-ref state "agents")))
+                (lambda (a b)
+                  (string<? (or (assoc-ref a "name") "")
+                            (or (assoc-ref b "name") ""))))))
+       categories)))
+
+  (define (abbreviate-derivation drv)
+    (let ((base (string-drop
+                 drv
+                 (+ 1 (string-length (%store-prefix))))))
+      (string-drop-right
+       (string-drop base (+ 32 1))      ;32 hash part + 1 hyphen
+       4)))                             ;.drv
+
+  (define (git-commit-hash-length? str)
+    (= (string-length str) 40))
+
+  (layout
+   #:title (string-append "Activity — " title)
+   #:head
+   `((style "
+table tr:nth-child(even) {
+    background-color: var(--color-bg);
+}
+
+.agents {
+    display: grid;
+    column-gap: 5px;
+    row-gap: 5px;
+    grid-template-columns: repeat(auto-fill, minmax(355px, 355px));
+}
+
+.agent {
+    border: 2px solid var(--color-bg-secondary);
+    border-radius: var(--border-radius);
+    padding: 8px;
+}
+
+.agent h4 {
+    margin-block-start: 0px;
+    font-size: 22px;
+}
+
+.agent-load {
+    border-width: 0px 12px 0px 0px;
+    border-style: solid;
+    padding-right: 3px;
+
+    border-radius: 3px;
+}
+
+.agent-load-normal {
+    border-color: #28a745;
+}
+
+.agent-load-medium {
+    border-color: orange;
+}
+
+.agent-load-high {
+    border-color: red;
+}
+
+.agent-plan-size {
+    float: right;
+    clear: right;
+
+    border-radius: 3px;
+}
+
+.build-tag {
+    display: inline-block;
+    padding: .2em .4em .3em;
+    font-size: 77%;
+    font-weight: 700;
+    line-height: 1;
+    text-align: center;
+    white-space: nowrap;
+    vertical-align: baseline;
+    border-radius: .25em;
+
+    background-color: var(--color-secondary-accent);
+}
+
+.build {
+    overflow-x: auto;
+    white-space: nowrap;
+
+    padding-top: 3px;
+    padding-bottom: 4px;
+    margin-bottom: 3px;
+}
+
+.build:not(:first-child) {
+    border-top: 2px solid var(--color-bg-secondary);
+}
+
+.hidden {
+    display: none;
+}
+
+#recent-activity {
+    width: 100%;
+    height: 200px;
+    overflow-y: scroll;
+}
+
+"))
+   #:body
+   `((main
+      (@ (id "main")
+         (data-stateid ,(assoc-ref state "state_id")))
+
+      (h2 "Recent activity")
+      (table
+       (@ (id "recent-activity"))
+       (tbody
+        (@ (id "recent-activity-body"))))
+
+      (h2 "Agents")
+      ,@(append-map
+         (match-lambda
+           ((systems . agents)
+            `((h3 (@ (class "monospace"))
+                  ,(string-join systems ", "))
+
+              (div
+               (@ (class "agents"))
+
+               ,@(filter-map
+                  (lambda (agent)
+                    (if (assoc-ref agent "active")
+                        (let ((all-builds
+                               (vector->list
+                                (assoc-ref agent "builds"))))
+                          `(div
+                            (@ (class "agent")
+                               (id
+                                ,(string-append
+                                  "agent-"
+                                  (assoc-ref agent "uuid")))
+                               (data-name
+                                ,(assoc-ref agent "name")))
+                            ,(let ((last-status-update
+                                    (assoc-ref
+                                     agent
+                                     "last_status_update")))
+                               (if (and last-status-update
+                                        (and=>
+                                         (assoc-ref last-status-update
+                                                    "timestamp")
+                                         (lambda (timestamp)
+                                           (let ((seconds
+                                                  (time-second
+                                                   (time-difference
+                                                    (current-time time-utc)
+                                                    (date->time-utc
+                                                     (string->date
+                                                      (string-append timestamp "Z")
+                                                      "~Y-~m-~d ~H:~M:~S~z"))))))
+                                             (< seconds (* 60 5))))))
+                                   (let* ((1min
+                                           (assoc-ref
+                                            last-status-update
+                                            "1min_load_average"))
+                                          (cores
+                                           (assoc-ref
+                                            last-status-update
+                                            "processor_count"))
+                                          (load-percentage
+                                           (/ (* 100 1min)
+                                              cores)))
+                                     `(span
+                                       (@ (style "float: right;")
+                                          (id
+                                           ,(string-append
+                                             "agent-"
+                                             (assoc-ref agent "uuid")
+                                             "-load"))
+                                          (class
+                                            ,(string-append
+                                              "agent-load "
+                                              (cond
+                                               ((< load-percentage 150)
+                                                "agent-load-normal")
+                                               ((< load-percentage 250)
+                                                "agent-load-medium")
+                                               (else
+                                                "agent-load-high"))))
+                                          (data-value
+                                           ,load-percentage))
+                                       "Load: "
+                                       ,(number->string
+                                         (round load-percentage))
+                                       "%"))
+                                   `(span
+                                     (@ (style "float: right;")
+                                        (id
+                                         ,(string-append
+                                           "agent-"
+                                           (assoc-ref agent "uuid")
+                                           "-load"))
+                                        (class "agent-load-unknown"))
+                                     "Status unknown")))
+                            (span
+                             (@ (class "agent-plan-size")
+                                (id
+                                 ,(string-append
+                                   "agent-"
+                                   (assoc-ref agent "uuid")
+                                   "-plan-size"))
+                                (data-value
+                                 ,(assoc-ref
+                                   (assoc-ref agent "allocation_plan")
+                                   "count")))
+                             "Plan size: "
+                             ,(assoc-ref
+                               (assoc-ref agent "allocation_plan")
+                               "count"))
+                            (h4 (@ (style "display: block;"))
+                                ,(assoc-ref agent "name"))
+                            (div
+                             (@ (class "agent-builds")
+                                (id
+                                 ,(string-append
+                                   "agent-"
+                                   (assoc-ref agent "uuid")
+                                   "-builds")))
+                             ,@(map
+                                (lambda (build index)
+                                  (let ((tags
+                                         (sort
+                                          (vector->list
+                                           (assoc-ref build "tags"))
+                                          (lambda (a b)
+                                            (string<?
+                                             (assoc-ref a "key")
+                                             (assoc-ref b "key"))))))
+                                    `(div
+                                      (@ (id
+                                          ,(string-append
+                                            "build-"
+                                            (assoc-ref build "uuid")))
+                                         (data-derivation
+                                          ,(or (assoc-ref build "derivation_name")
+                                               (assoc-ref build "derivation-name")))
+                                         (class
+                                           ,(string-append
+                                             "build"
+                                             (if (> index 3)
+                                                 " hidden"
+                                                 ""))))
+                                      (span
+                                       (@ (class "monospace")
+                                          (style "display: block;"))
+                                       ,(abbreviate-derivation
+                                         (or (assoc-ref build "derivation_name")
+                                             (assoc-ref build "derivation-name"))))
+                                      ,@(append-map
+                                         (lambda (tag)
+                                           `((span
+                                              (@ (class "build-tag"))
+                                              ,(assoc-ref tag "key")
+                                              ": "
+                                              ,(let ((val (assoc-ref
+                                                           tag "value")))
+                                                 (if (git-commit-hash-length? val)
+                                                     (string-take val 8)
+                                                     val)))
+                                             (*ENTITY* nbsp)))
+                                         tags))))
+                                ;; TODO Sort builds by priority?
+                                all-builds
+                                (iota (length all-builds))))
+                            (span
+                             (@ (id ,(string-append
+                                      "agent-"
+                                      (assoc-ref agent "uuid")
+                                      "-plus-x-builds"))
+                                (style ,(string-append
+                                         (if (> (length all-builds) 4)
+                                             "display: block;"
+                                             "display: none;")
+                                         "margin-top: 10px; text-align: center;")))
+                             ,(let ((additional-builds
+                                     (- (length all-builds)
+                                        4)))
+                                (if (= additional-builds 1)
+                                    (simple-format #f "Plus ~A other build"
+                                                   additional-builds)
+                                    (simple-format #f "Plus ~A other builds"
+                                                   additional-builds))))
+                            (span
+                             (@ (id ,(string-append
+                                      "agent-"
+                                      (assoc-ref agent "uuid")
+                                      "-no-allocated-builds"))
+                                (style ,(string-append
+                                         (if (= 0 (length all-builds))
+                                             "display: block;"
+                                             "display: none;")
+                                         "margin-top: 10px; text-align: center;")))
+                             "No allocated builds")))
+                        #f))
+                  agents)))))
+         categorised-agents)
+
+      (script (@ (src "/assets/js/activity.js")))))))
diff --git a/bffe/view/home.scm b/bffe/view/home.scm
new file mode 100644
index 0000000..820f75f
--- /dev/null
+++ b/bffe/view/home.scm
@@ -0,0 +1,14 @@
+(define-module (bffe view home)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (bffe view util)
+  #:export (home))
+
+(define (home title template-content)
+  (layout
+   #:title title
+   #:body
+   `((main
+      (raw ,template-content)))))
diff --git a/bffe/view/util.scm b/bffe/view/util.scm
new file mode 100644
index 0000000..9b4a676
--- /dev/null
+++ b/bffe/view/util.scm
@@ -0,0 +1,268 @@
+;;; Build Farm Front-End
+;;;
+;;; Copyright © 2023 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 (bffe 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 ftw)
+  #: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 (web response)
+  #: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
+            render-json
+
+            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 " — Build farm")
+                  "Build farm"))
+      (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;
+  --justify-normal: center;
+  --line-height: 1.5;
+}
+
+table td,
+table th,
+table tr {
+    text-align: center;
+}
+
+header, main {
+    padding: 1rem;
+}
+
+header {
+    border-bottom: 2px solid green;
+}
+
+.monospace {
+    font-family: monospace;
+    font-size: 16px;
+}
+
+@media (min-width: 700px) {
+  .large-screen-float-right {
+    float: right;
+  }
+}
+
+.derivation {
+  display: block;
+  font-family: monospace;
+  font-size: 16px;
+}
+
+@keyframes scale-move {
+    0%   { transform: scale(0.9,0); }
+    100% { transform: scale(1,1); }
+}
+
+.submitted-build {
+  animation: scale-move 0.8s;
+}
+
+.tag {
+  display: inline-block;
+  border-radius: 10px;
+  background: var(--color-bg-secondary);
+  padding: 0.25em 0.4em;
+  margin-right: 0.25rem;
+
+  font-family: monospace;
+  font-size: 14px;
+}
+
+")
+      ,@head)
+     (body (header
+            (h1 ,title))
+           ,@body))))
+
+(define render-html
+  guix-data-service:render-html)
+
+(define render-json
+  guix-data-service:render-json)
+
+(define (general-not-found header-text body)
+  (layout
+   #:body
+   `((main
+      (h1 ,header-text)
+      (p ,body)))))
+
+(define* (error-page #:optional error)
+  (layout
+   #:body
+   `((main
+      (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))
+                    (cache-control . (no-cache)))
+                  (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)))