summaryrefslogtreecommitdiff
path: root/tissue/web
diff options
context:
space:
mode:
Diffstat (limited to 'tissue/web')
-rw-r--r--tissue/web/dev.scm86
-rw-r--r--tissue/web/server.scm391
-rw-r--r--tissue/web/static.scm89
-rw-r--r--tissue/web/themes.scm42
-rw-r--r--tissue/web/themes/default.scm340
5 files changed, 641 insertions, 307 deletions
diff --git a/tissue/web/dev.scm b/tissue/web/dev.scm
new file mode 100644
index 0000000..5ca7d16
--- /dev/null
+++ b/tissue/web/dev.scm
@@ -0,0 +1,86 @@
+;;; 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 dev)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 filesystem)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web server)
+ #:use-module (web uri)
+ #:use-module (xapian xapian)
+ #:use-module (tissue tissue)
+ #:use-module (tissue utils)
+ #:use-module (tissue web server)
+ #:use-module (tissue web static)
+ #:export (start-dev-web-server))
+
+(define (handler request body xapian-index project-thunk)
+ "Handle web @var{request} with @var{body} and return two values---the
+response headers and body. See @code{start-dev-web-server} for
+documentation of @var{xapian-index} and @var{project-thunk}."
+ ;; The project configuration could have changed between requests and
+ ;; we want to read the latest configuration on each request. So, we
+ ;; require a thunk that loads the project configuration, rather than
+ ;; the project configuration itself.
+ (let ((project (project-thunk))
+ (path (uri-path (request-uri request))))
+ (log-request request)
+ (cond
+ ;; Files
+ ((any (lambda (web-file)
+ (cond
+ ((find (cut string=?
+ (string-append "/" (file-name web-file))
+ <>)
+ (try-paths path))
+ => (cut file <> (file-writer web-file)))
+ (else #f)))
+ (tissue-configuration-web-files project))
+ => (lambda (file)
+ (values `((content-type . ,(mime-type-for-extension
+ (file-name-extension (file-name file)))))
+ (call-with-values open-bytevector-output-port
+ (lambda (port get-bytevector)
+ ((file-writer file) port)
+ (get-bytevector))))))
+ ;; Search page. We look for the search page only after files
+ ;; because we want to let files shadow the search page if
+ ;; necessary.
+ ((member path (list "/" "/search"))
+ (search-handler request body xapian-index project))
+ ;; Not found
+ (else
+ (404-response request)))))
+
+(define (start-dev-web-server port xapian-index project-thunk)
+ "Start development web server listening on
+@var{port}. @var{xapian-index} is the path to the Xapian index to
+search in. @var{project} is a thunk that returns a
+@code{<tissue-configuration>} object describing the project."
+ (format (current-error-port)
+ "Tissue development web server listening at http://localhost:~a~%" port)
+ ;; Explicitly dereference the module and handler variable each time
+ ;; so as to support live hacking.
+ (run-server (cut (module-ref (resolve-module '(tissue web dev))
+ 'handler)
+ <> <> xapian-index project-thunk)
+ 'http
+ (list #:port port)))
diff --git a/tissue/web/server.scm b/tissue/web/server.scm
index fa26aa5..e8ee9eb 100644
--- a/tissue/web/server.scm
+++ b/tissue/web/server.scm
@@ -1,5 +1,5 @@
;;; tissue --- Text based issue tracker
-;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of tissue.
;;;
@@ -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,182 +39,24 @@
(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)
- #:export (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 (query-parameters query)
- "Return an association list of query parameters in web QUERY string."
- (if query
- (map (lambda (parameter)
- (match (string-split parameter #\=)
- ((key value)
- (cons (uri-decode key)
- (uri-decode value)))))
- (string-split query #\&))
- '()))
-
-(define (query-string parameters)
- "Return a query string for association list of PARAMETERS."
- (string-join
- (map (match-lambda
- ((key . value)
- (string-append (uri-encode key)
- "="
- (uri-encode value))))
- parameters)
- "&"))
+ #:use-module (tissue web themes)
+ #:export (log-request
+ mime-type-for-extension
+ try-paths
+ 404-response
+ search-handler
+ start-web-server))
+
+(define (log-request request)
+ "Log @var{request} to standard output."
+ (display (request-method request))
+ (display " ")
+ (display (uri->string (request-uri request)))
+ (newline))
(define %mime-types
'(("gif" image/gif)
@@ -227,6 +70,20 @@ operators "
("svg" image/svg+xml)
("txt" text/plain)))
+(define (mime-type-for-extension extension)
+ "Return the mime type for @var{extension}."
+ (or (assoc-ref %mime-types (if (string-null? extension)
+ extension
+ (string-remove-prefix "." extension)))
+ '(application/octet-stream)))
+
+(define (404-response request)
+ "Return a response and body for a 404 error corresponding to
+@var{request}."
+ (values (build-response #:code 404)
+ (string-append "Resource not found: "
+ (uri->string (request-uri request)))))
+
(define (matches db query filter)
"Return the number of matches in DB for QUERY filtering with FILTER
query. QUERY and FILTER are Xapian Query objects."
@@ -236,85 +93,78 @@ query. QUERY and FILTER are Xapian Query objects."
db (new-Query (Query-OP-FILTER) query filter))
#:maximum-items (database-document-count db))))
+(define (search-handler request body xapian-index project)
+ (let* ((parameters (query-parameters (uri-query (request-uri request))))
+ (search-query (or (assoc-ref parameters "query")
+ ""))
+ (search-type (match (assoc-ref parameters "type")
+ ((or "open-issue" "closed-issue" "commit" "document")
+ (string->symbol (assoc-ref parameters "type")))
+ (_ 'all)))
+ (filter-alist `((open-issue . ,(parse-query "type:issue AND is:open"))
+ (closed-issue . ,(parse-query "type:issue AND is:closed"))
+ (commit . ,(parse-query "type:commit"))
+ (document . ,(parse-query "type:document")))))
+ (values '((content-type . (text/html)))
+ (sxml->html
+ (call-with-database xapian-index
+ (lambda (db)
+ ((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 1000)
+ #: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)))))))))))
+
+(define (try-paths path)
+ "Return a list of candidate paths to look for @var{path}."
+ (if (string-suffix? "/" path)
+ ;; Try path/index.html.
+ (list (string-append path "index.html"))
+ ;; Try path and path.html.
+ (list path
+ (string-append path ".html"))))
+
(define (handler request body hosts)
"Handle web REQUEST with BODY and return two values---the response
headers and the body.
See `start-web-server' for documentation of HOSTS."
(let* ((path (uri-path (request-uri request)))
- (parameters (query-parameters (uri-query (request-uri request))))
(hostname (match (assq-ref (request-headers request) 'host)
((hostname . _) hostname)))
(host-parameters (or (assoc-ref hosts hostname)
(raise (condition
(make-message-condition "Unknown host")
- (make-irritants-condition hostname))))))
- (format #t "~a ~a\n"
- (request-method request)
- path)
+ (make-irritants-condition hostname)))))
+ (repository-directory (assq-ref host-parameters 'repository-directory)))
+ (log-request request)
(parameterize ((%current-git-repository
- (repository-open
- (assq-ref host-parameters 'repository-directory))))
+ (repository-open repository-directory)))
(cond
- ;; Search page
- ((member path (list "/" "/search"))
- (let* ((search-query (or (assoc-ref parameters "query")
- ""))
- (search-type (match (assoc-ref parameters "type")
- ((or "open-issue" "closed-issue" "commit" "document")
- (string->symbol (assoc-ref parameters "type")))
- (_ 'all)))
- (filter-alist `((open-issue . ,(parse-query "type:issue AND is:open"))
- (closed-issue . ,(parse-query "type:issue AND is:closed"))
- (commit . ,(parse-query "type:commit"))
- (document . ,(parse-query "type:document")))))
- (values '((content-type . (text/html)))
- (sxml->html
- (call-with-database (assq-ref host-parameters 'xapian-directory)
- (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
- (assq-ref host-parameters 'css)
- #: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))))))))
;; Static files
((let ((file-path
(find file-exists?
- ;; Try path and path.html.
- (list (string-append (assq-ref host-parameters 'website-directory)
- "/" path)
- (string-append (assq-ref host-parameters 'website-directory)
- "/" path ".html")))))
+ (map (cut string-append (assq-ref host-parameters 'website-directory) <>)
+ (try-paths path)))))
(and file-path
;; Check that the file really is within the document
;; root.
@@ -322,16 +172,20 @@ See `start-web-server' for documentation of HOSTS."
(canonicalize-path file-path))
(canonicalize-path file-path)))
=> (lambda (file-path)
- (values `((content-type . ,(or (assoc-ref %mime-types (string-remove-prefix
- "." (file-name-extension file-path)))
- '(application/octet-stream))))
+ (values `((content-type . ,(mime-type-for-extension
+ (file-name-extension file-path))))
(call-with-input-file file-path
get-bytevector-all))))
+ ;; Search page. We look for the search page only after files
+ ;; because we want to let files shadow the search page if
+ ;; necessary.
+ ((member path (list "/" "/search"))
+ (search-handler request body
+ (assq-ref host-parameters 'xapian-directory)
+ (assq-ref host-parameters 'project)))
;; Not found
(else
- (values (build-response #:code 404)
- (string-append "Resource not found: "
- (uri->string (request-uri request)))))))))
+ (404-response request))))))
(define (start-web-server socket-address hosts)
"Start web server listening on SOCKET-ADDRESS.
@@ -356,24 +210,33 @@ list containing parameters for that host."
;; Unix socket
((= (sockaddr:fam socket-address) AF_UNIX)
(sockaddr:path socket-address))))
- (run-server (lambda (request body)
- ;; Explicitly dereference the module and handler
- ;; variable each time so as to support live hacking.
- ((module-ref (resolve-module '(tissue web server))
- 'handler)
- request body hosts))
- 'http
- (cond
- ;; IPv4 or IPv6 address
- ((or (= (sockaddr:fam socket-address) AF_INET)
- (= (sockaddr:fam socket-address) AF_INET6))
- (list #:family (sockaddr:fam socket-address)
- #:addr (sockaddr:addr socket-address)
- #:port (sockaddr:port socket-address)))
- ;; Unix socket
- ((= (sockaddr:fam socket-address) AF_UNIX)
- (let ((socket (make-unix-domain-server-socket
- #:path (sockaddr:path socket-address))))
- ;; Grant read-write permissions to all users.
- (chmod (sockaddr:path socket-address) #o666)
- (list #:socket socket))))))
+ (let ((unix-socket #f))
+ (dynamic-wind
+ (lambda ()
+ (when (= (sockaddr:fam socket-address) AF_UNIX)
+ (set! socket (make-unix-domain-server-socket
+ #:path (sockaddr:path socket-address)))
+ ;; Grant read-write permissions to all users.
+ (chmod (sockaddr:path socket-address) #o666)))
+ (cut run-server
+ (lambda (request body)
+ ;; Explicitly dereference the module and handler
+ ;; variable each time so as to support live hacking.
+ ((module-ref (resolve-module '(tissue web server))
+ 'handler)
+ request body hosts))
+ 'http
+ (cond
+ ;; IPv4 or IPv6 address
+ ((or (= (sockaddr:fam socket-address) AF_INET)
+ (= (sockaddr:fam socket-address) AF_INET6))
+ (list #:family (sockaddr:fam socket-address)
+ #:addr (sockaddr:addr socket-address)
+ #:port (sockaddr:port socket-address)))
+ ;; Unix socket
+ ((= (sockaddr:fam socket-address) AF_UNIX)
+ (list #:socket socket))))
+ (lambda ()
+ ;; Clean up socket file if Unix socket.
+ (when (= (sockaddr:fam socket-address) AF_UNIX)
+ (delete-file (sockaddr:path socket-address)))))))
diff --git a/tissue/web/static.scm b/tissue/web/static.scm
index 69a9d90..2b910cb 100644
--- a/tissue/web/static.scm
+++ b/tissue/web/static.scm
@@ -1,5 +1,5 @@
;;; tissue --- Text based issue tracker
-;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of tissue.
;;;
@@ -30,24 +30,22 @@
#:use-module (skribilo evaluator)
#:use-module (skribilo reader)
#:use-module (web uri)
+ #:use-module (git)
#:use-module (tissue git)
#:use-module (tissue issue)
#:use-module (tissue utils)
- #:export (%project-name
- file
+ #:export (file
file?
file-name
file-writer
replace-extension
copier
+ html-engine
gemtext-reader
gemtext-exporter
skribe-exporter
build-website))
-(define %project-name
- (make-parameter #f))
-
(define-record-type <file>
(file name writer)
file?
@@ -61,15 +59,15 @@ NEW-EXTENSION."
new-extension))
(define (exporter file proc)
- "Return a writer function that exports FILE using PROC. PROC is
-passed two arguments---the input port to read from and the output port
-to write to."
+ "Return a writer function that exports @var{file} using
+@var{proc}. @var{proc} is passed two arguments---the input port to
+read from and the output port to write to."
(lambda (out)
- (call-with-file-in-git (current-git-repository) file
+ (call-with-input-file file
(cut proc <> out))))
(define (copier file)
- "Return a writer function that copies FILE."
+ "Return a writer function that copies @var{file}."
(exporter file
(lambda (in out)
(port-transduce (tmap (cut put-bytevector out <>))
@@ -77,56 +75,63 @@ to write to."
get-bytevector-some
in))))
+(define (engine-custom-set engine key value)
+ "Set custom @var{key} of @var{engine} to @var{value}. This is a purely
+functional setter that operates on a copy of @var{engine}. It does not
+mutate @var{engine}."
+ (let ((clone (copy-engine (engine-ident engine) engine)))
+ (engine-custom-set! clone key value)
+ clone))
+
+(define* (html-engine #:key css)
+ "Return a new HTML engine.
+
+@var{css} is the URI to a CSS stylesheet. If it is @code{#f}, no
+stylesheet is included in the generated web pages."
+ (if css
+ (engine-custom-set (find-engine 'html)
+ 'css
+ (list css))
+ (find-engine 'html)))
+
(define (gemtext-reader)
"Return a skribilo reader for gemtext."
((reader:make (lookup-reader 'gemtext))
;; Relax the gemtext standard by joining adjacent lines.
#:join-lines? #t))
-(define* (gemtext-exporter file #:optional (reader (gemtext-reader)))
- "Return a writer function that exports FILE, a gemtext file."
- (exporter file
- (lambda (in out)
- (with-output-to-port out
- (cut evaluate-document
- (evaluate-ast-from-port in #:reader reader)
- (find-engine 'html))))))
+(define* (gemtext-exporter file #:key (reader (gemtext-reader))
+ (engine (html-engine)))
+ "Return a writer function that reads gemtext @var{file} using
+@var{reader} and exports it using @var{engine}."
+ (skribe-exporter file
+ #:reader reader
+ #:engine engine))
-(define* (skribe-exporter file #:optional (reader (make-reader 'skribe)))
- "Return a writer function that exports FILE, a skribe file."
+(define* (skribe-exporter file #:key (reader (make-reader 'skribe))
+ (engine (html-engine)))
+ "Return a writer function that reads skribe @var{file} using
+@var{reader} and exports it using @var{engine}."
(exporter file
(lambda (in out)
(with-output-to-port out
(cut evaluate-document
(evaluate-ast-from-port in #:reader reader)
- (find-engine 'html))))))
+ engine)))))
-(define (with-current-directory directory thunk)
- "Change current directory to DIRECTORY, execute THUNK and restore
-original current directory."
- (let ((previous-current-directory (getcwd)))
- (dynamic-wind (const #t)
- thunk
- (cut chdir previous-current-directory))))
-
-(define* (build-website repository-top-level output-directory css files
+(define* (build-website output-directory files
#:key (log-port (current-error-port)))
- "Export git repository with REPOSITORY-TOP-LEVEL to OUTPUT-DIRECTORY
-as a website.
-
-CSS is the path to a CSS stylesheet. If it is #f, no stylesheet is
-included in the generated web pages.
+ "Export git repository to OUTPUT-DIRECTORY as a website. The current
+directory must be the top level of the repository being exported.
FILES is a list of <file> objects representing files to be written to
the web output.
Log to LOG-PORT. When LOG-PORT is #f, do not log."
- ;; Set CSS.
- (when css
- (engine-custom-set! (find-engine 'html) 'css css))
;; Create output directory.
(make-directories output-directory)
- ;; Write each of the <file> objects.
+ ;; Move into a temporary clone of the git repository, and write each
+ ;; of the <file> objects.
(for-each (lambda (file)
(let ((output-file
(string-append output-directory "/" (file-name file))))
@@ -135,7 +140,5 @@ Log to LOG-PORT. When LOG-PORT is #f, do not log."
(newline log-port))
(make-directories (dirname output-file))
(call-with-output-file output-file
- (lambda (port)
- (with-current-directory repository-top-level
- (cut (file-writer file) port))))))
+ (cut (file-writer file) <>))))
files))
diff --git a/tissue/web/themes.scm b/tissue/web/themes.scm
new file mode 100644
index 0000000..648d4d5
--- /dev/null
+++ b/tissue/web/themes.scm
@@ -0,0 +1,42 @@
+;;; 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)
+ #:use-module (srfi srfi-26)
+ #: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..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))