feat: very primitive publisher

publisher/deps.edn

@@ -1,23 +1,15 @@
 {:deps {org.clojure/clojure {:mvn/version "1.12.0"}
-        http-kit/http-kit {:mvn/version "2.8.0"}
         org.clojure/tools.logging {:mvn/version "1.3.0"}
         hiccup/hiccup {:mvn/version "2.0.0-RC4"}
-        compojure/compojure {:mvn/version "1.7.1"}
         org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
-        ring/ring-defaults {:mvn/version "0.6.0"}
         babashka/fs {:mvn/version "0.5.24"}
         org.clojure/core.match {:mvn/version "1.1.0"}
         com.github.seancorfield/next.jdbc {:mvn/version "1.3.1070"}
         org.xerial/sqlite-jdbc {:mvn/version "3.47.1.0"}
         cheshire/cheshire {:mvn/version "6.1.0"}
-        instaparse/instaparse {:mvn/version "1.5.0"}
-        babashka/process {:mvn/version "0.6.25"}
         org.clojure/test.check {:mvn/version "1.1.2"}
-        #_#_
-        io.github.msyds/spec-dict
-        {:git/sha "531d629b7f05f37232261cf9e8927a4b5915714f"}
-        net.deertopia/doerg {:local/root "../doerg"}}
- :paths ["src" "resources" "test"]
- :aliases
- {:dev
-  {:extra-deps {vvvvalvalval/scope-capture-nrepl {:mvn/version "0.3.1"}}}}}
+        net.deertopia/doerg {:local/root "../doerg"}
+        metosin/reitit {:mvn/version "0.10.1"}
+        http-kit/http-kit {:mvn/version "2.8.0"}
+        instaparse/instaparse {:mvn/version "1.5.0"}}
+ :paths ["src" "resources" "test"]}

publisher/resources/net/deertopia/publisher/elisp/grammar

@@ -0,0 +1,30 @@
+<file> ::= elements
+
+<elements> ::= ws? element ws? elements
+            |  ws? ε
+
+<element> ::= string
+           |  list
+           |  symbol
+           |  integer
+           |  property-string
+
+string ::= <'"'> #'([^"\\]|\\.|\\\n)*' <'"'>
+
+property-string
+  ::= <'#('> ws? string text-property* ws? <')'>
+
+text-property ::= ws? element ws? element ws? element
+
+list ::= <'('> elements dot-cdr? <')'>
+
+symbol ::= #'([^?#0-9 \n\s\f()\[\]"\'\\.]|\\.)([^ \n\s\f()\[\]"\'\\]|\\.)*'
+        |  #'\.([^ \n\s\f()\[\]"\'\\]|\\.)+'
+
+integer ::= #'[-+]?[0-9]+' <#'.'>?
+
+dot-cdr ::= <'.'> ws? element
+
+<text> ::= ws? (string | property-string) ws?
+
+<ws> ::= <#'(\s||\n)'>+

publisher/src/net/deertopia/publisher/cached_file.clj

@@ -0,0 +1,24 @@
+(ns net.deertopia.publisher.cached-file
+  (:require [babashka.fs :as fs]))
+
+(defn newer-than?
+  "Return `true` if fs `file₁` was last modified sooner or at the same
+  time as `file₂`, or if `file₂` does not exist."
+  [file₁ file₂]
+  (or (not (fs/exists? file₂))
+      (<= 0 (compare (fs/last-modified-time file₁)
+                     (fs/last-modified-time file₂)))))
+
+(def ^:dynamic *use-cache?*
+  "Bind to `false` to disable caching for debugging purposes."
+  true)
+
+(defn cached-file
+  "Return a file path after potentially regenerating the file by
+  calling `compute` with no arguments only if stale? is logical true."
+  [& {:keys [file stale? compute]}]
+  (when (or (not *use-cache?*) stale?)
+    (let [r (compute)]
+      (assert (string? r))
+      (spit file r)))
+  file)

publisher/src/net/deertopia/publisher/config.clj

@@ -0,0 +1,17 @@
+(ns net.deertopia.publisher.config
+  (:require [babashka.fs :as fs]
+            [clojure.spec.alpha :as s]
+            [net.deertopia.doerg.config :as doerg]))
+
+(s/def ::config
+  (s/keys :req [::state-directory
+                ::org-roam-db-path]))
+
+(def default
+  {::state-directory (fs/xdg-state-home "doerg-publisher")
+   ::org-roam-db-path (fs/file (fs/home) ".cache" "emacs" "org-roam.db")})
+
+(def ^:dynamic *cfg* default)
+
+(s/def ::state-directory ::doerg/file)
+(s/def ::org-roam-db-path ::doerg/file)

publisher/src/net/deertopia/publisher/elisp.clj

@@ -0,0 +1,119 @@
+(ns net.deertopia.publisher.elisp
+  (:require
+   [clojure.core.match :refer [match]]
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [instaparse.core :as ip]))
+
+(ip/defparser read*
+  (io/resource "net/deertopia/publisher/elisp/grammar"))
+
+(defn- transform-string [s]
+  (let [s* (loop [s (seq s)
+                  acc ""]
+             (match s
+               ([\\ c & cs] :seq)
+               (recur
+                cs
+                (str acc
+                     (condp = c
+                       \n \newline
+                       \f \formfeed
+                       \\ \\
+                       \" \"
+                       \newline nil
+                       (throw (ex-info "IDK!" {:char c})))))
+               ([c & cs] :seq) (recur cs (str acc c))
+               ([] :seq) acc))]
+    [:string (apply str s*)]))
+
+(defn- transform-integer [s]
+  [:integer (parse-long s)])
+
+(defn- transform-property-string
+  ([[_ text]]
+   [:string text])
+  ([[_ text] & props]
+   [:string text (->> (for [[_ [_ beg] [_ end] prop] props]
+                        {[beg end] prop})
+                      (apply merge))]))
+
+(defn- transform-list [& xs]
+  (match (last xs)
+    [:dot-cdr x] [:cons* (butlast xs) x]
+    _ [:cons* xs]))
+
+(def transforms {:string transform-string
+                 :list transform-list
+                 :integer transform-integer
+                 :property-string transform-property-string})
+
+(defn read [s & args]
+  (->> (apply read* s args)
+       (ip/transform transforms)))
+
+(defn read-string [s]
+  (read s :start :text))
+
+(defn cons? [x]
+  (= (first x) :cons*))
+
+(s/def ::alist
+  (s/tuple #{:list}
+           (s/and ::list
+                  cons?)))
+
+(defn car [x]
+  (match x
+    [:cons* xs y] (first xs)
+    [:cons* xs] (first xs)
+    [:symbol "nil"] nil
+    _ nil))
+
+(defn cdr [x]
+  (match x
+    [:cons* xs y] (if (<= (count xs) 1)
+                    y
+                    [:cons* (rest xs) y])
+    [:cons* xs] [:cons* (rest xs)]
+    [:symbol "nil"] nil
+    _ nil))
+
+(defn emacs-list? [x]
+  (match x
+    [:cons* xs] true
+    _ false))
+
+(defn read-alist [s]
+  (let [r (->> s read*
+               (ip/transform
+                (merge transforms
+                       {:symbol (fn [s] (symbol s))
+                        :string (fn [s] s)}))
+               first)]
+    (match r
+      [:cons* pairs] (->> (for [pair pairs]
+                            (let [x (car pair)
+                                  y (cdr pair)]
+                              {x y}))
+                          (apply merge))
+      _ nil)))
+
+(defn read-string [s]
+  (match (-> s read first)
+    [:string x & props] x
+    :else nil))
+
+(defn print [x]
+  ;; TODO: this is really not how it should be done lol. at the
+  ;; moment, `print` is only used in `net.deertopia.publisher.roam`
+  ;; and only to serialise uuids, so it's not a /massive/ priority.
+  (cond (string? x) (str \" x \")
+        :else (throw (ex-info "`print` is unimplemented lol"
+                              {:x x}))))
+
+(comment
+  (do (ip/defparser parse* (io/resource "elisp-grammar"))
+      (read "#(\"blah\" 0 1 (doge))")
+      (read "\"bla\\nh\"")
+      (read-alist "((x . y))")))

publisher/src/net/deertopia/publisher/main.clj

@@ -1,7 +1,7 @@
 (ns net.deertopia.publisher.main
-  (:require [net.deertopia.doerg.main :as doerg])
+  (:require [net.deertopia.doerg.main :as doerg]
+            [net.deertopia.publisher.server :as server])
   (:gen-class))
 
 (defn -main []
-  (doerg/-main)
-  (println "hi from publisher"))
+  (server/start!))

publisher/src/net/deertopia/publisher/roam.clj

@@ -0,0 +1,170 @@
+(ns net.deertopia.publisher.roam
+  (:require [babashka.fs :as fs]
+            [net.deertopia.publisher.config :as cfg]
+            [net.deertopia.publisher.elisp :as elisp]
+            [net.deertopia.publisher.slug :as slug]
+            [next.jdbc :as sql])
+  (:import (java.util UUID)))
+
+
+;;; Global database
+
+(defonce ^:dynamic *use-db-cache?* true)
+
+(def db-path (-> cfg/*cfg* ::cfg/org-roam-db-path
+                 fs/expand-home str))
+
+(def db {:dbtype "sqlite"
+         :dbname db-path})
+
+(def ds (sql/get-datasource db))
+
+
+;;; Elisp sexp (de)serialisation
+
+(defn id [node]
+  (-> node :id))
+
+(defn slug [node]
+  (-> node :id slug/from-uuid))
+
+(defn- print-id [node]
+  (-> node id print))
+
+
+;;; Node
+
+(defrecord Node [id cache])
+
+(defn make-node [uuid]
+  (->Node uuid (atom {})))
+
+(defn- fetch-with-cache [node field fetch]
+  (if *use-db-cache?*
+    (-> (:cache node)
+        (swap! (fn [cache]
+                 (update cache field #(or % (fetch node)))))
+        (get field))
+    (fetch node)))
+
+(defn org-file [node]
+  (fetch-with-cache
+   node :org-file
+   (fn [node]
+     (when-some [r (sql/execute-one!
+                    ds
+                    ["select file from nodes where id = ?"
+                     (-> node :id str elisp/print)])]
+       (-> r :nodes/file elisp/read-string)))))
+
+(defprotocol GetNode
+  (get-node [this]
+    "Return the node associated with `this` or nil."))
+
+(extend-protocol GetNode
+  String
+  (get-node [this]
+    (or (some-> this slug/from-string get-node)
+        (some-> this parse-uuid get-node)
+        (throw (IllegalArgumentException.
+                "Give `get-node` a UUID or slug string plz. }:)"))))
+  java.util.UUID
+  (get-node [this]
+    (make-node this))
+  net.deertopia.publisher.slug.Slug
+  (get-node [this]
+    (-> this slug/to-uuid make-node))
+  Node
+  (get-node [this]
+    this))
+
+(comment
+  (def node (get-node "68XqhHerTWCbE--RYLEdHw"))
+  (fetch-with-cache
+   node :title
+   #(do (println "fetch")
+        (sql/execute-one! ds ["select title from nodes where id = ?"
+                              (elisp/print (:id %))]))))
+
+
+;;; Node operations
+
+(defn level [node]
+  (fetch-with-cache
+   node :level
+   #(-> (sql/execute-one!
+         ds ["select level from nodes where id = ?"
+             (print-id %)])
+        :nodes/level)))
+
+(defn top-level? [node]
+  (zero? (level node)))
+
+(defn file [node]
+  (fetch-with-cache
+   node :file
+   #(-> (sql/execute-one!
+         ds ["select file from nodes where id = ?"
+             (print-id %)])
+        :nodes/file
+        elisp/read-string)))
+
+(defn properties [node]
+  (fetch-with-cache
+   node :properties
+   #(-> (sql/execute-one!
+         ds ["select properties from nodes where id = ?"
+             (print-id %)])
+        :nodes/properties
+        elisp/read-alist)))
+
+(defn public? [node]
+  (-> node properties (get "DEERTOPIAVISIBILITY") (= "public")))
+
+(defn graph-visible? [node]
+  (#{"public" "graphonly"}
+   (-> node properties (get "DEERTOPIAVISIBILITY"))))
+
+(defn backlinks
+  "Returns a collection of maps {:id …, :title …}."
+  [node]
+  (for [{id :nodes/id, title :nodes/title}
+        (sql/execute! ds ["select distinct nodes.id, nodes.title from links
+                           inner join nodes
+                           on nodes.id = links.source
+                           where links.dest = ?"
+                          (elisp/print (:id node))])
+        :let [id (elisp/read-string id)]
+        :when (graph-visible? (get-node (UUID/fromString id)))]
+    {:id id
+     :title (elisp/read-string title)}))
+
+
+;;; Graph support
+
+(defn- read-string-field [n field]
+  (-> n (get field) elisp/read-string))
+
+(defn- uuid-graph-visible? [uuid]
+  (-> uuid parse-uuid get-node graph-visible?))
+
+(defn get-graph []
+  (let [nodes (sql/execute! ds ["select id, title from nodes"])
+        links (sql/execute!
+               ds
+               ["select n1.id as source, nodes.id as target from
+                   ((nodes as n1) join links on n1.id = links.source)
+                 join (nodes as n2) on links.dest = nodes.id
+                 where links.type = '\"id\"'"])]
+    {:nodes (for [n nodes
+                  :let [id (read-string-field n :nodes/id)]
+                  :when (uuid-graph-visible? id)]
+              {:id id
+               :title (read-string-field n :nodes/title)})
+     :links (for [l links
+                  :let [source (read-string-field l :nodes/source)
+                        target (read-string-field l :nodes/target)]
+                  :when (and (uuid-graph-visible? source)
+                             (uuid-graph-visible? target))]
+              {:source source
+               :target target})}))

publisher/src/net/deertopia/publisher/server.clj

@@ -0,0 +1,112 @@
+(ns net.deertopia.publisher.server
+  (:require [clojure.pprint :refer [pprint]]
+            [clojure.tools.logging :as l]
+            [hiccup2.core :as hiccup]
+            [net.deertopia.doerg.html :as doerg-html]
+            [net.deertopia.publisher.slug :as slug]
+            [net.deertopia.publisher.config :as cfg]
+            [net.deertopia.publisher.roam :as roam]
+            [org.httpkit.server :as http]
+            [reitit.coercion]
+            [reitit.coercion.spec]
+            [reitit.ring.coercion]
+            [reitit.core :as r]
+            [reitit.ring]
+            [reitit.ring.middleware.exception :as reitit-exception]
+            [ring.util.response :as response]
+            [spec-tools.spell]
+            [reitit.spec]
+            [reitit.dev.pretty]
+            [clojure.spec.alpha :as s]
+            [net.deertopia.doerg.render :as doerg-render]))
+
+
+;;; Routes
+
+(defn hello [req]
+  (-> (hiccup/html {}
+        [:html
+         [:head
+          [:title "hello"]
+          doerg-html/charset
+          doerg-html/viewport]
+         [:body
+          [:pre
+           (with-out-str
+             (pprint req))]]])
+      str
+      response/response
+      (response/content-type "text/html")))
+
+(defn node-by-slug [{{{:keys [slug]} :path} :parameters}]
+  (let [html (-> slug slug/from-string roam/get-node
+                 roam/org-file doerg-render/to-html)]
+    (-> html response/response
+        (response/content-type "text/html"))))
+
+(defn node-by-id [req]
+  (hello req))
+
+(def exception-middleware
+  (reitit-exception/create-exception-middleware
+   (merge
+    reitit-exception/default-handlers
+    {::reitit-exception/wrap
+     (fn [handler e request]
+       (l/error e "error in fucking somwhere dude")
+       (handler e request))})))
+
+(def router
+  (reitit.ring/router
+   #{["/" {:get hello}]
+     ["/n/:slug"
+      {:get {:handler #'node-by-slug
+             :parameters
+             {:path {:slug ::slug/slug}}}}]
+     ["/id/:id" {:get #'node-by-id}]}
+   {:validate reitit.spec/validate
+    :exception reitit.dev.pretty/exception
+    :spec (s/merge :reitit.spec/default-data)
+    :data
+    {:coercion reitit.coercion.spec/coercion
+     :middleware [exception-middleware
+                  reitit.ring.coercion/coerce-request-middleware
+                  reitit.ring.coercion/coerce-response-middleware
+                  #_reitit.ring.coercion/coerce-exceptions-middleware]}}))
+
+
+;;; Server API
+
+(def app (reitit.ring/ring-handler router))
+
+(defonce server (atom nil))
+
+(defn stop! []
+  (when @server
+    (http/server-stop! @server {:timeout 100})
+    (reset! server nil)
+    (l/info "Stopped server")))
+
+;; For some reason, the log messages from `stop!` are not flushed
+;; before the JVM shuts dowm.  Nevertheless, the server /does/ come to
+;; a graceful halt.
+(def ^:private shutdown-hook (Thread. stop!))
+
+(defn start! []
+  (if @server
+    (let [msg "Server already started"]
+      (throw (ex-info msg {})))
+    (do (reset! server
+                (http/run-server (bound-fn* #'app)
+                                 {:port 8080
+                                  :legacy-return-value? false}))
+        ;; For some reason, the log messages are not flushed before
+        ;; the JVM shuts dowm.  Nevertheless, the server /does/ come
+        ;; to a graceful halt.
+        (.addShutdownHook (Runtime/getRuntime) shutdown-hook)
+        (l/info "Server started on port 8080"))))
+
+(defn status []
+  (if @server
+    (http/server-status @server)
+    :stopped))

publisher/src/net/deertopia/publisher/slug.clj

@@ -0,0 +1,64 @@
+(ns net.deertopia.publisher.slug
+  (:require [clojure.spec.alpha :as s]
+            [spec-tools.core :as st])
+  (:import (java.nio ByteBuffer)
+           (java.util Base64 UUID)))
+
+(defrecord Slug [slug-string]
+  Object
+  (toString [this]
+    (:slug-string this)))
+
+(defn from-string [s]
+  (try (let [decoder (Base64/getUrlDecoder)]
+         (when (= 16 (count (.decode decoder s)))
+           (Slug. s)))
+       ;; really stupid
+       (catch IllegalArgumentException _
+         nil)))
+
+(defn to-string [s]
+  (str s))
+
+(defn- coerce-to-uuid [string-or-uuid]
+  (cond (string? string-or-uuid) (UUID/fromString string-or-uuid)
+        (uuid? string-or-uuid) string-or-uuid))
+
+(defn- uuid->bytes [string-or-uuid]
+  (let [uuid (coerce-to-uuid string-or-uuid)]
+    (.array (doto (ByteBuffer/wrap (byte-array 16))
+              (.putLong (.getMostSignificantBits uuid))
+              (.putLong (.getLeastSignificantBits uuid))))))
+
+(defn- bytes->uuid [bytes]
+  (when (= (count bytes) 16)
+    (let [bb (ByteBuffer/wrap bytes)
+          high (.getLong bb)
+          low (.getLong bb)]
+      (UUID. high low))))
+
+(defn from-uuid [string-or-uuid]
+  (let [uuid (coerce-to-uuid string-or-uuid)
+        encoder (.withoutPadding (Base64/getUrlEncoder))]
+    (Slug. (.encodeToString encoder (uuid->bytes uuid)))))
+
+(defn to-uuid [slug]
+  (let [decoder (Base64/getUrlDecoder)]
+    (bytes->uuid (.decode decoder (str slug)))))
+
+(comment
+  (let [uuid #uuid "f9eab66e-7773-4b87-b854-0bfc8f563809"
+        slug (from-uuid uuid)
+        round-tripped (to-uuid slug)]
+    {:uuid uuid, :slug slug, :round-tripped round-tripped}))
+
+(defn make-slug [string]
+  (assert (try (to-uuid string)
+               (catch Throwable _
+                 nil))
+          "invalid slug")
+  (->Slug string))
+
+(s/def ::slug
+  (s/conformer #(or (some-> % from-string)
+                    ::s/invalid)))