web server is working

2 files changed, 174 insertions, 36 deletions

diff --git a/Alpha/Core.scm b/Alpha/Core.scm
index 192a74f..db5975b 100644
--- a/Alpha/Core.scm
+++ b/Alpha/Core.scm
@@ -6,7 +6,7 @@
   #:export (fmt printf pr prn rest last butlast
                 true? false? some? empty?
                 -> ->> fn /. curry comp
-                repeat
+                repeat for seq
                 inc dec member? contains?
                 comment get-source* get-source source))
 
@@ -49,7 +49,7 @@
   (eq? #t x))
 
 (define (some? a)
-  (not (nil? a)))
+  (not (null? a)))
 
 (define (empty? a)
   (equal? a '()))
@@ -205,3 +205,11 @@
 
 (define (contains? ls x)
   (member? x ls))
+
+(define (for ls f)
+  (map f ls))
+
+(define (seq x)
+  (if (list? x)
+      x
+      (list x)))
diff --git a/z.scm b/z.scm
index c318d9a..ef7466e 100644
--- a/z.scm
+++ b/z.scm
@@ -1,10 +1,17 @@
 (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
+ ;; general functions, should be extracted to libs
 
 (import (only (ice-9 ftw) scandir))
 (define (os.listdir path)
@@ -14,9 +21,8 @@
   (let ([home (getenv "HOME")])
     (string.replace path "~" home)))
 
-(import (only (srfi srfi-1) remove))
-(define (rm ls item)
-  (remove (/. x (eq? x item)) ls))
+(define (os.getenv var)
+  (getenv var))
 
 (define (set.difference s1 s2)
   (cond [(null? s1) '()]
@@ -31,10 +37,21 @@
     (lambda [p]
       (read-delimited "" p 'concat))))
 
-;; z program
+(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
@@ -62,7 +79,7 @@
        *zdir*
        (id->string id)))
 
-;; Manipulating nodes
+ ;; Manipulating nodes
 
 (define (list-nodes* dir)
   (->> dir
@@ -79,15 +96,17 @@
       0
       (apply max ls)))
 
-(define (make-node title)
-  (call-with-output-file
-      (-> (list-nodes) latest-node inc id->path)
-    (fn [file]
-        (format file "title: ~a\n" title)
-        (format file "created: ~a\n"
-                (date->string (current-date) "~Y.~m.~d..~H.~M"))
-        (format file "tags:\n")
-        (display "---\n" file))))
+(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)))
@@ -95,29 +114,140 @@
 (define (cat-node id)
   (prn (read-node id)))
 
-;; Metadata
+ ;; Metadata
 
-(define (get-title id)
-  (-> id
-      read-node
+(define (get-title node)
+  (-> node
       (re.match "title: ([^\n]*)")
-      (match:substring 1)))
-
-(define (get-by-title title)
-  (let ([index (index-titles)])
-    (assoc title index)))
+      (re.group 1)))
 
-(define (get-tags id)
-  (-> id
-      read-node
+(define (get-tags node)
+  (-> node
       (re.match "tags: ([^\n]*)")
       (re.group 1)
-      (string.split #\space)))
+      (string.split #\space)
+      seq))
 
-;; Indexing
+ ;; Indexing
 
-(define (index-titles)
-  (fold
-   (/. node ls (acons (get-title node) node ls))
-   '()
-   (list-nodes)))
+(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 files 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 ,@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
+         ,@(map
+            (lambda (id)
+              `(li (a (@ (href ,(fmt "/id/~a" id)))
+                      ,(fmt "~a: ~a"
+                            id (get-title (read-node id))))))
+            (list-nodes)))))]
+    [("id" id)
+     (let ([node (read-node (string->id id))])
+       (respond `((pre ,node))
+        #:title (fmt "z - ~a" (get-title node))))]
+    [("hacker")
+     (respond "Hello hacker!")]
+    [_ (respond "not found")]))
+
+ ;; CLI
+
+(define (usage)
+  (prn "\
+usage: z [command]
+where 'command' is:
+    <none>         create new note
+    tagged [tag]   list notes tagged with 'tag'"))
+
+(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") (begin
+               (pr "z server")
+               (http.run-server routes))]
+    [_ (usage)]))