1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
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
|