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

            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;
  --justify-normal: center;
  --line-height: 1.5;
}

table td,
table th,
table tr {
    text-align: center;
}

header, main {
    padding: 1rem;
}

main > 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;
}

.monospace {
    font-family: monospace;
    font-size: 16px;
}

@media (min-width: 700px) {
  .large-screen-float-right {
    float: right;
  }
}

.darkgreen-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: #006400;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

.green-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: #28a745;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

.orange-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: orange;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

.yellow-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: yellow;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

.purple-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: purple;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

.lightblue-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: lightblue;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

.red-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: red;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

.darkred-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: darkred;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

.pink-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: pink;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

.grey-dot {
  vertical-align: text-bottom;
  height: 23px;
  width: 23px;
  background-color: grey;
  border-radius: 50%;
  display: inline-block;
  text-align: center;
}

")
      ,@head)
     (body (header
            (h1
             (img (@ (style "height: 1.4em;")
                     (src "/assets/img/guix.svg")))
             (span
              (@ (style "position: relative; left: -0.3em;"))
              "Guix QA"
              ,@(if title
                    `(": " ,title)
                    '()))))
           ,@body))))

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