Initial commit

4 files changed, 1110 insertions, 0 deletions

diff --git a/bffe/server.scm b/bffe/server.scm
new file mode 100644
index 0000000..14d5d0a
--- /dev/null
+++ b/bffe/server.scm
@@ -0,0 +1,490 @@
+;;; 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 server)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-71)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (web http)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (json)
+  #:use-module (prometheus)
+  #:use-module (system repl error-handling)
+  #:use-module (fibers)
+  #:use-module (fibers channels)
+  #:use-module (fibers conditions)
+  #:use-module (fibers web server)
+  #:use-module (guix store)
+  #:use-module ((guix build utils) #:select (dump-port))
+  #:use-module (guix-data-service web util)
+  #:use-module ((guix-build-coordinator utils)
+                #:select (with-time-logging get-gc-metrics-updater
+                           call-with-delay-logging))
+  #:use-module ((guix-build-coordinator utils fibers)
+                #:select (run-server/patched call-with-sigint))
+  #:use-module (guix-build-coordinator client-communication)
+  #:use-module (bffe view util)
+  #:use-module (bffe view home)
+  #:use-module (bffe view activity)
+  #:export (start-bffe-web-server))
+
+(define (make-state-channel)
+  (let ((channel (make-channel)))
+    (call-with-new-thread
+     (lambda ()
+       (let loop ((last-fetch-time #f)
+                  (state #f))
+         (let ((reply-channel (get-message channel))
+               (state-age-seconds
+                (and last-fetch-time
+                     (- (time-second (current-time))
+                        last-fetch-time))))
+           (if (or (not state-age-seconds)
+                   (> state-age-seconds
+                      120))
+               (let ((response
+                      body
+                      (http-get
+                       (string->uri "http://localhost:8746/state"))))
+                 (let ((state
+                        (json-string->scm
+                         (utf8->string body))))
+                   (put-message reply-channel
+                                state)
+                   (loop (time-second (current-time))
+                         state)))
+               (begin
+                 (put-message
+                  reply-channel
+                  state)
+                 (loop last-fetch-time
+                       state)))))))
+
+    channel))
+
+(define (get-state state-channel)
+  (let ((reply-channel (make-channel)))
+    (put-message state-channel
+                 reply-channel)
+
+    (get-message reply-channel)))
+
+(define (make-events-channel initial-state-id)
+  (let* ((submission-channel (make-channel))
+         (listener-channels-box (make-atomic-box vlist-null))
+
+         (buffer-size 10000)
+         (event-buffer (make-vector buffer-size))
+
+         (current-state-id-and-event-buffer-index-box
+          (make-atomic-box (cons 0 -1))))
+
+    (define (get-state-id)
+      (match (atomic-box-ref
+              current-state-id-and-event-buffer-index-box)
+        ((current-state-id . event-buffer-index)
+         current-state-id)))
+
+    (define (spawn-fiber-for-listener callback
+                                      after-state-id
+                                      submission-channel
+                                      listener-channel
+                                      listening-finished-channel)
+      (spawn-fiber
+       (lambda ()
+         (let loop ((last-sent-state-id after-state-id))
+           (let ((new-state-id
+                  (with-exception-handler
+                      (lambda (exn)
+                        (simple-format
+                         (current-error-port)
+                         "exception listening for events: ~A\n" exn)
+                        (put-message submission-channel
+                                     (list 'remove-listener
+                                           listener-channel))
+
+                        (put-message listening-finished-channel #t)
+
+                        #f)
+                    (lambda ()
+                      (with-throw-handler #t
+                        (lambda ()
+                          (match (atomic-box-ref
+                                  current-state-id-and-event-buffer-index-box)
+                            ((current-state-id . event-buffer-index)
+                             (let ((event-count-to-send
+                                    (- current-state-id last-sent-state-id)))
+                               (for-each
+                                (lambda (index index-state-id)
+                                  (match (vector-ref event-buffer index)
+                                    ((event-state-id event-name data)
+
+                                     (when (not (= event-state-id index-state-id))
+                                       (error "listener behind"))
+
+                                     (callback event-state-id event-name data))))
+                                (map (lambda (i)
+                                       (modulo i buffer-size))
+                                     (iota event-count-to-send
+                                           (- event-buffer-index
+                                              (- event-count-to-send 1))))
+                                (iota event-count-to-send
+                                      (+ 1 last-sent-state-id))))
+
+                             current-state-id)))
+                        (lambda (key . args)
+                          (peek "ERROR" key args)
+                          (if (and
+                               (eq? key 'system-error)
+                               (match args
+                                 (("fport_write" "~A" ("Broken pipe") rest ...)
+                                  #t)
+                                 (_ #f)))
+                              #f
+                              (backtrace)))))
+                    #:unwind? #t)))
+
+             (unless (eq? #f new-state-id)
+               (get-message listener-channel)
+               (loop new-state-id)))))
+       #:parallel? #t))
+
+    (define (store-event id event-name data)
+      (match (atomic-box-ref
+              current-state-id-and-event-buffer-index-box)
+        ((current-state-id . event-buffer-index)
+         (let ((new-event-index
+                (modulo
+                 (+ 1 event-buffer-index)
+                 buffer-size)))
+
+           (atomic-box-set! current-state-id-and-event-buffer-index-box
+                            (cons id new-event-index))
+
+           (vector-set! event-buffer
+                        new-event-index
+                        (list id event-name data))))))
+
+    (spawn-fiber
+     (lambda ()
+       (let* ((response
+               remote-port
+               (http-get
+                (string->uri "http://localhost:8746/events")
+                #:headers
+                `((last-event-id
+                   . ,(number->string
+                       (- initial-state-id
+                          ;; Get some earlier events as well, as clients that
+                          ;; are reconnecting might want them
+                          100))))
+                #:streaming? #t)))
+         (setvbuf remote-port 'none)
+
+         (let loop ((line (get-line remote-port)))
+           (or (eof-object? line)
+               ;; TODO: It would be good to replace this with a more general way
+               ;; of processing the event stream that handles
+               (begin
+                 (when (string-prefix? "id: " line)
+                   (let ((id
+                          (string->number (string-drop line 4)))
+                         (event-name
+                          (string-drop
+                           (get-line remote-port)
+                           (string-length
+                            "event: ")))
+                         (data
+                          (json-string->scm
+                           (string-drop
+                            (get-line remote-port)
+                            (string-length "data: ")))))
+                     (put-message
+                      submission-channel
+                      (list id event-name data))))
+
+                 (loop (get-line remote-port)))))))
+     #:parallel? #t)
+
+    (spawn-fiber
+     (lambda ()
+       (while #t
+         (match (get-message submission-channel)
+           (('new-listener callback requested-after-state-id
+                           listening-finished-channel)
+
+            (let ((listener-channel (make-channel))
+                  (after-state-id
+                   (match (atomic-box-ref
+                           current-state-id-and-event-buffer-index-box)
+                     ((current-state-id . event-buffer-index)
+                      (if (and requested-after-state-id
+                               (<= requested-after-state-id
+                                   current-state-id)
+                               (match (vector-ref
+                                       event-buffer
+                                       (modulo
+                                        (+ event-buffer-index
+                                           (- requested-after-state-id
+                                              current-state-id))
+                                        buffer-size))
+                                 ((? unspecified? _) #f)
+                                 ((event-state-id event-name data)
+                                  (= event-state-id
+                                     requested-after-state-id))))
+                          requested-after-state-id
+                          current-state-id)))))
+              (atomic-box-set!
+               listener-channels-box
+               (vhash-consq listener-channel
+                            #t
+                            (atomic-box-ref listener-channels-box)))
+
+              (spawn-fiber-for-listener callback
+                                        after-state-id
+                                        submission-channel
+                                        listener-channel
+                                        listening-finished-channel)))
+
+           (('remove-listener listener-channel)
+            (atomic-box-set!
+             listener-channels-box
+             (vhash-delq listener-channel
+                         (atomic-box-ref listener-channels-box))))
+
+           ((id event-name data)
+            (store-event id event-name data)
+
+            (vhash-fold
+             (lambda (listener-channel val res)
+               (spawn-fiber
+                (lambda ()
+                  (put-message listener-channel #t))
+                #:parallel? #t)
+               #f)
+             #f
+             (atomic-box-ref listener-channels-box)))))))
+
+    (values submission-channel
+            get-state-id)))
+
+(define* (listen-for-events events-channel callback
+                            #:key after-state-id)
+  (let ((listening-finished-channel
+         (make-channel)))
+    (put-message
+     events-channel
+     (list 'new-listener
+           callback
+           after-state-id
+           listening-finished-channel))
+    ;; This is designed to be useful in the controller, so this procedure
+    ;; shouldn't exit until callback has finished being called
+    (get-message listening-finished-channel)))
+
+(define* (make-controller assets-directory metrics-registry
+                          events-channel state-channel
+                          title
+                          template-directory)
+
+  (define handle-static-assets
+    (if (string-prefix? (%store-prefix)
+                        assets-directory)
+        (static-asset-from-store-renderer assets-directory)
+        (static-asset-from-directory-renderer assets-directory)))
+
+  (define gc-metrics-updater!
+    (get-gc-metrics-updater metrics-registry))
+
+  (define home-template-content
+    (call-with-input-file
+        (string-append
+         template-directory "/home.html")
+      get-string-all))
+
+  (lambda (request
+           method-and-path-components
+           mime-types
+           body)
+
+    (define path
+      (uri-path (request-uri request)))
+
+    (match method-and-path-components
+      (('GET)
+       (render-html
+        #:sxml (home title home-template-content)))
+      (('GET "activity")
+       (render-html
+        #:sxml (activity title (get-state state-channel))))
+      (('GET "state")
+       (render-json
+        (get-state state-channel)))
+      (('GET "events")
+       (let ((headers (request-headers request))
+             (query-parameters
+              (let lp ((lst (map uri-decode
+                                 (string-split (uri-query
+                                                (request-uri request))
+                                               (char-set #\& #\=)))))
+               (match lst
+                 ((key value . rest)
+                  (cons (cons key value) (lp rest)))
+                 (("") '())
+                 (() '())))))
+
+         (list (build-response
+                #:code 200
+                #:headers '((content-type . (text/event-stream))))
+               (lambda (port)
+                 (listen-for-events
+                  events-channel
+                  (lambda (id event-name data)
+                    (display
+                     (simple-format #f "id: ~A\nevent: ~A\ndata: ~A\n\n"
+                                    id
+                                    event-name
+                                    (scm->json-string data))
+                     port)
+                    (force-output port)
+                    ;; TODO because the chunked output port doesn't call
+                    ;; force-output on the underlying port, do that here. We
+                    ;; want this event to be sent now, rather than when some
+                    ;; buffer fills up.
+                    (force-output (request-port request)))
+                  #:after-state-id
+                  (with-exception-handler
+                      (lambda (exn)
+                        (simple-format
+                         (current-error-port)
+                         "error: when processing Last-Event-ID header value: ~A\n"
+                         (assoc-ref headers 'last-event-id))
+                        #f)
+                    (lambda ()
+                      (or (and=> (assoc-ref headers 'last-event-id)
+                                 string->number)
+                          (and=> (assoc-ref query-parameters "last_event_id")
+                                 string->number)))
+                    #:unwind? #t))))))
+
+      (('GET "assets" rest ...)
+       (or (handle-static-assets (string-join rest "/")
+                                 (request-headers request))
+           (list (build-response #:code 404)
+                 (string-append
+                  "Resource not found: "
+                  (uri->string
+                   (request-uri request))))))
+      (('GET "metrics")
+       (gc-metrics-updater!)
+       (list (build-response
+              #:code 200
+              #:headers '((content-type . (text/plain))
+                          (vary . (accept))))
+             (lambda (port)
+               (write-metrics metrics-registry port))))
+      ((method path ...)
+       (render-html
+        #:sxml (general-not-found
+                "Page not found"
+                "")
+        #:code 404)))))
+
+(define (handler request body controller)
+  (display
+   (format #f "~a ~a\n"
+           (request-method request)
+           (uri-path (request-uri request))))
+
+  (call-with-error-handling
+   (lambda ()
+     (let-values (((request-components mime-types)
+                   (request->path-components-and-mime-type request)))
+       (controller request
+                   (cons (request-method request)
+                         request-components)
+                   mime-types
+                   body)))
+   #:on-error 'backtrace
+   #:post-error (lambda args
+                  (render-html #:sxml (error-page args)
+                               #:code 100))))
+
+(define* (start-bffe-web-server port host assets-directory
+                                metrics-registry
+                                #:key (controller-args '()))
+  (define state-channel
+    (make-state-channel))
+
+  (call-with-error-handling
+   (lambda ()
+     (let ((finished? (make-condition)))
+       (call-with-sigint
+        (lambda ()
+          (run-fibers
+           (lambda ()
+             (let* ((initial-state-id
+                     (assoc-ref
+                      (get-state state-channel)
+                      "state_id"))
+                    (events-channel
+                     get-state-id
+                     (make-events-channel
+                      initial-state-id))
+                    (controller
+                     (apply make-controller assets-directory
+                            metrics-registry
+                            events-channel state-channel
+                            controller-args)))
+
+               ;; Wait until the events channel catches up
+               (while (< (get-state-id) initial-state-id)
+                 (sleep 10))
+
+               (simple-format #t "Starting the server\n")
+               (run-server/patched (lambda (request body)
+                                     (apply values
+                                            (handler request body controller)))
+                                   #:host host
+                                   #:port port))
+
+             (wait finished?))))
+        finished?)))
+   #:on-error 'backtrace
+   #:post-error (lambda (key . args)
+                  (when (eq? key 'system-error)
+                    (match args
+                      (("bind" "~A" ("Address already in use") _)
+                       (simple-format
+                        (current-error-port)
+                        "\n
+error: bffe could not start, as it could not bind to port ~A
+
+Check if it's already running, or whether another process is using that
+port. Also, the port used can be changed by passing the --port option.\n"
+                        port)))))))
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)))