path: root/z.scm

(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)))))

(define-generic render-li)
(define-generic render-full)

 ;; 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))

 ;; webserver

(define *css* "body{max-width:650px;margin:40px auto;padding:0 10px;font:18px/1.5 -apple-system, BlinkMacSystemFont, \"Segoe UI\", Roboto, \"Helvetica Neue\", Arial, \"Noto Sans\", sans-serif, \"Apple Color Emoji\", \"Segoe UI Emoji\", \"Segoe UI Symbol\", \"Noto Color Emoji\";color:#444}h1,h2,h3{line-height:1.2}@media (prefers-color-scheme: dark){body{color:white;background:#444}a:link{color:#5bf}a:visited{color:#ccf}}")

(define *navbar*
  (let ((items (lambda ()
                 (unzip2
                  '(("index" "/")
                    #;("new" "/id/new")
                    ("tags" "/tag"))))))
    `(nav
      (ul
       ,@(call-with-values items
          (lambda (names paths)
            (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
          (h1 (a (@ (href "/"))
                 "z"))
          ,*navbar*
          ,@body)))

(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
        `(,(->> txt
                pandoc
                ;; wrap in article tags so sxml includes all of the content
               ((/. s (string.str "<article>" s "</article>")))
               xml->sxml))
        #:title (fmt "z - ~a" (title node))))]
    [("tag")
     (begin
       (reindex)
       (respond
        `((ul ,@(turn (dict.keys *tags*)
                      (lambda [tag]
                        `(li (a (@ (href ,(fmt "/tag/~a" tag)))
                                ,(fmt "~a" 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)]))