From 6858a6b3d1236bbffaf32376699c3e193ffad324 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Sat, 24 Dec 2022 23:38:55 +0000 Subject: 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). ()[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. --- Makefile | 4 +- tissue/commit.scm | 20 --- tissue/document.scm | 4 +- tissue/file-document.scm | 26 ---- tissue/issue.scm | 83 ----------- tissue/tissue.scm | 21 ++- tissue/web/server.scm | 215 ++++----------------------- tissue/web/themes.scm | 41 ++++++ tissue/web/themes/default.scm | 330 ++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 421 insertions(+), 323 deletions(-) create mode 100644 tissue/web/themes.scm create mode 100644 tissue/web/themes/default.scm 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 ) mset) - "Render COMMIT, a 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 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 )) (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 ) 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 ) mset) - "Render ISSUE, an 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 (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 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{} object describing the search page and a +@code{} object describing the project. It must +return the rendered SXML. + @var{web-files} is a list of @code{} 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 + #: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 +;;; +;;; 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 . + +(define-module (tissue web themes) + #:use-module (oop goops) + #:export ( + 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 () + (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 +;;; +;;; 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 . + +(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 + + + + + )) + +(define-class ()) +(define-class ()) +(define-class ()) +(define-class ()) +(define-class ()) + +(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 ) project) + "Return SXML for @var{page}, a @code{} object and +@var{project}, a @code{} object." + `(html + ,(render-sxml (make ) page project) + (body + ,(render-sxml (make ) page project) + ,(render-sxml (make ) page project) + ,(render-sxml (make ) page project) + ,(render-sxml (make ) page project)))) + +(define-method (render-sxml (head ) (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 ) (page ) project) + `(div)) + +(define-method (render-sxml (form ) (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 ) (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 ) (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 ) (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 ) (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 ) (page ) project) + `(div)) -- cgit v1.2.3