summaryrefslogtreecommitdiff
path: root/tissue/web/server.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tissue/web/server.scm')
-rw-r--r--tissue/web/server.scm215
1 files changed, 28 insertions, 187 deletions
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}."
generated by cgit v1.2.3 (git 2.44.0) at 2024-05-15 15:01:17 +0000