inital import of webdav client

project.clj

@@ -0,0 +1,16 @@
+(defproject de.mpg.shh/webdav "0.0.1"
+  :description "LIMS for ssh"
+  :url "http://www.shh.mpg.de/"
+  :license {:name "Eclipse Public License"
+            :url "http://www.eclipse.org/legal/epl-v10.html"}
+  :dependencies [[org.clojure/clojure "1.8.0"]
+                 [org.clojure/tools.logging "0.3.1"]
+                 [org.apache.logging.log4j/log4j-api "2.5"]
+                 [org.apache.logging.log4j/log4j-core "2.5"]
+                 [org.apache.logging.log4j/log4j-1.2-api "2.5"]
+                 [org.slf4j/slf4j-log4j12 "1.6.4"]
+                 [com.github.lookfirst/sardine "5.7"]]
+  :source-paths ["src/main/clojure"]
+  :profiles {:test {:test-paths ["src/test/clojure"]
+                    :resource-paths ["test-resources"]
+                    :dependencies [[de.mpg.shh/util-properties "0.0.1"]]}})

src/main/clojure/de/mpg/shh/util_webdav/client.clj

@@ -0,0 +1,213 @@
+(ns de.mpg.shh.util-webdav.client
+  (require [clojure.tools.logging :refer [info error]]
+           [clojure.string :as str]
+           [clojure.edn :as edn])
+  (import [java.util Collections]
+          [java.nio.file Files]
+          [java.io ByteArrayInputStream]
+          [org.apache.http.conn.ssl SSLContextBuilder]
+          [org.apache.http.impl.client HttpClients]
+          [com.github.sardine.impl SardineImpl SardineException SardineRedirectStrategy]
+          [com.github.sardine.util SardineUtil]
+          [javax.xml.namespace QName]))
+
+(defn- file-to-byte-array
+  "Converts a java.io.File to a byte[]"
+  [file]
+  (Files/readAllBytes (.toPath file)))
+
+(defn- http-ns->attr-ns
+  [n-space]
+  (-> (if-let [protocol (re-find #"^[a-zA-Z]+:/{0,2}" n-space)]
+        (subs n-space (count protocol))
+        n-space)
+      (str/replace #"/$" "")
+      (str/replace #"/" ".")))
+
+(defn- qname->keyword
+  [^QName qname]
+  (keyword (str (-> qname (.getNamespaceURI) http-ns->attr-ns) "/" (.getLocalPart qname))))
+
+(defn- apache-prop->val
+  [ap]
+  (get {"F" false
+        "T" true} ap ap))
+
+(defn- extract-properties
+  [accumulator [k v]]
+  (let [q-ns (.getNamespaceURI k)
+        q-local-part (.getLocalPart k)]
+    (cond
+      (= q-ns "http://apache.org/dav/props/")
+      (assoc-in accumulator [:props (qname->keyword k)] (apache-prop->val v))
+      (= q-ns SardineUtil/CUSTOM_NAMESPACE_URI)
+      (update accumulator :custom conj [q-local-part (if (re-matches #"^de\.mpg\.shh\.webdav\.(?:key|value)\.[0-9]+" q-local-part)
+                                                       (edn/read-string v)
+                                                       v)])
+      :else (assoc accumulator k v))))
+
+(defn- sort-on-kv-num
+  [kv-name]
+  (-> kv-name first (str/split #"\.") last Long/valueOf))
+
+
+(defn- gather-custom-props
+  [custom-props]
+  (zipmap (->> custom-props
+               (filter #(re-matches #"^de\.mpg\.shh\.webdav\.key\.[0-9]+" (first %)))
+               (sort-by sort-on-kv-num)
+               (map second))
+          (->> custom-props
+               (filter #(re-matches #"^de\.mpg\.shh\.webdav\.value\.[0-9]+" (first %)))
+               (sort-by sort-on-kv-num)
+               (map second))))
+
+(defn- extract-dav-resource
+  [dav-resource]
+  ;;(info "extract-dav-resource .getCustomProps: " (pr-str (.getCustomProps dav-resource)))
+  ;;(info "extract-dav-resource .getCustomPropsNS: " (pr-str (.getCustomPropsNS dav-resource)))
+  (let [gathered-props (reduce extract-properties {:custom [] :props {}} (.getCustomPropsNS dav-resource))
+        custom-props (gather-custom-props (:custom gathered-props))]
+    {:file-name (.getName dav-resource)
+     :path (.getPath dav-resource)
+     :dir? (.isDirectory dav-resource)
+     :content-type (.getContentType dav-resource)
+     :content-length (.getContentLength dav-resource)
+     :modified (.getModified dav-resource)
+     :created (.getCreation dav-resource)
+     :properties (merge (:props gathered-props) custom-props)}))
+
+(defn conn [opts]
+  (let [sardine (SardineImpl. (:user-name opts) (:password opts))
+        ;;_ (info "sardine: " sardine)
+        conn {:sardine sardine
+              :base-url (:base-url opts)}]
+    conn))
+
+(defn get-file
+  [{sardine :sardine
+    base-url :base-url} file-path]
+  (let [url (str/join "/" [base-url file-path])]
+    (try
+      (-> sardine (.get url))
+      (catch SardineException se
+        (throw (ex-info "Failed to fetch file" {:cause (.getMessage se)}))))))
+
+(defn list-dir
+  [{sardine :sardine
+    base-url :base-url}
+   file-path]
+  (let [url (str/join "/" [base-url file-path])]
+    (try
+      (map extract-dav-resource (-> sardine (.list url 1)))
+      (catch SardineException se
+        (throw (ex-info "Failed to list file" {:cause (.getMessage se)}))))))
+
+(defn list-file
+  [{sardine :sardine
+    base-url :base-url}
+   file-path]
+  (let [url (str/join "/" [base-url file-path])]
+    (try
+      (map extract-dav-resource (-> sardine (.list url 0)))
+      (catch SardineException se
+        (throw (ex-info "Failed to list file" {:cause (.getMessage se)}))))))
+
+(defn put-file
+  [{sardine :sardine
+    base-url :base-url}
+   file
+   file-path]
+  (let [url (str/join "/" [base-url file-path])
+        ba (file-to-byte-array file)]
+    (try
+      (-> sardine (.put url ba))
+      (catch SardineException se
+        (throw (ex-info "Failed to put file" {:cause (.getMessage se)}))))))
+
+(defn put-stream
+  [{sardine :sardine
+    base-url :base-url}
+   i-stream
+   file-path]
+  (let [url (str/join "/" [base-url file-path])]
+    (try
+      (-> sardine (.put url i-stream))
+      (catch SardineException se
+        (throw (ex-info "Failed to put stream" {:cause (.getMessage se)}))))))
+
+(defn delete-file
+  [{sardine :sardine
+    base-url :base-url}
+   file-path]
+  (let [url (str/join "/" [base-url file-path])]
+    (try
+      (-> sardine (.delete url))
+      (catch SardineException se
+        (throw (ex-info "Failed to delete file" {:cause (.getMessage se)}))))))
+
+(defn delete-dir
+  [{sardine :sardine
+    base-url :base-url}
+   file-path]
+  (let [url (str/join "/" [base-url file-path ""])]
+    (try
+      (-> sardine (.delete url))
+      (catch SardineException se
+        (throw (ex-info "Failed to delete file" {:cause (.getMessage se)}))))))
+
+(defn create-directory
+    [{sardine :sardine
+    base-url :base-url}
+   file-path]
+  (let [url (str/join "/" [base-url file-path])]
+    (try
+      (-> sardine (.createDirectory url))
+      (catch SardineException se
+        (throw (ex-info "Failed to create directory" {:cause (.getMessage se)}))))))
+
+(defn prop->sardine
+  [accumulator [k v]]
+  (let [qname-key (SardineUtil/createQNameWithCustomNamespace (str "de.mpg.shh.webdav.key." (count accumulator)))
+        qname-value (SardineUtil/createQNameWithCustomNamespace (str "de.mpg.shh.webdav.value." (count accumulator)))
+        element-key (SardineUtil/createElement qname-key)
+        _ (.setTextContent element-key (pr-str k))
+        element-value (SardineUtil/createElement qname-value)
+        _ (.setTextContent element-value (pr-str v))]
+    (conj accumulator element-key element-value)))
+
+(defn assoc-props
+  [{sardine :sardine
+    base-url :base-url}
+   file-path
+   props]
+  (let [url (str/join "/" [base-url file-path])
+        sardine-props (reduce prop->sardine [] props)]
+    (try
+      (map extract-dav-resource (-> sardine (.patch url sardine-props (Collections/emptyList))))
+      (catch SardineException se
+        (throw (ex-info "Failed to add props" {:cause (.getMessage se)}))))))
+
+(defn- filter-custom-keys
+  [[k v]]
+  (let [q-ns (.getNamespaceURI k)
+        q-local-part (.getLocalPart k)]
+    (and (= q-ns SardineUtil/CUSTOM_NAMESPACE_URI)
+         (re-matches #"^de\.mpg\.shh\.webdav\.key\.[0-9]+" q-local-part))))
+
+(defn- extract-custom-key
+  [[k v]]
+  [(edn/read-string v) (.getLocalPart k)])
+
+(defn dissoc-props
+  [{sardine :sardine
+    base-url :base-url}
+   file-path
+   prop-key-set]
+  (let [url (str/join "/" [base-url file-path])]
+    (try
+      (let [current-key-lookup (into {} (map extract-custom-key (filter filter-custom-keys (-> sardine (.list url 0) first (.getCustomPropsNS)))))
+            dissoc-qnames (map #(SardineUtil/createQNameWithCustomNamespace %) (vals (select-keys current-key-lookup prop-key-set)))]
+        (-> sardine (.patch url (Collections/emptyMap) dissoc-qnames)))
+      (catch SardineException se
+        (throw (ex-info "Failed to add props" {:cause (.getMessage se)}))))))