path: root/z.scm

(import (Alpha Core))
(import (prefix (Alpha String) string.))
(import (srfi srfi-1))
(import (sxml simple))
(import (only (srfi srfi-19) date->string current-date))
(import (only (ice-9 match) match))
(import (prefix (dict) dict.))
(import (prefix (re) re.))
(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))

 ;; z program

(define *zdir* (os.path.expanduser "~/test-z-wiki"))

(define *about* "\
# z is a zettelkasten tool

- notes are stored as markdown with metadata
- filenames serve as the note id's
")

;; 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)
  (number->string id 36))

(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 (make-node)
  (let ([path (-> (list-nodes) latest-node inc id->path)])
    (call-with-output-file path

      (fn [file]
          (format file "title:\n")
          (format file "created: ~a\n"
                  (date->string (current-date) "~Y.~m.~d..~H.~M"))
          (format file "tags:\n")
          (display "---\n" file)))
    path))

(define (read-node id)
  (readlines (id->path id)))

(define (cat-node id)
  (prn (read-node id)))

 ;; Metadata

(define (get-title node)
  (-> node
      (re.match "title: ([^\n]*)")
      (re.group 1)))

(define (get-tags node)
  (-> node
      (re.match "tags: ([^\n]*)")
      (re.group 1)
      (string.split #\space)
      seq))

 ;; Indexing

(define *tags* (dict.empty))
(define *titles* (dict.empty))

(define (index-node id)
  (let ([node (read-node id)])
    (dict.set *titles* (get-title node) id)
    (for (get-tags node)
      (/. tag
          (if tag
              (dict.update
               *tags*
               tag
               (/. ids (cons id ids))))))))

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

 ;; Printing

(define (print-titles)
  (for (list-nodes)
    (lambda (id)
      (pr id) (pr ": ")
      (prn (get-title (read-node id))))))

(define (print-node id)
  (pr (read-node id)))

 ;; 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 (template title body)
  `(html (head (title ,title))
         (style ,*css*)
         (body
          ;; TODO: nav bar
          ,@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
      `((h1 "z")
        (ul
         ,@(for (list-nodes)
             (lambda (id)
               `(li (a (@ (href ,(fmt "/id/~a" id)))
                       ,(fmt "~a: ~a"
                             id (get-title (read-node id))))))))))]
    [("id" id)
     (let ([node (read-node (string->id id))])
       (respond `((pre ,node))
                #:title (fmt "z - ~a" (get-title node))))]
    [("tag" tag)
     (let ([ids (tagged tag)])
       `((ul ,@(for nodes
                 `(li (a (@ (href ,(mdt "/id~a" id)))
                         ,(fmt "~a: ~a"
                               id (get-title (read-node id)))))))))]
    [_ (respond "not found")]))

(define* (serve #:key (port 8080))
  (pr "z server")
  (http.run-server routes 'http `(#:port ,port)))

 ;; CLI

(define (usage)
  (prn "\
usage: z [command]
where 'command' is:
    <none>         create new note
    ls             list all notes
    tagged [tag]   list notes tagged with 'tag'
    web [port]     start the webserver"))

(define (main args)
  (match (rest args)
    ['()
     (let ([path (make-node)]
           [editor (os.getenv "EDITOR")])
       (subprocess.call (list editor path))
       (exit EXIT_SUCCESS))]
    [("ls") (print-titles)]
    [("tagged" tag)
     (begin
       (reindex)
       (for (tagged tag)
         (lambda (id)
           (let* ([node (read-node id)]
                  [title (get-title node)])
             (pr id)
             (pr ": ")
             (pr title)))))]
    [("web") (serve)]
    [("web" port) (serve #:port (string->number port))]
    [_ (usage)]))