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