Add initial support for GridFS with new fns insert-file!, fetch-files…

…, destroy-file! etc.

Implementation notes:

This is the bare minimum code to get data in and out of GridFS.

The collections that back GridFS internally use an ObjectClass of
GridFSDBFile, so the regular ClojureDBObject hack can't be used to get
painless coercion. To reuse the fast conversion code in
ClojureDBObject for this purpose, I've made public the static method
ClojureDBObject/toClojureMap. The :gridfs hint for 'coerce' seemed less
messy than leaking another function into congomongo.clj.

Some reflection will probably be used in insert-file! and
write-file-to, but this seems preferable than repeating the list of
possible argument types for the wrapped overloaded methods.

There's no atomic update support in GridFS, but an update-file! fn can
be written, together with wrappers for other GridFS functionality,
such as listing all files in a bucket.

The Java GridFS implementation curiously leaves the uploadDate
attribute of files blank by default, in addition to the contentType
field. It may be desirable to fill those fields in congomongo, but I
haven't done that at this stage.

src/clj/somnium/congomongo.clj

@@ -28,6 +28,7 @@
             [clojure.contrib.json read write])
   (:import  [com.mongodb Mongo DB DBCollection DBObject]
             [com.mongodb.util JSON]
+            [com.mongodb.gridfs GridFS]
             [somnium.congomongo ClojureDBObject]))
 
 (defunk mongo!
@@ -181,7 +182,70 @@
   (.getCollectionNames #^DB (:db @*mongo-config*)))
 
 (defn drop-coll!
-  [collection]
   "Permanently deletes a collection. Use with care."
+  [collection]
   (.drop #^DBCollection (.getCollection #^DB (:db @*mongo-config*)
-                                        #^String (named collection))))
+                                        #^String (named collection))))
+
+;;; GridFS
+
+
+(definline get-gridfs
+  "Returns a GridFS object for the named bucket"
+  [bucket]
+  `(GridFS. #^DB (:db @*mongo-config*) #^String (named ~bucket)))
+
+;; The naming of :contentType is ugly, but consistent with that
+;; returned by GridFSFile
+(defunk insert-file!
+  "Insert file data into a GridFS. Data should be either a File,
+   InputStream or byte array.
+   Options include:
+   :filename    -> defaults to nil
+   :contentType -> defaults to nil
+   :metadata    -> defaults to nil"
+  {:arglists '(fs data {:filename nil :contentType nil :metadata nil})}
+  [fs data :filename nil :contentType nil :metadata nil]
+  (let [f (.createFile (get-gridfs fs) data)]
+    (if filename (.setFilename f filename))
+    (if contentType (.setContentType f contentType))
+    (if metadata (.putAll (.getMetaData f) (coerce metadata [:clojure :mongo])))
+    (.save f)
+    (coerce f [:gridfs :clojure])))
+
+(defunk destroy-file!
+   "Removes file from gridfs. Takes a GridFS name and
+    a query map"
+   {:arglists '(fs where {:from :clojure})}
+   [fs q :from :clojure]
+   (.remove (get-gridfs fs)
+            #^DBObject (coerce q [from :mongo])))
+
+(defunk fetch-files
+  "Fetches objects from a GridFS
+   Note that MongoDB always adds the _id and _ns
+   fields to objects returned from the database.
+   Optional arguments include
+   :where  -> takes a query map
+   :from   -> argument type, same options as above
+   :one?   -> defaults to false, use fetch-one-file as a shortcut"
+  {:arglists
+   '([fs :where :from :one?])}
+  [fs :where {} :from :clojure :one? false]
+  (let [n-where (coerce where [from :mongo])
+        n-fs   (get-gridfs fs)]
+    (if one?
+      (if-let [m (.findOne #^GridFS n-fs #^DBObject n-where)]
+        (coerce m [:gridfs :clojure]) nil)
+      (if-let [m (.find #^GridFS n-fs #^DBObject n-where)]
+        (coerce m [:gridfs :clojure] :many true) nil))))
+
+(defn fetch-one-file [fs & options]
+  (apply fetch-files fs (concat options '[:one? true])))
+
+(defn write-file-to
+  "Writes the data stored for a file to the supplied output, which
+   should be either an OutputStream, File, or the String path for a file."
+  [fs file out]
+  (if-let [f (.findOne (get-gridfs fs) (coerce file [:clojure :mongo]))]
+    (.writeTo f out)))

src/clj/somnium/congomongo/coerce.clj

@@ -5,13 +5,35 @@
         [clojure.contrib.core :only [seqable?]])
   (:import [somnium.congomongo ClojureDBObject]
            [clojure.lang IPersistentMap]
+           [com.mongodb DBObject]
+           [com.mongodb.gridfs GridFSFile]
            [com.mongodb.util JSON]))
 
 (defvar *keywordize* true
   "Set this to false to prevent ClojureDBObject from setting string keys to keywords")
 
-(defunk 
-  coerce
+
+(defn- dbobject->clojure
+  "Not every DBObject returned from Mongo is a ClojureDBObject,
+   since we can't setObjectClass on the collections used to back GridFS;
+   those collections have GridFSDBFile as their object class.
+
+   This function uses ClojureDBObject to marshal such DBObjects
+   into Clojure structures; in practice, this applies only to GridFSFile
+   and its subclasses."
+  [#^DBObject f keywordize]
+  (ClojureDBObject/toClojureMap
+   (try (.toMap f)
+        ;; DBObject provides .toMap, but the implementation in
+        ;; subclass GridFSFile unhelpfully throws
+        ;; UnsupportedOperationException
+        (catch UnsupportedOperationException e
+          (let [keys (.keySet f)]
+            (zipmap keys (map #(.get f %) keys)))))
+   keywordize))
+
+
+(defunk coerce
   {:arglists '([obj [:from :to] {:many false}])
    :doc
    "takes an object, a vector of keywords:
@@ -28,6 +50,7 @@
               [:mongo   :clojure] #(.toClojure #^ClojureDBObject %
                                                #^Boolean/TYPE *keywordize*)
               [:mongo   :json   ] #(.toString #^ClojureDBObject %)
+              [:gridfs  :clojure] #(dbobject->map #^GridFSFile %)
               [:json    :clojure] #(binding [*json-keyword-keys* *keywordize*] (read-json %))
               [:json    :mongo  ] #(JSON/parse %)
               :else               (throw (RuntimeException.
@@ -39,4 +62,5 @@
 (defn coerce-fields
   "only used for creating argument object for :only"
   [fields]
-  (ClojureDBObject. #^IPersistentMap (zipmap fields (repeat 1))))
+  (ClojureDBObject. #^IPersistentMap (zipmap fields (repeat 1))))
+

src/java/somnium/congomongo/ClojureDBObject.java

@@ -91,7 +91,7 @@ public IPersistentMap toClojure(boolean keywordize) {
       return toClojureMap(this, keywordize);
     }
 
-    private static IPersistentMap toClojureMap(Map m, boolean keywordize){
+    public static IPersistentMap toClojureMap(Map m, boolean keywordize){
       int msize = m.size() * 2;
       Object[] ary = new Object[msize];
       Set keys = m.keySet();

test/congomongo_test.clj

@@ -106,3 +106,36 @@
      (add-index! :points [:x])
      (is (some #(= (into {} (% "key")) {"x" 1})
                (get-indexes :points)))))
+
+(deftest gridfs-insert-and-fetch
+  (with-mongo
+    (is (empty? (fetch-files :testfs)))
+    (let [f (insert-file! :testfs (.getBytes "toasted")
+                          :filename "muffin" :contentType "food/breakfast")]
+      (is (= "muffin" (:filename f)))
+      (is (= "food/breakfast" (:contentType f)))
+      (is (= 7 (:length f)))
+      (is (= nil (fetch-one-file :testfs :where {:filename "monkey"})))
+      (is (= f (fetch-one-file :testfs :where {:filename "muffin"})))
+      (is (= f (fetch-one-file :testfs :where {:contentType "food/breakfast"})))
+      (is (= (list f) (fetch-files :testfs))))))
+
+(deftest gridfs-destroy
+  (with-mongo
+    (insert-file! :testfs (.getBytes "banana") :filename "lunch")
+    (destroy-file! :testfs {:filename "lunch"})
+    (is (empty? (fetch-files :testfs)))))
+
+(deftest gridfs-insert-with-metadata
+  (with-mongo
+    (let [f (insert-file! :testfs (.getBytes "nuts")
+                          :metadata { :calories 50, :opinion "tasty"})]
+      (is (= "tasty" (-> f :metadata :opinion)))
+      (is (= f (fetch-one-file :testfs :where { :metadata.opinion "tasty" }))))))
+
+(deftest gridfs-write-file-to
+  (with-mongo
+    (let [f (insert-file! :testfs (.getBytes "banana"))]
+      (let [o (java.io.ByteArrayOutputStream.)]
+        (write-file-to :testfs f o)
+        (is (= "banana" (str o)))))))