summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArun Isaac2022-12-24 23:38:55 +0000
committerArun Isaac2022-12-25 23:32:15 +0000
commit6858a6b3d1236bbffaf32376699c3e193ffad324 (patch)
treedf2aed6d8f31d2a46cc3303c9887f444cb3a9d0a
parentcfc072a57916c99d8304d6f478acd6860cb49d10 (diff)
downloadtissue-6858a6b3d1236bbffaf32376699c3e193ffad324.tar.gz
tissue-6858a6b3d1236bbffaf32376699c3e193ffad324.tar.lz
tissue-6858a6b3d1236bbffaf32376699c3e193ffad324.zip
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.
-rw-r--r--Makefile4
-rw-r--r--tissue/commit.scm20
-rw-r--r--tissue/document.scm4
-rw-r--r--tissue/file-document.scm26
-rw-r--r--tissue/issue.scm83
-rw-r--r--tissue/tissue.scm21
-rw-r--r--tissue/web/server.scm215
-rw-r--r--tissue/web/themes.scm41
-rw-r--r--tissue/web/themes/default.scm330
9 files changed, 421 insertions, 323 deletions
diff --git a/Makefile b/Makefile
index 2bc955c..3e8359b 100644
--- a/Makefile
+++ b/Makefile
@@ -30,7 +30,9 @@ libdir ?= $(exec_prefix)/lib
datarootdir ?= $(prefix)/share
top_level_module_dir = $(project)
-sources = $(wildcard $(top_level_module_dir)/*.scm) $(wildcard $(top_level_module_dir)/web/*.scm)
+sources = $(wildcard $(top_level_module_dir)/*.scm) \
+ $(wildcard $(top_level_module_dir)/web/*.scm) \
+ $(wildcard $(top_level_module_dir)/web/themes/*.scm)
objects = $(sources:.scm=.go)
scripts = $(wildcard bin/*)
tests = $(wildcard tests/*)
diff --git a/tissue/commit.scm b/tissue/commit.scm
index 3dfd45f..e08f5a6 100644
--- a/tissue/commit.scm
+++ b/tissue/commit.scm
@@ -90,26 +90,6 @@ search results."
(newline port)
(newline port))))
-(define-method (document->sxml (commit <commit>) mset)
- "Render COMMIT, a <commit> object, to SXML. MSET is the xapian MSet
-object representing a list of search results."
- `(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 mset)))
- (if snippet
- (list `(div (@ (class "search-result-snippet"))
- ,@snippet))
- (list)))))
-
(define (repository-commits repository)
"Return a list of <commit> objects representing commits in
REPOSITORY."
diff --git a/tissue/document.scm b/tissue/document.scm
index 65a68b6..38270a5 100644
--- a/tissue/document.scm
+++ b/tissue/document.scm
@@ -43,8 +43,7 @@
document-snippet-source-text
document-snippet
print
- document-sxml-snippet
- document->sxml))
+ document-sxml-snippet))
(define (slot-set object slot-name value)
"Set @var{slot-name} in @var{object} to @var{value}. This is a purely
@@ -138,7 +137,6 @@ mutate @var{object}."
(define-generic document-text)
(define-generic document-recency-date)
(define-generic print)
-(define-generic document->sxml)
(define-method (document-type (document <document>))
(string-trim-both (symbol->string (class-name (class-of document)))
diff --git a/tissue/file-document.scm b/tissue/file-document.scm
index 847fb42..7673964 100644
--- a/tissue/file-document.scm
+++ b/tissue/file-document.scm
@@ -116,32 +116,6 @@ MSet object representing a list of search results."
(newline port)
(newline port))))
-(define-method (document->sxml (document <file-document>) mset)
- "Render DOCUMENT to SXML. MSET is the xapian MSet object representing
-a list of search results."
- `(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 mset)))
- (if snippet
- (list `(div (@ (class "search-result-snippet"))
- ,@snippet))
- (list)))))
-
(define file-modification-table-for-current-repository
(memoize-thunk
(cut file-modification-table (current-git-repository))))
diff --git a/tissue/issue.scm b/tissue/issue.scm
index 869b0ed..e20b4d0 100644
--- a/tissue/issue.scm
+++ b/tissue/issue.scm
@@ -160,89 +160,6 @@
(newline)
(newline)))
-(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 (document->sxml (issue <issue>) mset)
- "Render ISSUE, an <issue> object, to SXML. MSET is the xapian MSet
-object representing a list of search results."
- `(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 mset)))
- (if snippet
- (list `(div (@ (class "search-result-snippet"))
- ,@snippet))
- (list)))))
-
(define (hashtable-prepend! hashtable key new-values)
"Prepend NEW-VALUES to the list of values KEY is associated to in
HASHTABLE. Deduplicate the resulting list if necessary. If KEY is not
diff --git a/tissue/tissue.scm b/tissue/tissue.scm
index e42420a..2e901d2 100644
--- a/tissue/tissue.scm
+++ b/tissue/tissue.scm
@@ -22,23 +22,26 @@
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (tissue git)
+ #:use-module (tissue web themes default)
#:export (tissue-configuration
tissue-configuration?
tissue-configuration-project
tissue-configuration-aliases
tissue-configuration-indexed-documents
tissue-configuration-web-css
+ tissue-configuration-web-search-renderer
tissue-configuration-web-files
gemtext-files-in-directory))
(define-record-type <tissue-configuration>
(make-tissue-configuration project aliases indexed-documents
- web-css web-files)
+ web-css web-search-renderer web-files)
tissue-configuration?
(project delayed-tissue-configuration-project)
(aliases delayed-tissue-configuration-aliases)
(indexed-documents delayed-tissue-configuration-indexed-documents)
(web-css delayed-tissue-configuration-web-css)
+ (web-search-renderer delayed-tissue-configuration-web-search-renderer)
(web-files delayed-tissue-configuration-web-files))
(define tissue-configuration-project
@@ -53,6 +56,9 @@
(define tissue-configuration-web-css
(compose force delayed-tissue-configuration-web-css))
+(define tissue-configuration-web-search-renderer
+ (compose force delayed-tissue-configuration-web-search-renderer))
+
(define tissue-configuration-web-files
(compose force delayed-tissue-configuration-web-files))
@@ -96,7 +102,10 @@ directory they are in."
#`(delay #,arg)))
#'(args :::)))))))))))))
-(define-lazy (tissue-configuration #:key project (aliases '()) (indexed-documents '()) web-css (web-files '()))
+(define-lazy (tissue-configuration #:key project (aliases '()) (indexed-documents '())
+ web-css
+ (web-search-renderer render-sxml)
+ (web-files '()))
"Construct a <tissue-configuration> object. All arguments are
evaluated lazily.
@@ -115,6 +124,12 @@ documents to index.
document root and must begin with a @code{\"/\"}. If it is @code{#f},
no stylesheet is used in the generated web pages.
+@var{web-search-renderer} is a function that accepts two arguments---a
+@code{<search-page>} object describing the search page and a
+@code{<tissue-configuration>} object describing the project. It must
+return the rendered SXML.
+
@var{web-files} is a list of @code{<file>} objects representing files to be
written to the web output."
- (make-tissue-configuration project aliases indexed-documents web-css web-files))
+ (make-tissue-configuration project aliases indexed-documents
+ web-css web-search-renderer web-files))
diff --git a/tissue/web/server.scm b/tissue/web/server.scm
index e9665ec..cca67ae 100644
--- a/tissue/web/server.scm
+++ b/tissue/web/server.scm
@@ -25,6 +25,7 @@
#:use-module (srfi srfi-171)
#:use-module (ice-9 filesystem)
#:use-module (ice-9 match)
+ #:use-module (oop goops)
#:use-module (htmlprag)
#:use-module (sxml simple)
#:use-module ((system repl server) #:select (make-unix-domain-server-socket))
@@ -38,11 +39,11 @@
(case symbol
((parse-query) 'xapian:parse-query)
(else symbol))))
- #:use-module (tissue document)
#:use-module (tissue git)
#:use-module (tissue search)
#:use-module (tissue tissue)
#:use-module (tissue utils)
+ #:use-module (tissue web themes)
#:export (log-request
mime-type-for-extension
try-paths
@@ -50,155 +51,6 @@
search-handler
start-web-server))
-(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* (make-search-page results query css
- #:key
- page-uri-path page-uri-parameters
- matches
- matched-open-issues matched-closed-issues
- matched-documents matched-commits
- current-search-type)
- "Return SXML for a page with search RESULTS produced for QUERY.
-
-CSS is a URI to a stylesheet. PAGE-URI-PATH is the path part of the
-URI to the page. PAGE-URI-PARAMETERS is an association list of
-parameters in the query string of the URI of the page.
-
-MATCHES is the number of matches. MATCHED-OPEN-ISSUES,
-MATCHED-CLOSED-ISSUES, MATCHED-DOCUMENTS and MATCHED-COMMITS are
-respectively the number of open issues, closed issues, documents and
-commits matching the current query. CURRENT-SEARCH-TYPE is the type of
-document search results are being showed for."
- `(html
- (head
- (title "Tissue search")
- (style ,%css)
- ,@(if css
- (list `(link (@ (href "/style.css")
- (rel "stylesheet")
- (type "text/css"))))
- (list)))
- (body
- (form (@ (action "/search") (method "GET"))
- (input (@ (type "text")
- (name "query")
- (value ,query)
- (placeholder "Enter search query")))
- (input (@ (type "hidden")
- (name "type")
- (value ,(symbol->string current-search-type))))
- (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."))
- ,(let ((search-result-statistic
- (lambda (search-type format-string matches)
- `(li (a (@ (href ,(string-append
- page-uri-path
- "?"
- (query-string
- (acons "type" (symbol->string search-type)
- (alist-delete "type" page-uri-parameters)))))
- ,@(if (eq? search-type current-search-type)
- '((class "current-search-type"))
- '()))
- ,(format #f format-string matches))))))
- `(ul (@ (class "search-results-statistics"))
- ,(search-result-statistic 'all "~a All" matches)
- ,(search-result-statistic 'open-issue "~a open issues" matched-open-issues)
- ,(search-result-statistic 'closed-issue "~a closed issues" matched-closed-issues)
- ,(search-result-statistic 'document "~a documents" matched-documents)
- ,(search-result-statistic 'commit "~a commits" matched-commits)))
- (ul (@ (class "search-results"))
- ,@results))))
-
(define (log-request request)
"Log @var{request} to standard output."
(format #t "~a ~a\n"
@@ -239,8 +91,7 @@ query. QUERY and FILTER are Xapian Query objects."
#:maximum-items (database-document-count db))))
(define (search-handler request body xapian-index project)
- (let* ((path (uri-path (request-uri request)))
- (parameters (query-parameters (uri-query (request-uri request))))
+ (let* ((parameters (query-parameters (uri-query (request-uri request))))
(search-query (or (assoc-ref parameters "query")
""))
(search-type (match (assoc-ref parameters "type")
@@ -255,41 +106,31 @@ query. QUERY and FILTER are Xapian Query objects."
(sxml->html
(call-with-database xapian-index
(lambda (db)
- (let* ((query (parse-query search-query))
- (mset (enquire-mset
- (let* ((query (new-Query (Query-OP-FILTER)
- query
- (or (assq-ref filter-alist search-type)
- (Query-MatchAll))))
- (enquire (enquire db query)))
- ;; Sort by recency date (slot
- ;; 0) when query is strictly
- ;; boolean.
- (when (boolean-query? query)
- (Enquire-set-sort-by-value enquire 0 #t))
- enquire)
- #:offset 0
- #:maximum-items (database-document-count db))))
- (make-search-page
- (reverse
- (mset-fold (lambda (item result)
- (cons (document->sxml
- (call-with-input-string (document-data (mset-item-document item))
- (compose scm->object read))
- mset)
- result))
- '()
- mset))
- search-query
- (tissue-configuration-web-css project)
- #:page-uri-path path
- #:page-uri-parameters parameters
- #:matches (matches db query (Query-MatchAll))
- #:matched-open-issues (matches db query (assq-ref filter-alist 'open-issue))
- #:matched-closed-issues (matches db query (assq-ref filter-alist 'closed-issue))
- #:matched-documents (matches db query (assq-ref filter-alist 'document))
- #:matched-commits (matches db query (assq-ref filter-alist 'commit))
- #:current-search-type search-type))))))))
+ ((tissue-configuration-web-search-renderer project)
+ (let ((query (parse-query search-query)))
+ (make <search-page>
+ #:uri (request-uri request)
+ #:query search-query
+ #:type search-type
+ #:mset (enquire-mset
+ (let* ((query (new-Query (Query-OP-FILTER)
+ query
+ (or (assq-ref filter-alist search-type)
+ (Query-MatchAll))))
+ (enquire (enquire db query)))
+ ;; Sort by recency date (slot 0) when
+ ;; query is strictly boolean.
+ (when (boolean-query? query)
+ (Enquire-set-sort-by-value enquire 0 #t))
+ enquire)
+ #:offset 0
+ #:maximum-items (database-document-count db))
+ #:matches (matches db query (Query-MatchAll))
+ #:matched-open-issues (matches db query (assq-ref filter-alist 'open-issue))
+ #:matched-closed-issues (matches db query (assq-ref filter-alist 'closed-issue))
+ #:matched-documents (matches db query (assq-ref filter-alist 'document))
+ #:matched-commits (matches db query (assq-ref filter-alist 'commit))))
+ project)))))))
(define (try-paths path)
"Return a list of candidate paths to look for @var{path}."
diff --git a/tissue/web/themes.scm b/tissue/web/themes.scm
new file mode 100644
index 0000000..f1a107c
--- /dev/null
+++ b/tissue/web/themes.scm
@@ -0,0 +1,41 @@
+;;; 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)
+ #:use-module (oop goops)
+ #:export (<search-page>
+ search-page-uri
+ search-page-query
+ search-page-type
+ search-page-mset
+ search-page-matches
+ search-page-matched-open-issues
+ search-page-matched-closed-issues
+ search-page-matched-documents
+ search-page-matched-commits))
+
+(define-class <search-page> ()
+ (uri #:getter search-page-uri #:init-keyword #:uri)
+ (query #:getter search-page-query #:init-keyword #:query)
+ (type #:getter search-page-type #:init-keyword #:type)
+ (mset #:getter search-page-mset #:init-keyword #:mset)
+ (matches #:getter search-page-matches #:init-keyword #:matches)
+ (matched-open-issues #:getter search-page-matched-open-issues #:init-keyword #:matched-open-issues)
+ (matched-closed-issues #:getter search-page-matched-closed-issues #:init-keyword #:matched-closed-issues)
+ (matched-documents #:getter search-page-matched-documents #:init-keyword #:matched-documents)
+ (matched-commits #:getter search-page-matched-commits #:init-keyword #:matched-commits))
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))