Skip to content

Instantly share code, notes, and snippets.

@jackrusher
Last active June 15, 2024 16:14
Show Gist options
  • Save jackrusher/af3528564355691dda9db327cd2b185d to your computer and use it in GitHub Desktop.
Save jackrusher/af3528564355691dda9db327cd2b185d to your computer and use it in GitHub Desktop.
A minimal webdav server/synthetic filesystem that works with JVM Clojure and babashka. See comments for instructions!
(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
@bsless
Copy link

bsless commented Jul 21, 2023

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}}

@jackrusher
Copy link
Author

@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! :)

@bsless
Copy link

bsless commented Jul 22, 2023

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

@jackrusher
Copy link
Author

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

@bsless
Copy link

bsless commented Jul 24, 2023

Ping me if you need a test subject

@jackrusher
Copy link
Author

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

@emlyn
Copy link

emlyn commented Jul 27, 2023

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.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment