summaryrefslogtreecommitdiff
path: root/tissue/web/themes/default.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tissue/web/themes/default.scm')
-rw-r--r--tissue/web/themes/default.scm340
1 files changed, 340 insertions, 0 deletions
diff --git a/tissue/web/themes/default.scm b/tissue/web/themes/default.scm
new file mode 100644
index 0000000..10732ee
--- /dev/null
+++ b/tissue/web/themes/default.scm
@@ -0,0 +1,340 @@
+;;; tissue --- Text based issue tracker
+;;; Copyright © 2022, 2023 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 utils)
+ #:use-module (tissue web themes)
+ #:export (default-theme
+ <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* (default-theme #:key (title "tissue issue tracker") css)
+ "Return a generic function that renders a page using the default
+theme.
+
+@var{title} is the title to use in the head of the HTML. @var{css} is
+a URI to a CSS stylesheet to link to. If it is @code{#f}, no
+stylesheet is linked to."
+ (add-method! render-sxml
+ (make <method>
+ #:specializers (list <search-page-head> <search-page>)
+ #:procedure (make-head-renderer title css)))
+ render-sxml)
+
+(define-method (render-sxml (page <search-page>))
+ "Return SXML for @var{page}, a @code{<search-page>}."
+ `(html
+ ,(render-sxml (make <search-page-head>) page)
+ (body
+ ,(render-sxml (make <search-page-header>) page)
+ ,(render-sxml (make <search-page-form>) page)
+ ,(render-sxml (make <search-page-result>) page)
+ ,(render-sxml (make <search-page-footer>) page))))
+
+(define (make-head-renderer title css)
+ (lambda (_ page)
+ `(head
+ (title ,title)
+ (style ,%css)
+ ,@(if css
+ (list `(link (@ (href ,css)
+ (rel "stylesheet")
+ (type "text/css"))))
+ (list)))))
+
+(define-method (render-sxml (header <search-page-header>) (page <search-page>))
+ `(div))
+
+(define-method (render-sxml (form <search-page-form>) (page <search-page>))
+ `(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>))
+ (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)
+ result))
+ '()
+ (search-page-mset page))))))
+
+(define-method (render-sxml (document <file-document>) (page <search-page>))
+ `(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>))
+ `(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>))
+ `(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>))
+ `(div))
generated by cgit v1.2.3 (git 2.44.0) at 2024-05-05 08:46:32 +0000