path: root/clj/webdav.clj

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