web: Implement themes for the search page.

We factor out all display related code to a theming module, and
support powerful user customization of the theme thanks to generic
functions.

* tissue/commit.scm (document->sxml): Move to (tissue web themes
default).
* tissue/document.scm (document->sxml): Move to (tissue web themes
default).
* tissue/file-document.scm (document->sxml): Move to (tissue web
themes default).
* tissue/issue.scm (sanitize-string, document->sxml): Move to (tissue
web themes default).
* tissue/tissue.scm: Import (tissue web themes default).
(<tissue-configuration>)[web-search-renderer]: New field.
(tissue-configuration-web-search-renderer): New function.
(tissue-configuration): Accept web-search-renderer argument.
* tissue/web/server.scm: Import (oop goops) and (tissue web
themes). Do not import (tissue document).
(%css, make-search-page, search-handler): Move to (tissue web themes
default).
* tissue/web/themes.scm, tissue/web/themes/default.scm: New files.
* Makefile (sources): Add $(top_level_module_dir)/web/themes/*.scm.

1 files changed, 330 insertions, 0 deletions

diff --git a/tissue/web/themes/default.scm b/tissue/web/themes/default.scm
new file mode 100644
index 0000000..2dc8872
--- /dev/null
+++ b/tissue/web/themes/default.scm
@@ -0,0 +1,330 @@
+;;; tissue --- Text based issue tracker
+;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of tissue.
+;;;
+;;; tissue is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; tissue 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
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with tissue.  If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (tissue web themes default)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (web uri)
+  #:use-module (xapian xapian)
+  #:use-module (tissue commit)
+  #:use-module (tissue document)
+  #:use-module (tissue file-document)
+  #:use-module (tissue issue)
+  #:use-module (tissue tissue)
+  #:use-module (tissue utils)
+  #:use-module (tissue web themes)
+  #:export (render-sxml
+            <search-page-head>
+            <search-page-header>
+            <search-page-form>
+            <search-page-result>
+            <search-page-footer>))
+
+(define-class <search-page-head> ())
+(define-class <search-page-header> ())
+(define-class <search-page-form> ())
+(define-class <search-page-result> ())
+(define-class <search-page-footer> ())
+
+(define %css
+  "
+body {
+    max-width: 1000px;
+    margin: 0 auto;
+}
+
+form { text-align: center; }
+.search-filter {
+    background-color: gray;
+    color: white;
+    padding: 0 0.2em;
+}
+
+.search-results-statistics {
+    list-style: none;
+    padding: 0;
+}
+.search-results-statistics li {
+    display: inline;
+    margin: 0.5em;
+}
+.search-results-statistics a { color: blue; }
+.current-search-type { font-weight: bold; }
+
+.search-results { padding: 0; }
+.search-result {
+    list-style-type: none;
+    padding: 0.5em;
+}
+.search-result a { text-decoration: none; }
+.document-type {
+    font-variant: small-caps;
+    font-weight: bold;
+}
+.search-result-metadata {
+    color: dimgray;
+    font-size: smaller;
+}
+.search-result-snippet { font-size: smaller; }
+
+.tags {
+    list-style-type: none;
+    padding: 0;
+    display: inline;
+}
+.tag { display: inline; }
+.tag a {
+    padding: 0 0.2em;
+    color: white;
+    background-color: blue;
+    margin: auto 0.25em;
+    font-size: smaller;
+}
+.tag-bug a { background-color: red; }
+.tag-feature a { background-color: green; }
+.tag-progress a, .tag-unassigned a {
+    background-color: orange;
+    color: black;
+}
+.tag-chore a {
+    background-color: khaki;
+    color: black;
+}")
+
+(define-method (render-sxml (page <search-page>) project)
+  "Return SXML for @var{page}, a @code{<search-page>} object and
+@var{project}, a @code{<tissue-configuration>} object."
+  `(html
+    ,(render-sxml (make <search-page-head>) page project)
+    (body
+     ,(render-sxml (make <search-page-header>) page project)
+     ,(render-sxml (make <search-page-form>) page project)
+     ,(render-sxml (make <search-page-result>) page project)
+     ,(render-sxml (make <search-page-footer>) page project))))
+
+(define-method (render-sxml (head <search-page-head>) (page <search-page>) project)
+  `(head
+    (title ,(string-append (tissue-configuration-project project)
+                           " issue tracker"))
+    (style ,%css)
+    ,@(let ((css (tissue-configuration-web-css project)))
+        (if css
+            (list `(link (@ (href ,css)
+                            (rel "stylesheet")
+                            (type "text/css"))))
+            (list)))))
+
+(define-method (render-sxml (header <search-page-header>) (page <search-page>) project)
+  `(div))
+
+(define-method (render-sxml (form <search-page-form>) (page <search-page>) project)
+  `(div
+    (form (@ (action "/search") (method "GET"))
+          (input (@ (type "text")
+                    (name "query")
+                    (value ,(search-page-query page))
+                    (placeholder "Enter search query")))
+          (input (@ (type "hidden")
+                    (name "type")
+                    (value ,(symbol->string (search-page-type page)))))
+          (input (@ (type "submit") (value "Search"))))
+    (details (@ (class "search-hint"))
+             (summary "Hint")
+             (p "Refine your search with filters "
+                ,@(append-map (lambda (filter)
+                                (list `(span (@ (class "search-filter"))
+                                             ,filter)
+                                      ", "))
+                              (list "type:issue"
+                                    "type:document"
+                                    "is:open"
+                                    "is:closed"
+                                    "title:git"
+                                    "creator:mani"
+                                    "lastupdater:vel"
+                                    "assigned:muthu"
+                                    "tag:feature-request"))
+                "etc. Optionally, combine search terms with boolean operators "
+                (span (@ (class "search-filter"))
+                      "AND")
+                " and "
+                (span (@ (class "search-filter"))
+                      "OR")
+                ". See " (a (@ (href "https://xapian.org/docs/queryparser.html"))
+                            "Xapian::QueryParser Syntax")
+                " for detailed documentation."))))
+
+(define-method (render-sxml (result <search-page-result>) (page <search-page>) project)
+  (define (search-result-statistic search-type format-string matches)
+    `(li (a (@ (href ,(string-append
+                       (uri-path (search-page-uri page))
+                       "?"
+                       (query-string
+                        (acons "type" (symbol->string search-type)
+                               (alist-delete "type"
+                                             (query-parameters
+                                              (uri-query (search-page-uri page))))))))
+               ,@(if (eq? search-type (search-page-type page))
+                     '((class "current-search-type"))
+                     '()))
+            ,(format #f format-string matches))))
+  
+  `(div
+    (ul (@ (class "search-results-statistics"))
+        ,(search-result-statistic 'all "~a All" (search-page-matches page))
+        ,(search-result-statistic 'open-issue "~a open issues" (search-page-matched-open-issues page))
+        ,(search-result-statistic 'closed-issue "~a closed issues" (search-page-matched-closed-issues page))
+        ,(search-result-statistic 'document "~a documents" (search-page-matched-documents page))
+        ,(search-result-statistic 'commit "~a commits" (search-page-matched-commits page)))
+    (ul (@ (class "search-results"))
+        ,@(reverse
+           (mset-fold (lambda (item result)
+                        (cons (render-sxml
+                               (call-with-input-string (document-data (mset-item-document item))
+                                 (compose scm->object read))
+                               page project)
+                              result))
+                      '()
+                      (search-page-mset page))))))
+
+(define-method (render-sxml (document <file-document>) (page <search-page>) project)
+  `(li (@ (class "search-result search-result-document"))
+       (a (@ (href ,(document-web-uri document))
+             (class "search-result-title"))
+          ,(document-title document))
+       (div (@ (class "search-result-metadata"))
+            (span (@ (class ,(string-append "document-type file-document-type")))
+                  "document")
+            ,(string-append
+              (format #f " created ~a by ~a"
+                      (human-date-string (file-document-created-date document))
+                      (file-document-creator document))
+              (if (> (length (file-document-commits document))
+                     1)
+                  (format #f ", last updated ~a by ~a"
+                          (human-date-string (file-document-last-updated-date document))
+                          (file-document-last-updater document))
+                  "")))
+       ,@(let ((snippet (document-sxml-snippet document (search-page-mset page))))
+           (if snippet
+               (list `(div (@ (class "search-result-snippet"))
+                           ,@snippet))
+               (list)))))
+
+(define (sanitize-string str)
+  "Downcase STR and replace spaces with hyphens."
+  (string-map (lambda (c)
+                (case c
+                  ((#\space) #\-)
+                  (else c)))
+              (string-downcase str)))
+
+(define-method (render-sxml (issue <issue>) (page <search-page>) project)
+  `(li (@ (class ,(string-append "search-result search-result-issue "
+                                 (if (issue-open? issue)
+                                     "search-result-open-issue"
+                                     "search-result-closed-issue"))))
+       (a (@ (href ,(document-web-uri issue))
+             (class "search-result-title"))
+          ,(document-title issue))
+       (ul (@ (class "tags"))
+           ,@(map (lambda (tag)
+                    (let ((words (string-split tag (char-set #\- #\space))))
+                      `(li (@ (class
+                                ,(string-append "tag"
+                                                (string-append " tag-" (sanitize-string tag))
+                                                (if (not (null? (lset-intersection
+                                                                 string=? words
+                                                                 (list "bug" "critical"))))
+                                                    " tag-bug"
+                                                    "")
+                                                (if (not (null? (lset-intersection
+                                                                 string=? words
+                                                                 (list "progress"))))
+                                                    " tag-progress"
+                                                    "")
+                                                (if (not (null? (lset-intersection
+                                                                 string=? words
+                                                                 (list "chore"))))
+                                                    " tag-chore"
+                                                    "")
+                                                (if (not (null? (lset-intersection
+                                                                 string=? words
+                                                                 (list "enhancement" "feature"))))
+                                                    " tag-feature"
+                                                    ""))))
+                           (a (@ (href ,(string-append
+                                         "/search?query="
+                                         (uri-encode
+                                          ;; Quote tag if it has spaces.
+                                          (string-append "tag:"
+                                                         (if (string-any #\space tag)
+                                                             (string-append "\"" tag "\"")
+                                                             tag))))))
+                              ,tag))))
+                  (issue-keywords issue)))
+       (div (@ (class "search-result-metadata"))
+            (span (@ (class ,(string-append "document-type issue-document-type "
+                                            (if (issue-open? issue)
+                                                "open-issue-document-type"
+                                                "closed-issue-document-type"))))
+                  ,(if (issue-open? issue)
+                       "issue"
+                       "✓ issue"))
+            ,(string-append
+              (format #f " opened ~a by ~a"
+                      (human-date-string (file-document-created-date issue))
+                      (file-document-creator issue))
+              (if (> (length (file-document-commits issue))
+                     1)
+                  (format #f ", last updated ~a by ~a"
+                          (human-date-string (file-document-last-updated-date issue))
+                          (file-document-last-updater issue))
+                  "")
+              (if (zero? (issue-tasks issue))
+                  ""
+                  (format #f "; ~a of ~a tasks done"
+                          (issue-completed-tasks issue)
+                          (issue-tasks issue)))))
+       ,@(let ((snippet (document-sxml-snippet issue (search-page-mset page))))
+           (if snippet
+               (list `(div (@ (class "search-result-snippet"))
+                           ,@snippet))
+               (list)))))
+
+(define-method (render-sxml (commit <commit>) (page <search-page>) project)
+  `(li (@ (class ,(string-append "search-result search-result-commit")))
+       (a (@ (href ,(document-web-uri commit))
+             (class "search-result-title"))
+          ,(document-title commit))
+       (div (@ (class "search-result-metadata"))
+            (span (@ (class ,(string-append "document-type commit-document-type")))
+                  "commit")
+            ,(string-append
+              (format #f " authored ~a by ~a"
+                      (human-date-string (doc:commit-author-date commit))
+                      (doc:commit-author commit))))
+       ,@(let ((snippet (document-sxml-snippet commit (search-page-mset page))))
+           (if snippet
+               (list `(div (@ (class "search-result-snippet"))
+                           ,@snippet))
+               (list)))))
+
+(define-method (render-sxml (footer <search-page-footer>) (page <search-page>) project)
+  `(div))