(import (bs core))
(import (prefix (bs dict) dict.))
(import (prefix (bs re) re.))
(import (prefix (bs string) string.))
(import (srfi srfi-1))
(import (sxml simple))
(import (oop goops))
(import (ice-9 peg))
(import (only (srfi srfi-19) date->string current-date))
(import (only (ice-9 match) match match-lambda))
(import (prefix (web server) http.))
(import (prefix (web request) http.req.))
(import (prefix (web response) http.res.))
(import (prefix (web uri) http.uri.))
;; general functions, should be extracted to libs
(import (only (ice-9 ftw) scandir))
(define (os.listdir path)
(scandir path))
(define (os.path.expanduser path)
(let ([home (getenv "HOME")])
(string.replace path "~" home)))
(define (os.getenv var)
(getenv var))
(define (set.difference s1 s2)
(cond [(null? s1) '()]
[(not (member? (first s1) s2))
(cons (first s1) (set.difference (rest s1) s2))]
[else
(set.difference (rest s1) s2)]))
(import (only (ice-9 rdelim) read-delimited))
(define (readlines fname)
(call-with-input-file fname
(lambda [p]
(read-delimited "" p 'concat))))
(import (prefix (ice-9 popen) popen/))
(define (subprocess.call argv)
(apply system* argv))
(import (ice-9 receive))
(import (only (ice-9 rdelim) read-string))
(define (pandoc text)
(receive (from to pid)
((@@ (ice-9 popen) open-process) OPEN_BOTH
"pandoc" "-f" "markdown" "-t" "html")
(display text to)
(close to)
(let ((ret (read-string from)))
(close from)
ret)))
;; z program
(define *zdir* (os.path.expanduser "~/test-z-wiki"))
;; A node 'id' is a monotonically increasing number.
;; It can be represented as a string, in which case it is encoded in
;; base 36.
(define (id->string id)
(fmt "~36,3'0r" id))
(define (string->id s)
(string->number s 36))
;; It can be represented as a path, in which case it is
;; `<*zdir*>/<string>.md'
(define (path->id fname)
"Given a path, parse out the node id."
(-> fname
(string.replace ".md" "")
(string.replace *zdir* "")
(string->id)))
(define (id->path id)
"Given an id, return the absolute path to the file."
(fmt "~a/~a.md" *zdir* (id->string id)))
;; Manipulating nodes
(define (list-nodes* dir)
(->> dir
(os.listdir)
;; remove '.' and '..'
((/. s (set.difference s '("." ".."))))
(map path->id)))
(define (list-nodes)
(list-nodes* *zdir*))
(define (latest-node ls)
(if (eq? ls '())
0
(apply max ls)))
(define (next-id)
(-> (list-nodes) latest-node inc))
(define-class <node> ()
(id #:getter id #:init-keyword #:id)
(title #:accessor title #:init-keyword #:title)
(created #:getter created
#:init-form (date->string (current-date) "~Y.~m.~d..~H.~M"))
(tags #:accessor tags #:init-keyword #:tags)
(content #:accessor get-content #:init-keyword #:content)
(path #:getter path
#:allocation #:virtual
#:slot-set! (lambda (_) #f)
#:slot-ref (lambda (self)
(id->path (id self)))))
(define-generic save!)
(define-method (save! (node <node>))
(call-with-output-file (path node)
(fn [file]
(format file "title: ~a\n" (title node))
(format file "created: ~a\n" (created node))
(format file "tags: ~{~a ~}" (tags node))
(display "---\n" file)
(format file "~a" (get-content node)))))
;; Parsing Nodes
(define-peg-string-patterns "\
node <- meta* content !.
meta <-- key SEP value NL
key <-- 'title' / 'created' / 'tag'
value <-- (!NL !SEP .)*
content <-- HR .*
HR < '---'
SEP < ':'
NL < '\n'
")
(define (parse-meta node-tree)
(turn (first node-tree)
(match-lambda
[('meta ('key key) ('value ret))
`(,key . ,(string.strip ret #\space))]
[_ '()])))
(define (parse-content node-tree)
(-> node-tree second second))
(define (load-node id)
(let* ([node-tree (->> id id->path readlines (match-pattern node) peg:tree)]
[meta (parse-meta node-tree)])
(make <node>
#:id id
#:title (assoc-ref meta "title")
#:created (assoc-ref meta "created")
#:tags (->> meta
(filter (/. P (equal? (car P) "tag")))
(map cdr))
#:content (parse-content node-tree))))
;; Indexing
(define *tags* (dict.empty))
(define *titles* (dict.empty))
(define (index-node id)
(let ([node (load-node id)])
(dict.set *titles* (title node) id)
(turn (tags node)
(/. tag
(if tag
(dict.update
*tags*
tag
(/. ids
(if (contains? ids id)
ids
(cons id ids)))))))))
(define (reindex)
(set! *titles* (dict.empty))
(set! *tags* (dict.empty))
(map index-node (list-nodes)))
;; Searching / filtering
(define (tagged tag)
"returns a list of all ids with the given tag"
(dict.get *tags* tag))
(define (get-by-title title)
(dict.get *titles* title))
;; view
(define *css* "
@import url('https://fonts.googleapis.com/css2?family=Source+Code+Pro:ital,wght@0,400;0,700;1,400&family=Source+Sans+Pro:ital,wght@0,400;0,700;1,400&family=Source+Serif+Pro:wght@400;700&display=swap');
body
{ max-width: 900px; min-height: 100vh
; margin: 0 auto; padding: 0 10px
; color:#444
; font: 18px/1.5 -apple-system, 'Source Sans Pro',
BlinkMacSystemFont, \"Segoe UI\", Roboto, \"Helvetica Neue\", Arial,
\"Noto Sans\", sans-serif, \"Apple Color Emoji\", \"Segoe UI Emoji\",
\"Segoe UI Symbol\", \"Noto Color Emoji\"
; display: flex; flex-direction: column
}
main,nav,aside { font-family: 'Source Sans Pro', sans-serif; }
nav { order: -1 }
h1,h2,h3 { line-height: 1.2 }
p, li { line-height: 1.4rem }
p { margin: 0 0 1.8rem 0 }
.serif { font-family: 'Source Sans Pro', serif }
pre { font-family: 'Source Sans Pro', monospace }
pre a, pre a:hover, pre a:visited { text-decoration: none }
@media (min-width: 768px) {
body { flex-direction: row; flex: 1; justify-content: center }
main { flex: 1 }
nav, aside { flex: 0 0 12em }
}
/* Base16 Spacemacs Scheme: Nasser Alshammari (https://github.com/nashamri/spacemacs-theme) */
table.sourceCode, tr.sourceCode, td.sourceCode, table.sourceCode pre
{ margin: 0; padding: 0; border: 0; vertical-align: baseline; border: none; background-color: #f8f8f8; color: #444155 }
td.nums { text-align: right; padding-right: 5px; padding-left: 5px; background-color: #e8e8e8; }
td.sourceCode { padding-left: 5px; }
code.sourceCode { background-color: #f8f8f8; }
pre.sourceCode { background-color: #f8f8f8; line-height: 125% }
td.nums pre { background-color: #e8e8e8; line-height: 125% }
code.sourceCode span.kw { color: #4f97d7; font-weight: bold } /* Keyword */
code.sourceCode span.dt { color: #a31db1} /* Keyword.Type */
code.sourceCode span.dv { color: #ffa500 } /* Literal.Number.Integer */
code.sourceCode span.bn { color: #ffa500 } /* Literal.Number.Hex */
code.sourceCode span.fl { color: #ffa500 } /* Literal.Number.Float */
code.sourceCode span.ch { color: #67b11d} /* Literal.String.Char */
code.sourceCode span.st { color: #67b11d } /* Literal.String */
code.sourceCode span.co { color: #585858 } /* Comment */
code.sourceCode span.ot { color: #b03060 } /* Comment.Preproc */
code.sourceCode span.al { color: #a31db1 } /* Generic.Error */
code.sourceCode span.fu { color: #b1951d } /* Name.Function */
code.sourceCode span.re { color: #2d9574}
code.sourceCode span.er { color: #f2241f; border: 1px solid #a31db1 } /* Error */
@media (prefers-color-scheme: dark)
{
body { color: white; background: #444 }
a:link { color: #5bf }
a:visited { color: #ccf }
/* Base16 Spacemacs Scheme: Nasser Alshammari (https://github.com/nashamri/spacemacs-theme) */
table.sourceCode, tr.sourceCode, td.sourceCode, table.sourceCode pre
{ margin: 0; padding: 0; border: 0; vertical-align: baseline; border: none; background-color: #1f2022; color: #a3a3a3 }
td.nums { text-align: right; padding-right: 5px; padding-left: 5px; background-color: #282828; }
td.sourceCode { padding-left: 5px; }
code.sourceCode { background-color: #1f2022; }
pre.sourceCode { background-color: #1f2022; line-height: 125% }
td.nums pre { background-color: #282828; line-height: 125% }
code.sourceCode span.kw { color: #4f97d7; font-weight: bold } /* Keyword */
code.sourceCode span.dt { color: #a31db1} /* Keyword.Type */
code.sourceCode span.dv { color: #ffa500 } /* Literal.Number.Integer */
code.sourceCode span.bn { color: #ffa500 } /* Literal.Number.Hex */
code.sourceCode span.fl { color: #ffa500 } /* Literal.Number.Float */
code.sourceCode span.ch { color: #67b11d} /* Literal.String.Char */
code.sourceCode span.st { color: #67b11d } /* Literal.String */
code.sourceCode span.co { color: #585858 } /* Comment */
code.sourceCode span.ot { color: #b03060 } /* Comment.Preproc */
code.sourceCode span.al { color: #a31db1 } /* Generic.Error */
code.sourceCode span.fu { color: #b1951d } /* Name.Function */
code.sourceCode span.re { color: #2d9574}
code.sourceCode span.er { color: #f2241f; border: 1px solid #a31db1 } /* Erro r */
}
")
;; global navbar on the left side
(define *navbar*
`(nav
(h1 (a (@ (href "/") (class "serif")) "z"))
(ul
,@(receive (names paths)
(unzip2 '(("index" "/")
#;("new" "/id/new")
("tags" "/tag")))
(map (lambda (name path)
`(li (a (@ (href ,path)) ,name)))
names paths)))))
(define (template title body)
`(html (head
(title ,title)
(meta (@ (name "viewport")
(content "width=device-width, initial-scale=1"))))
(style ,*css*)
(body
,@body)))
(define (link-tag tag)
`(a (@ (href ,(fmt "/tag/~a" tag)))
,(fmt "~a" tag)))
(define (view-content node)
`(main
(h2 ,(title node))
,(->> node
get-content
pandoc
;; wrap in article tags so sxml includes all of the
;; content, not just the first element
((/. s (string.str "<article>" s "</article>")))
xml->sxml)))
(define (view-meta node)
`(aside
(ul
(li ,(created node))
,(turn (tags node)
(/. tag `(li ,(link-tag tag)))))))
;; webserver
(define* (respond #:optional body #:key
(status 200)
(title "z")
(doctype "<!DOCTYPE html>\n")
(content-type-params '((charset . "utf-8")))
(content-type 'text/html)
(extra-headers '())
(sxml (and body (template title body))))
(values (http.res.build-response
#:code status
#:headers `((content-type
. (,content-type ,@content-type-params))
,@extra-headers))
(lambda (port)
(when sxml
(if doctype (display doctype port))
(sxml->xml sxml port)))))
(define (path-components req)
(-> req
http.req.request-uri
http.uri.uri-path
http.uri.split-and-decode-uri-path))
(define (routes req body)
(match (path-components req)
['()
(respond
`((ul
,@(turn (list-nodes)
(lambda (id)
`(li (a (@ (href ,(fmt "/node/~a" (id->string id))))
,(fmt "~a: ~a"
(id->string id)
(title (load-node id))))))))))]
[("node" id)
(let* ([node (load-node (string->id id))]
[txt (or (get-content node) "")])
(respond
(list
(view-content node)
(view-meta node)
*navbar*)
#:title (fmt "z - ~a" (title node))))]
[("tag")
(begin
(reindex)
(respond
`((ul ,@(turn (dict.keys *tags*)
(lambda [tag]
`(li ,(link-tag tag))))))))]
[("tag" tag)
(respond
`((ul ,@(turn (tagged tag)
(lambda [id]
`(li (a (@ (href ,(fmt "/node/~a" (id->string id))))
,(fmt "~a: ~a"
(id->string id)
(title (load-node id))))))))))]
[_ (respond '(h1 "not found")
#:title "z - not found")]))
(define* (serve #:key (port 8080))
(prn "z")
(prn (fmt "port ~a" port))
(http.run-server routes 'http `(#:port ,port #:host "0.0.0.0")))
;; CLI
(define (usage)
(prn "\
usage: z [command]
where 'command' is:
<none> create new note
ls list all notes
tags list all tags
tagged [tag] list notes tagged with 'tag'
web [port] start the webserver"))
(define (main args)
(match (rest args)
['()
;; TODO: create a tmp file with template, open that in editor,
;; write and save. then load-node and save! proper. I can't pipe,
;; because emacs doesn't pipe to buffer
(let ([node (make <node>)]
[editor (os.getenv "EDITOR")])
(subprocess.call (list editor (path node)))
(exit EXIT_SUCCESS))]
[("ls")
(turn (list-nodes)
(lambda (id)
(format #t "~a: ~a\n"
(id->string id)
(title (load-node id)))))]
[("tagged" tag)
(begin
(reindex)
(turn (tagged tag)
(lambda (id)
(format #t "~a: ~a\n"
(id->string id)
(title (load-node id))))))]
[("tags")
(begin
(reindex)
(turn (dict.keys *tags*)
(lambda (tag)
(format #t
"(~a) ~a\n"
(count (const #t) (dict.get *tags* tag))
tag))))]
[("web") (serve)]
[("web" port) (serve #:port (string->number port))]
[_ (usage)]))