diff options
Diffstat (limited to 'tissue')
| -rw-r--r-- | tissue/commit.scm | 42 | ||||
| -rw-r--r-- | tissue/document.scm | 37 | ||||
| -rw-r--r-- | tissue/file-document.scm | 63 | ||||
| -rw-r--r-- | tissue/git.scm | 98 | ||||
| -rw-r--r-- | tissue/issue.scm | 127 | ||||
| -rw-r--r-- | tissue/search.scm | 41 | ||||
| -rw-r--r-- | tissue/skribilo.scm | 104 | ||||
| -rw-r--r-- | tissue/tissue.scm | 106 | ||||
| -rw-r--r-- | tissue/utils.scm | 28 | ||||
| -rw-r--r-- | tissue/web/dev.scm | 86 | ||||
| -rw-r--r-- | tissue/web/server.scm | 391 | ||||
| -rw-r--r-- | tissue/web/static.scm | 89 | ||||
| -rw-r--r-- | tissue/web/themes.scm | 42 | ||||
| -rw-r--r-- | tissue/web/themes/default.scm | 340 |
14 files changed, 981 insertions, 613 deletions
diff --git a/tissue/commit.scm b/tissue/commit.scm index 3dfd45f..b910695 100644 --- a/tissue/commit.scm +++ b/tissue/commit.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. ;;; @@ -39,7 +39,7 @@ (author-date #:getter doc:commit-author-date #:init-keyword #:author-date)) (define-method (document-id-term (commit <commit>)) - "Return the ID term for DOCUMENT." + "Return the ID term for COMMIT." (string-append "Qcommit." (commit-hash commit))) (define-method (document-boolean-terms (commit <commit>)) @@ -48,16 +48,9 @@ (string-append "A" (doc:commit-author commit)))) (define-method (document-recency-date (commit <commit>)) - "Return a date representing the recency of DOCUMENT" + "Return a date representing the recency of COMMIT." (doc:commit-author-date commit)) -(define-method (document-snippet-source-text (commit <commit>)) - "Return the source text for COMMIT from which to extract a search -result snippet." - (commit-body - (commit-lookup (current-git-repository) - (string->oid (commit-hash commit))))) - (define-method (document-text (commit <commit>)) "Return the full text of COMMIT." (commit-message @@ -90,26 +83,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." @@ -119,7 +92,14 @@ REPOSITORY." #:hash (oid->string (commit-id commit)) #:author (resolve-alias (signature-name (commit-author commit)) (%aliases)) - #:author-date (commit-author-date commit)) + #:author-date (commit-author-date commit) + ;; The snippet source text excludes the + ;; first paragraph (i.e., the summary line) + ;; of the commit. Hence, we use commit-body. + #:snippet-source-text + (commit-body + (commit-lookup (current-git-repository) + (commit-id commit)))) result)) (list) repository)) diff --git a/tissue/document.scm b/tissue/document.scm index 48d82cc..1e55e67 100644 --- a/tissue/document.scm +++ b/tissue/document.scm @@ -43,12 +43,12 @@ document-snippet-source-text document-snippet print - document-sxml-snippet - document->sxml)) + document-sxml-snippet)) (define (slot-set object slot-name value) - "Set SLOT-NAME in OBJECT to VALUE. This is a purely functional setter -that operates on a copy of OBJECT. It does not mutate OBJECT." + "Set @var{slot-name} in @var{object} to @var{value}. This is a purely +functional setter that operates on a copy of @var{object}. It does not +mutate @var{object}." (let ((clone (shallow-clone object))) (slot-set! clone slot-name value) clone)) @@ -87,7 +87,8 @@ that operates on a copy of OBJECT. It does not mutate OBJECT." (define (object->scm object) "Convert GOOPS OBJECT to a serializable object." (cond - ((or (string? object) + ((or (symbol? object) + (string? object) (number? object) (boolean? object)) object) @@ -107,7 +108,8 @@ that operates on a copy of OBJECT. It does not mutate OBJECT." (define (scm->object scm) "Convert serializable object SCM to a GOOPS object." (cond - ((or (string? scm) + ((or (symbol? scm) + (string? scm) (number? scm) (boolean? scm)) scm) @@ -131,13 +133,14 @@ that operates on a copy of OBJECT. It does not mutate OBJECT." (define-class <document> () (title #:accessor document-title #:init-keyword #:title) - (web-uri #:accessor document-web-uri #:init-keyword #:web-uri)) + (web-uri #:accessor document-web-uri #:init-keyword #:web-uri) + (snippet-source-text #:accessor document-snippet-source-text + #:init-keyword #:snippet-source-text)) (define-generic document-id-term) (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))) @@ -172,21 +175,17 @@ and further text, increase-termpos! must be called before indexing." (index-text! term-generator (document-text document)) term-generator)) -(define-method (document-snippet-source-text (document <document>)) - "Return the source text for DOCUMENT from which to extract a search -result snippet." - ;; Remove blank lines from document text. - (string-join - (remove string-blank? - (string-split (document-text document) - #\newline)) - "\n")) - (define (document-html-snippet document mset) "Return snippet for DOCUMENT. MSET is the xapian MSet object representing a list of search results." (mset-snippet mset - (document-snippet-source-text document) + ;; Remove blank lines from text. + (string-join + (remove string-blank? + (string-split + (document-snippet-source-text document) + #\newline)) + "\n") #:length 200 #:highlight-start "<b>" #:highlight-end "</b>" diff --git a/tissue/file-document.scm b/tissue/file-document.scm index b910131..f389976 100644 --- a/tissue/file-document.scm +++ b/tissue/file-document.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. ;;; @@ -38,6 +38,7 @@ file-document-created-date file-document-last-updater file-document-last-updated-date + commits-affecting-file read-gemtext-document)) (define-class <file-document> (<document>) @@ -58,7 +59,7 @@ (compose doc:commit-author-date last file-document-commits)) (define-method (document-type (document <file-document>)) - (next-method)) + "document") (define-method (document-id-term (document <file-document>)) "Return the ID term for DOCUMENT." @@ -68,10 +69,14 @@ "Return a date representing the recency of DOCUMENT." (file-document-last-updated-date document)) +(define (file-text file) + "Return the contents of text @var{file}." + (call-with-input-file file + get-string-all)) + (define-method (document-text (document <file-document>)) "Return the full text of DOCUMENT." - (call-with-file-in-git (current-git-repository) (file-document-path document) - get-string-all)) + (file-text (file-document-path document))) (define-method (document-term-generator (document <file-document>)) "Return a term generator indexing DOCUMENT." @@ -116,40 +121,25 @@ 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)))) +(define (commits-affecting-file file) + "Return a list of commits affecting @var{file} in current repository." + (map (lambda (commit) + (make <commit> + #:author (resolve-alias (signature-name (commit-author commit)) + (%aliases)) + #:author-date (commit-author-date commit))) + (hashtable-ref (file-modification-table-for-current-repository) + file #f))) + (define (read-gemtext-document file) - "Read gemtext document from FILE. Return a <file-document> object." + "Read gemtext document from @var{file} and return a +@code{<file-document>} object." (make <file-document> - #:title (or (call-with-file-in-git (current-git-repository) file + #:title (or (call-with-input-file file (lambda (port) (port-transduce (tfilter-map (lambda (line) ;; The first level one @@ -162,10 +152,5 @@ a list of search results." ;; Fallback to filename if document has no title. file) #:path file - #:commits (map (lambda (commit) - (make <commit> - #:author (resolve-alias (signature-name (commit-author commit)) - (%aliases)) - #:author-date (commit-author-date commit))) - (hashtable-ref (file-modification-table-for-current-repository) - file #f)))) + #:commits (commits-affecting-file file) + #:snippet-source-text (file-text file))) diff --git a/tissue/git.scm b/tissue/git.scm index 764fba2..70f0de9 100644 --- a/tissue/git.scm +++ b/tissue/git.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. ;;; @@ -45,9 +45,9 @@ commit-author-date git-tracked-file? git-tracked-files - call-with-file-in-git file-modification-table - clone-options)) + clone-options + call-with-temporary-checkout)) ;; We bind additional functions from libgit2 that are not already ;; bound in guile-git. TODO: Contribute them to guile-git. @@ -93,7 +93,11 @@ directory." (define (git-top-level) "Return the top-level directory of the current git repository." - (dirname (repository-directory (current-git-repository)))) + (let ((repository-directory + (repository-directory (current-git-repository)))) + (if (repository-bare? (current-git-repository)) + repository-directory + (dirname repository-directory)))) (define (head-tree repository) "Return tree of HEAD in REPOSITORY." @@ -122,35 +126,15 @@ directory." path))) (define* (git-tracked-files #:optional (repository (current-git-repository))) - "Return a list of all files and directories tracked in REPOSITORY. The -returned paths are relative to the top-level directory of REPOSITORY -and do not have a leading slash." + "Return a list of all files and directories tracked in +@var{repository}. The returned paths are relative to the top-level +directory of @var{repository} and do not have a leading slash." (tree-list (head-tree repository))) -(define (call-with-file-in-git repository path proc) - "Call PROC on an input port reading contents of PATH. PATH may refer -to a file on the filesystem or in REPOSITORY." - (let ((file-path (if (absolute-file-name? path) - ;; Treat absolute paths verbatim. - path - ;; Treat relative paths as relative to the - ;; top-level of the git repository. - (string-append (dirname (repository-directory repository)) - "/" path)))) - (if (file-exists? file-path) - ;; If file exists on the filesystem, read it. - (call-with-input-file file-path proc) - ;; Else, read the file from the repository. - (let* ((path-tree-entry (tree-entry-bypath (head-tree repository) - path)) - (path-object (tree-entry->object repository path-tree-entry)) - (blob (blob-lookup repository (object-id path-object)))) - (call-with-port (open-bytevector-input-port (blob-content blob)) - proc))))) - -(define (commit-deltas repository commit) - "Return the list of <diff-delta> objects created by COMMIT with -respect to its first parent in REPOSITORY." +(define (commit-file-changes repository commit) + "Return a list of pairs describing files modified by COMMIT with +respect to its first parent in REPOSITORY. Each pair maps the old +filename before COMMIT to the new filename after COMMIT." (match (commit-parents commit) ((parent _ ...) (let ((diff (diff-tree-to-tree repository @@ -158,7 +142,9 @@ respect to its first parent in REPOSITORY." (commit-tree commit)))) (diff-find-similar! diff) (diff-fold (lambda (delta progress result) - (cons delta result)) + (cons (cons (diff-file-path (diff-delta-old-file delta)) + (diff-file-path (diff-delta-new-file delta))) + result)) (lambda (delta binary result) result) (lambda (delta hunk result) @@ -167,7 +153,9 @@ respect to its first parent in REPOSITORY." result) (list) diff))) - (() (list)))) + (() (map (lambda (file) + (cons file file)) + (tree-list (commit-tree commit)))))) (define (file-modification-table repository) "Return a hashtable mapping files to the list of commits in REPOSITORY @@ -176,25 +164,21 @@ that modified them." (renames (make-hashtable string-hash string=?))) (fold-commits (lambda (commit _) - (map (lambda (delta) - ;; Map old filename to current filename if they are - ;; different. Note that this manner of following renames - ;; requires a linear git history and will not work with - ;; branch merges. - (unless (string=? (diff-file-path (diff-delta-old-file delta)) - (diff-file-path (diff-delta-new-file delta))) - (hashtable-set! renames - (diff-file-path (diff-delta-old-file delta)) - (diff-file-path (diff-delta-new-file delta)))) - (hashtable-update! result - ;; If necessary, translate old - ;; filename to current filename. - (hashtable-ref renames - (diff-file-path (diff-delta-old-file delta)) - (diff-file-path (diff-delta-old-file delta))) - (cut cons commit <>) - (list))) - (commit-deltas repository commit))) + (map (match-lambda + ((old-file . new-file) + ;; Map old filename to current filename if they are + ;; different. Note that this manner of following renames + ;; requires a linear git history and will not work with + ;; branch merges. + (unless (string=? old-file new-file) + (hashtable-set! renames old-file new-file)) + (hashtable-update! result + ;; If necessary, translate old + ;; filename to current filename. + (hashtable-ref renames old-file old-file) + (cut cons commit <>) + (list)))) + (commit-file-changes repository commit))) #f repository) result)) @@ -206,3 +190,13 @@ that modified them." 'bare (if bare? 1 0)) clone-options)) + +(define (call-with-temporary-checkout repository proc) + "Call PROC with a temporary checkout of REPOSITORY, and delete the +checkout when PROC returns or exits non-locally." + (call-with-temporary-directory + (lambda (temporary-checkout) + (clone repository temporary-checkout) + (proc temporary-checkout)) + ;; The system-dependent temporary directory + (dirname (tmpnam)))) diff --git a/tissue/issue.scm b/tissue/issue.scm index 469b033..14bd75f 100644 --- a/tissue/issue.scm +++ b/tissue/issue.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> ;;; Copyright © 2022 Frederick Muriuki Muriithi <fredmanglis@gmail.com> ;;; ;;; This file is part of tissue. @@ -27,7 +27,6 @@ #:use-module (ice-9 regex) #:use-module (oop goops) #:use-module (term ansi-color) - #:use-module (git) #:use-module (web uri) #:use-module (xapian xapian) #:use-module (tissue document) @@ -48,8 +47,7 @@ print-issue print-issue-to-gemtext issues - read-gemtext-issue - index-issue)) + read-gemtext-issue)) (define-class <issue> (<file-document>) (assigned #:accessor issue-assigned #:init-keyword #:assigned) @@ -58,18 +56,26 @@ (tasks #:accessor issue-tasks #:init-keyword #:tasks) (completed-tasks #:accessor issue-completed-tasks #:init-keyword #:completed-tasks)) +(define-method (document-type (issue <issue>)) + "issue") + (define-method (document-boolean-terms (issue <issue>)) "Return the boolean terms in ISSUE." - (append (list (string-append "A" (file-document-creator issue)) - (string-append "XA" (file-document-last-updater issue)) - (string-append "XS" (if (issue-open? issue) + (append (list (string-append "XS" (if (issue-open? issue) "open" "closed"))) - (map (cut string-append "XI" <>) - (issue-assigned issue)) (map (cut string-append "K" <>) (issue-keywords issue)) (next-method))) +(define-method (document-term-generator (issue <issue>)) + "Return a term generator indexing ISSUE." + (let ((term-generator (next-method))) + (index-text! term-generator (file-document-creator issue) #:prefix "A") + (index-text! term-generator (file-document-last-updater issue) #:prefix "XA") + (for-each (cut index-text! term-generator <> #:prefix "XI") + (issue-assigned issue)) + term-generator)) + (define-method (print (issue <issue>) mset port) "Print ISSUE, an <issue> object, in search results." (let ((number-of-posts (length (file-document-commits issue)))) @@ -160,89 +166,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 @@ -291,17 +214,23 @@ return #f." (define (file-details port) "Return a hashtable of details extracted from input PORT reading a gemtext file." - (let ((result (make-eq-hashtable))) + (let ((result (make-eq-hashtable)) + (in-preformatted #f)) (port-transduce (tmap (lambda (line) (cond + ;; Toggle preformatted state. + ((string=? "```" line) + (set! in-preformatted (not in-preformatted))) + ;; Ignore preformatted blocks. + (in-preformatted #t) ;; Checkbox lists are tasks. If the ;; checkbox has any character other ;; than space in it, the task is ;; completed. - ((string-match "^\\* \\[(.)\\]" line) + ((string-match "^\\* \\[(.*)\\]" line) => (lambda (m) (hashtable-update! result 'tasks 1+ 0) - (unless (string=? (match:substring m 1) " ") + (unless (string-blank? (match:substring m 1)) (hashtable-update! result 'completed-tasks 1+ 0)))) ((list-line->alist line) => (lambda (alist) @@ -350,9 +279,10 @@ gemtext file." result)) (define (read-gemtext-issue file) - "Read issue from gemtext FILE. Return an <issue> object." + "Read issue from gemtext @var{file} and return an @code{<issue>} +object." (let* ((file-document (read-gemtext-document file)) - (file-details (call-with-file-in-git (current-git-repository) file + (file-details (call-with-input-file file file-details)) ;; Downcase keywords to make them ;; case-insensitive. @@ -370,4 +300,5 @@ gemtext file." #:open? (not (member "closed" all-keywords)) #:tasks (hashtable-ref file-details 'tasks 0) #:completed-tasks (hashtable-ref file-details 'completed-tasks 0) - #:commits (file-document-commits file-document)))) + #:commits (file-document-commits file-document) + #:snippet-source-text (document-snippet-source-text file-document)))) diff --git a/tissue/search.scm b/tissue/search.scm index bc60c19..b9feafc 100644 --- a/tissue/search.scm +++ b/tissue/search.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. ;;; @@ -49,13 +49,13 @@ mapping field names to prefixes." query-parser)) (define %prefixes - '(("title" . "S"))) + '(("title" . "S") + ("creator" . "A") + ("lastupdater" . "XA") + ("assigned" . "XI"))) (define %boolean-prefixes '(("type" . "XT") - ("creator" . "A") - ("lastupdater" . "XA") - ("assigned" . "XI") ("keyword" . "K") ("tag" . "K") ("is" . "XS"))) @@ -97,7 +97,7 @@ when PRED returns #f." query)) (define* (search-fold proc initial db search-query - #:key (offset 0) (maximum-items (database-document-count db))) + #:key (offset 0) (maximum-items 1000)) "Search xapian database DB using SEARCH-QUERY and fold over the results using PROC and INITIAL. @@ -110,20 +110,21 @@ first call. OFFSET specifies the number of items to ignore at the beginning of the result set. MAXIMUM-ITEMS specifies the maximum number of items to return." - (mset-fold (lambda (item result) - (proc (call-with-input-string (document-data (mset-item-document item)) - (compose scm->object read)) - (MSetIterator-mset-get item) - result)) - initial - (enquire-mset (let* ((query (parse-query search-query)) - (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) - #:maximum-items maximum-items))) + (let ((mset (enquire-mset (let* ((query (parse-query search-query)) + (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) + #:maximum-items maximum-items))) + (mset-fold (lambda (item result) + (proc (call-with-input-string (document-data (mset-item-document item)) + (compose scm->object read)) + mset + result)) + initial + mset))) (define* (search-map proc db search-query #:key (offset 0) (maximum-items (database-document-count db))) diff --git a/tissue/skribilo.scm b/tissue/skribilo.scm new file mode 100644 index 0000000..8a0a929 --- /dev/null +++ b/tissue/skribilo.scm @@ -0,0 +1,104 @@ +;;; tissue --- Text based issue tracker +;;; Copyright © 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 skribilo) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (skribilo ast) + #:use-module (skribilo evaluator) + #:use-module (skribilo reader) + #:use-module (tissue document) + #:use-module (tissue file-document) + #:use-module (tissue utils) + #:export (<skribilo-fragment> + skribilo-fragment-filename + skribilo-fragment-identifier + document-fragment)) + +(define-class <skribilo-fragment> (<file-document>) + (identifier #:getter skribilo-fragment-identifier #:init-keyword #:identifier) + (reader-name #:getter skribilo-fragment-reader-name #:init-keyword #:reader-name)) + +(define (document-node file identifier reader-name) + "Return @code{<markup>} object describing node identified by +@var{identifier} in @var{file} read using reader named by +@var{reader-name}." + (find1-down (lambda (node) + (and (is-a? node <markup>) + (markup-ident node) + (string=? (markup-ident node) identifier))) + (call-with-input-file file + (cut evaluate-ast-from-port <> #:reader (make-reader reader-name))))) + +(define (fragment-text file identifier reader-name) + "Return the full text of skribilo fragment in @var{file} identified by +@var{identifier} using reader named by @var{reader-name}." + (call-with-output-string + (cut ast->text + (document-node file identifier reader-name) + <>))) + +(define* (document-fragment file identifier #:key (reader-name 'skribe)) + "Return a @code{<skribilo-fragment>} object describing node identified +by @var{identifier} in @var{file} read using reader named by +@var{reader-name}." + (make <skribilo-fragment> + #:title (ast->string + (markup-option (document-node file identifier reader-name) + #:title)) + #:path file + #:commits (commits-affecting-file file) + #:identifier identifier + #:reader-name reader-name + #:snippet-source-text (fragment-text file identifier reader-name))) + +(define-method (document-id-term (fragment <skribilo-fragment>)) + "Return the ID term for skribilo @var{fragment}." + (string-append "Qskribilofragment." + (file-document-path fragment) + "#" + (skribilo-fragment-identifier fragment))) + +(define (ast->text node port) + "Serialize AST @var{node} into text suitable for indexing. Write +output to @var{port}." + (cond + ((is-a? node <node>) + (for-each (match-lambda + ((_ . value) + (display (ast->string value) port))) + (node-options node)) + (newline port) + (ast->text (node-body node) port)) + ((string? node) + (display node port)) + ((number? node) + (display (number->string node) port)) + ((list? node) + (for-each (lambda (element) + (ast->text element port) port) + node)))) + +(define-method (document-text (fragment <skribilo-fragment>)) + "Return the full text of skribilo @var{fragment}." + (fragment-text (file-document-path fragment) + (skribilo-fragment-identifier fragment) + (skribilo-fragment-reader-name fragment))) diff --git a/tissue/tissue.scm b/tissue/tissue.scm index e7637b4..9180467 100644 --- a/tissue/tissue.scm +++ b/tissue/tissue.scm @@ -22,82 +22,96 @@ #: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) + (make-tissue-configuration aliases indexed-documents + web-search-renderer web-files) tissue-configuration? - (project tissue-configuration-project) - (aliases tissue-configuration-aliases) + (aliases delayed-tissue-configuration-aliases) (indexed-documents delayed-tissue-configuration-indexed-documents) - (web-css tissue-configuration-web-css) + (web-search-renderer delayed-tissue-configuration-web-search-renderer) (web-files delayed-tissue-configuration-web-files)) +(define tissue-configuration-aliases + (compose force delayed-tissue-configuration-aliases)) + (define tissue-configuration-indexed-documents (compose force delayed-tissue-configuration-indexed-documents)) +(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)) (define* (gemtext-files-in-directory #:optional directory) - "Return a list of all gemtext files in DIRECTORY tracked in the -current git repository. If DIRECTORY is #f, return the list of all -gemtext files tracked in the current git repository regardless of -which directory they are in." + "Return a list of all gemtext files in @var{directory} tracked in the +current git repository. The returned paths are relative to the +top-level directory of the current repository and do not have a +leading slash. + +If @var{directory} is unspecified, return the list of all gemtext +files tracked in the current git repository regardless of which +directory they are in." (filter (lambda (filename) (and (or (not directory) (string-prefix? directory filename)) (string-suffix? ".gmi" filename))) (git-tracked-files (current-git-repository)))) -(define (pairify lst) - "Return a list of pairs of successive elements of LST. For example, - -(pairify (list 1 2 3 4 5 6)) -=> ((1 . 2) (3 . 4) (5 . 6))" - (match lst - (() '()) - ((first second tail ...) - (cons (cons first second) - (pairify tail))))) - -(define-syntax tissue-configuration +(define-syntax define-lazy (lambda (x) + "Define function that lazily evaluates all its arguments." (syntax-case x () - ((_ args ...) - #`((lambda* (#:key project (aliases '()) - (indexed-documents (delay '())) - web-css (web-files (delay '()))) - "PROJECT is the name of the project. It is used in the title of the -generated web pages, among other places. + ((_ (name formal-args ...) body ...) + (with-syntax ((delayed-formal-args + (map (lambda (formal-arg) + (syntax-case formal-arg () + ((name default-value) + #'(name (delay default-value))) + (x #'x))) + #'(formal-args ...)))) + #`(define-syntax name + (lambda (x) + (with-ellipsis ::: + (syntax-case x () + ((_ args :::) + #`((lambda* delayed-formal-args + body ...) + #,@(map (lambda (arg) + (if (keyword? (syntax->datum arg)) + arg + #`(delay #,arg))) + #'(args :::))))))))))))) + +(define-lazy (tissue-configuration #:key (aliases '()) (indexed-documents '()) + (web-search-renderer (default-theme)) + (web-files '())) + "Construct a <tissue-configuration> object. All arguments are +evaluated lazily. -ALIASES is a list of aliases used to refer to authors in the +@var{aliases} is a list of aliases used to refer to authors in the repository. Each element is in turn a list of aliases an author goes by, the first of which is the canonical name of that author. -INDEXED-DOCUMENTS is a list of <indexed-documents> objects -representing documents to index. +@var{indexed-documents} is a list of @code{<document>} objects (or +objects of classes inheriting from @code{<document>}) representing +documents to index. -WEB-CSS is the path to a CSS stylesheet. It is relative to the -document root and must begin with a /. If it is #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. -WEB-FILES is a list of <file> objects representing files to be written -to the web output." - (make-tissue-configuration project aliases - indexed-documents web-css web-files)) - #,@(append-map (match-lambda - ((key . value) - (if (memq (syntax->datum key) - (list #:indexed-documents #:web-files)) - #`(#,key (delay #,value)) - #`(#,key #,value)))) - (pairify #'(args ...)))))))) +@var{web-files} is a list of @code{<file>} objects representing files to be +written to the web output." + (make-tissue-configuration aliases indexed-documents + web-search-renderer web-files)) diff --git a/tissue/utils.scm b/tissue/utils.scm index 59c0b0a..14cc243 100644 --- a/tissue/utils.scm +++ b/tissue/utils.scm @@ -21,7 +21,9 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 filesystem) + #:use-module (ice-9 match) #:use-module (ice-9 popen) + #:use-module (web uri) #:export (string-blank? string-contains? string-remove-prefix @@ -31,7 +33,9 @@ call-with-temporary-directory call-with-output-pipe get-line-dos-or-unix - memoize-thunk)) + memoize-thunk + query-parameters + query-string)) (define (string-blank? str) "Return #t if STR contains only whitespace. Else, return #f." @@ -120,3 +124,25 @@ ports) in that it also supports DOS line endings." (unless result (set! result (thunk))) result))) + +(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) + "&")) 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)) |