A minimal webdav server/synthetic filesystem that works with JVM Clojure and babashka. See comments for instructions!

webdav.clj

(ns webdav
  (:require [clojure.string :as str]
            [clojure.data.xml :as xml]
            [org.httpkit.server :as hk-server]))

;; add the XML namespace that we'll use later
(xml/alias-uri 'd "DAV:")

(defn dissoc-in
  "Should be in the standard library..."
  [m [k & ks]]
  (if-not ks
    (dissoc m k)
    (assoc m k (dissoc-in (m k) ks))))

(def tree
  "The filesystem tree, empty but for the root directory."
  (let [now (java.time.ZonedDateTime/now)]
    (atom {:ctime now
           :mtime now
           "time" {:ctime now
                   :mtime now
                   :content (fn [] (str (java.time.ZonedDateTime/now) "\n"))}})))

(defn update-path-timestamps
  "Update ctime/mtime for every file/dir in path."
  [now path]
  (doseq [sub-path (mapv #(vec (drop-last % path)) (range (count path)))]
    (swap! tree assoc-in (conj sub-path :mtime) now)
    (when-not (get-in @tree (conj sub-path :ctime))
      (swap! tree assoc-in (conj sub-path :ctime) now))))

(defn write-file
  "Create if needed, including parent path."
  [path content]
  (swap! tree assoc-in (conj path :content) content)
  (update-path-timestamps (java.time.ZonedDateTime/now) path))

(defn delete-file [path]
  (swap! tree dissoc-in path))

(defn move-file [old-path new-path]
  (let [current-file (get-in @tree (conj old-path))]
    (if-let [content (:content current-file)]
      (write-file new-path content)
      (do (swap! tree assoc-in new-path current-file)
          (update-path-timestamps (java.time.ZonedDateTime/now) new-path))))
  (delete-file old-path))

(defn mkdir [path]
  (update-path-timestamps (java.time.ZonedDateTime/now) path))

(defn date->str
  "Make it ISO 8601/UTC."
  [d]
  (.format d java.time.format.DateTimeFormatter/ISO_INSTANT))

(defn props-for-file [uri file]
  (let [is-file? (:content file)] ; otherwise, directory
    [::d/reponse
     [::d/href (if is-file?
                 uri
                 (if (.endsWith uri "/") ; ensure directories have trailing slash
                   uri
                   (str uri "/")))]
     [::d/propstat
      [::d/prop
       [::d/creationdate (date->str (:ctime file))]
       [::d/getlastmodified (if (fn? (:content file)) ; fn-backed files are always fresh
                              (date->str (java.time.ZonedDateTime/now))
                              (date->str (:mtime file)))]
       [::d/getcontentlength (if (fn? (:content file)) ; fn-backed files have 0 length
                               0
                               (:content file))]
       (if is-file?
         [::d/resourcetype]
         [::d/resourcetype [::d/collection]])]
      [::d/status "HTTP/1.1 200 OK"]]]))

(defn parse-lock-spec [lock-spec]
  (->> (xml/parse-str lock-spec {:namespace-aware false})
       :content
       flatten
       (remove string?)
       (reduce (fn [m thing]
                 (let [tag (:tag thing)]
                   (assoc m tag (if (= tag :D:owner)
                                  (-> thing :content second :content first)
                                  (-> thing :content first :tag)))))
               {})))

(defn handler [req]
  (let [uri (:uri req)
        path (vec (rest (str/split uri #"/")))
        file (get-in @tree path)]
    (println (:headers req))
    (if file ; path exists
      (condp = (:request-method req)
        :options {:status  204
                  :headers {"Allow" "OPTIONS,PROPFIND,GET,PUT,LOCK,UNLOCK,DELETE,MKCOL,MOVE" ; COPY?
                            "DAV" "1,2"}}
        :propfind (do
                    ;; (println (slurp (:body req)))
                    {:body (xml/indent-str
                            (xml/sexp-as-element
                             (if (:content file) ; not a directory
                               [::d/multistatus
                                (props-for-file uri file)]
                               (into [::d/multistatus
                                      (props-for-file uri file)]
                                     (map (fn [[k v]]
                                            (props-for-file (str (if (.endsWith uri "/") uri (str uri "/"))
                                                                 k)
                                                            v))
                                          (dissoc file :ctime :mtime))))))
                     :status 207
                     :headers {"Content-Type" "application/xml"}})
        ;; XXX lock/unlock is currently a no-op! 😱
        :lock (let [lock-req (parse-lock-spec (slurp (:body req)))
                    lock-token (str "urn:uuid:" (str (java.util.UUID/randomUUID)))]
                {:body (xml/indent-str
                        (xml/sexp-as-element
                         [::d/prop
                          [::d/lockdiscovery
                           [::d/activelock
                            [::d/locktype [::d/write]]      ; both of these should come from the
                            [::d/lockscope [::d/exclusive]] ; lock spec, but this'll do for now
                            [::d/depth "infinity"]
                            [::d/owner [::d/href (:D:owner lock-req)]]
                            [::d/timeout "Second-604800"]
                            [::d/locktoken [::d/href lock-token]]
                            [::d/lockroot [::d/href (:uri req)]]]]]))
                 :headers {"Lock-Token" lock-token
                           "Content-Type" "application/xml"}})
        :unlock {:status 204}
        :get (let [content (:content file)
                   body (if (fn? content) ; files backed by functions return the result
                          (content)     ; of calling the function
                          content)]
               {:body body
                :headers {"Content-Length" (str (count body))}})
         ; TODO content-type!
        ;; overwrite existing file
        :put (let [content (:content file)
                   payload (if (nil? (:body req))
                             (byte-array 0)
                             (.readAllBytes (:body req)))]
               (if (fn? content)
                 (content payload)
                 (write-file path payload))
               {:status 201})
        :delete (do (delete-file path)
                    {:status 204})
        :move (do (move-file path (vec (rest (str/split (get (-> req :headers) "destination") #"/"))))
                  {:status 201}))
      ;; path doesn't exist -- if it's a req to create it, we'll try. otherwise 404
      (condp = (:request-method req)
        :mkcol (do (mkdir path) ; XXX should return 409 (Conflict) if the rest of the path doesn't exist
                   {:status 201})
        :put (do (write-file path (if (nil? (:body req))
                                    (byte-array 0)
                                    (.readAllBytes (:body req))))
                 {:status 201})
        {:status 404}))))

(def server ; start server
  (hk-server/run-server #'handler {:port 8080}))

@(promise) ; don't exit

Should the :put method when the file exists be wrapped in a (write-file path ...)? Unless I'm missing something it doesn't look like it currently does anything.

Tried connecting with Nautilus on Linux, got HTTP Error, thought it was related to the status code and changed 207 to 200, but it still reported an error.
Here's a print of the requests and responses, maybe it helps

Request:

{:remote-addr 0:0:0:0:0:0:0:1, :headers {accept-encoding gzip, deflate, accept-language en-us, en;q=0.9, connection Keep-Alive, host localhost:8080, user-agent gvfs/1.48.2}, :async-channel #object[org.httpkit.server.AsyncChannel 0x12d14376 /[0:0:0:0:0:0:0:1]:8080<->/[0:0:0:0:0:0:0:1]:43428], :server-port 8080, :content-length 0, :websocket? false, :content-type nil, :character-encoding utf8, :uri /, :server-name localhost, :query-string nil, :body nil, :scheme :http, :request-method :options}

Response:

{:status 204, :headers {Allow OPTIONS,PROPFIND,GET,PUT,LOCK,UNLOCK,DELETE,MKCOL,MOVE, DAV 2}}

Request:

{:remote-addr 0:0:0:0:0:0:0:1, :headers {accept-encoding gzip, deflate, accept-language en-us, en;q=0.9, connection Keep-Alive, content-length 146, content-type application/xml, depth 1, host localhost:8080, user-agent gvfs/1.48.2}, :async-channel #object[org.httpkit.server.AsyncChannel 0x12d14376 /[0:0:0:0:0:0:0:1]:8080<->/[0:0:0:0:0:0:0:1]:43428], :server-port 8080, :content-length 146, :websocket? false, :content-type application/xml, :character-encoding utf8, :uri /, :server-name localhost, :query-string nil, :body <?xml version="1.0" encoding="utf-8" ?>
 <D:propfind xmlns:D="DAV:">
  <D:prop>
<D:resourcetype/>
<D:getcontentlength/>
  </D:prop>
 </D:propfind>, :scheme :http, :request-method :propfind}

Response:

{:body <?xml version="1.0" encoding="UTF-8"?>
<a:multistatus xmlns:a="DAV:">
  <a:reponse>
    <a:href>/</a:href>
    <a:propstat>
      <a:prop>
        <a:creationdate>Fri, 21 Jul 2023 19:57:25 IDT</a:creationdate>
        <a:getlastmodified>Fri, 21 Jul 2023 19:57:25 IDT</a:getlastmodified>
        <a:resourcetype>
          <a:collection/>
        </a:resourcetype>
      </a:prop>
      <a:status>HTTP/1.1 200 OK</a:status>
    </a:propstat>
  </a:reponse>
</a:multistatus>
, :status 207, :headers {Content-Type application/xml}}

@emlyn 💯 fixed, seem to have broken this when rewriting everything to run in bb

@bsless it looks like Nautilus was asking for the content length in that PROPFIND, while my test environment doesn't. I've added it and updated the gist, let me know if it works for you now! :)

Still doesn't work. Any other info you need?

Hm. I'll spin up a local environment and debug it sometime soon.

Ping me if you need a test subject

@bsless This two character fix may have done it (works with davfs under Linux, anyway)

I found a couple of issues with it:

• if you rename a file, the file completely disappears
• I tried copying a relatively large file into it (~400kB), and it failed (Error code -36). After that all files (even newly copied files) appear to have zero length.