From 5daf85f95c615df35437f9c5b918f18497434ad3 Mon Sep 17 00:00:00 2001 From: elioat Date: Fri, 21 Jul 2023 11:50:33 -0400 Subject: * --- clj/webdav.clj | 159 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 159 insertions(+) create mode 100644 clj/webdav.clj (limited to 'clj/webdav.clj') diff --git a/clj/webdav.clj b/clj/webdav.clj new file mode 100644 index 0000000..a2dd649 --- /dev/null +++ b/clj/webdav.clj @@ -0,0 +1,159 @@ +;; from https://gist.github.com/jackrusher/af3528564355691dda9db327cd2b185d +; To try it out on MacOS: + +; - download it +; - bb webdav.clj +; - use ⌘-K in Finder to connect to localhost:8080 (any username and password you like, it doesn't matter) +; +; The filesystem will be mounted at: +; /Volumes/localhost + +(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.util.Date.)] + (atom {:ctime now :mtime now}))) + +(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.util.Date.) 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.util.Date.) new-path)))) + (delete-file old-path)) + +(defn mkdir [path] + (update-path-timestamps (java.util.Date.) path)) + +(defn date->str + "The only date format I'm sure works with WebDAV." + [d] + (.format (java.text.SimpleDateFormat. "E, dd MMM yyyy H:m:s z") d)) + +(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 (date->str (:mtime 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 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" "2"}} + :propfind {:body (xml/indent-str + (xml/sexp-as-element + (if (:content file) ; is a plain file + [::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 {:body (:content file) + :headers {"Content-Length" (str (count (:content file)))}} ; TODO content-type! + ;; overwrite existing file + :put (do (if (nil? (:body req)) + (byte-array 0) + (.readAllBytes (:body req))) + {: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 -- cgit 1.4.1-2-gfad0