path: root/z.scm

(import (Alpha Core))
(import (prefix (Alpha String) string.))
(import (srfi srfi-1))
(import (sxml simple))
(import (oop goops))
(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"))

;; 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 (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 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" (content node)))))

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

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

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

(define (parse-created node-data)
  (-> node-data
      (re.match "created: ([^\n]*)")
      (re.group 1)))

(define (parse-content node-data)
  (-> node-data
      (re.match "---\n(.*)$")
      (re.group 1)))

(define (load-node id)
  (let ([data (readlines (id->path id))])
    (make <node>
      #:id id
      #:title (parse-title data)
      #:created (parse-created data)
      #:tags (parse-tags data)
      #:content (parse-content data))))

 ;; 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))
         (style ,*css*)
         (body
          (h1 "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)))
                       ,(fmt "~a: ~a"
                             id (title (load-node id))))))))))]
    [("node" id)
     (let* ([node (load-node (string->id id))]
            [txt (or (content node) "")])
       (respond `((pre ,txt))
                #:title (fmt "z - ~a" (title node))))]
    [("tag")
     (let ((tags (dict.keys *tags*)))
       (reindex)
       (respond
        `((ul ,@(turn tags
                  (lambda [tag]
                    `(li (a (@ (href ,(fmt "/tag/~a" tag)))
                            ,(fmt "~a" tag)))))))))]
    [("tag" tag)
     (let ([ids (tagged tag)])
       (respond
        `((ul ,@(turn ids
                  (lambda [id]
                    `(li (a (@ (href ,(fmt "/node/~a" id)))
                            ,(fmt "~a: ~a"
                                  id
                                  (title (load-node id)))))))))))]
    [_ (respond "not found")]))

(define* (serve #:key (port 8080))
  (prn "z")
  (prn (fmt "port ~a" port))
  (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
    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)
         (pr id) (pr ": ")
         (prn (title (load-node id)))))]
    [("tagged" tag)
     (begin
       (reindex)
       (turn (tagged tag)
         (lambda (id)
           (pr id)
           (pr ": ")
           (pr (title (load-node id))))))]
    [("tags")
     (begin
       (reindex)
       (map prn (dict.keys *tags*)))]
    [("web") (serve)]
    [("web" port) (serve #:port (string->number port))]
    [_ (usage)]))