added whereClause, tidied code

Database/MongoDB.hs

@@ -46,6 +46,8 @@ module Database.MongoDB
      save, 
      -- * Convenience collection operations
      find, findOne, quickFind, quickFind',
+     -- * Query Helpers
+     whereClause,
      -- * Cursor
      Cursor,
      allDocs, allDocs', finish, nextDoc,
@@ -82,7 +84,9 @@ import System.IO.Unsafe
 import System.Random
 
 -- | A list of handles to database connections
-data Connection = Connection { cHandles :: [Handle], cIndex :: IORef Int, cRand :: IORef [Int] }
+data Connection = Connection { cHandles :: [Handle]
+                              ,cIndex :: IORef Int
+                              ,cRand :: IORef [Int] }
 
 -- | Establish a connection to a MongoDB server
 connect :: HostName -> IO Connection
@@ -542,33 +546,48 @@ update c col flags sel obj = do
   cPut c msg
   return reqID
 
+-- | log into the mongodb /Database/ attached to the /Connection/
 login :: Connection -> Database -> String -> String -> IO BsonDoc 
 login c db user pass = do
   doc <- runCommand c db (toBsonDoc [("getnonce", toBson (1 :: Int))])
   let nonce = fromBson $ fromLookup $ BSON.lookup "nonce" doc :: String
-      digest = md5sum $ pack $ nonce ++ user ++ ( md5sum $ pack (user ++ ":mongo:" ++ pass)) 
+      digest = md5sum $ pack $ nonce ++ user ++ 
+                 ( md5sum $ pack (user ++ ":mongo:" ++ pass)) 
       request = toBsonDoc [("authenticate", toBson (1 :: Int)), 
                            ("user", toBson user), 
                            ("nonce", toBson nonce), 
                            ("key", toBson digest)]
       in runCommand c db request
 
-addUser :: Connection -> String -> String -> String -> IO BsonDoc
+-- | create a new user in the current /Database/
+addUser :: Connection -> Database -> String -> String -> IO BsonDoc
 addUser c db user pass = do
   let userDoc = toBsonDoc [(s2L"user", toBson user)]
-      fdb = s2L (db ++ ".system.users")  
+      fdb = L.append db (s2L ".system.users")  
   doc <- liftM (maybe userDoc id) (findOne c fdb userDoc)
-  let doc' = Map.insert (s2L "pwd") (toBson ( md5sum $ pack (user ++ ":mongo:" ++ pass))) doc
+  let doc' = Map.insert (s2L "pwd") 
+               (toBson ( md5sum $ pack (user ++ ":mongo:" ++ pass))) doc
   _ <- save c fdb doc'
   return doc'
 
-
+-- | Conveniently stores the /BsonDoc/ to the /FullCollection/ 
+-- | if there is an _id present in the /BsonDoc/ then it already has 
+-- | a place in the DB, so we update it using the _id, otherwise
+-- | we insert it
 save :: Connection -> FullCollection -> BsonDoc -> IO RequestID
 save c fc doc =
   case Map.lookup (s2L "_id") doc of 
     Nothing -> insert c fc doc
     Just obj -> update c fc [UFUpsert] (toBsonDoc [("_id", obj)]) doc
-  
+
+-- | Use this in the place of the query portion of a select type query
+-- | This uses javascript and a scope supplied by a /BsonDoc/ to evaluate 
+-- | documents in the database for retrieval. 
+-- | Example: 
+-- | > findOne conn mycoll $ whereClause "this.name == (name1 + name2)" 
+-- | >     (toBsonDoc [("name1", toBson "mar"), ("name2", toBson "tha")])
+whereClause :: String -> BsonDoc -> BsonDoc
+whereClause qry scope = toBsonDoc [("$where", (BsonCodeWScope (s2L qry) scope))]
 
 data Hdr = Hdr {
       hMsgLen :: Int32,

Database/MongoDB/BSON.hs

@@ -73,6 +73,7 @@ data BsonValue
     | BsonSymbol L8.ByteString
     | BsonInt32 Int32
     | BsonInt64 Int64
+    | BsonCodeWScope L8.ByteString BsonDoc
     | BsonMinKey
     | BsonMaxKey
     deriving (Show, Eq, Ord)
@@ -195,7 +196,11 @@ getVal DataSymbol = do
   sLen1 <- getI32
   (_sLen2, s) <- getS
   return (fromIntegral $ 4 + sLen1, BsonString s)
-getVal DataCodeWScope = fail "DataCodeWScope not yet supported" -- TODO
+getVal DataCodeWScope = do
+  sLen1 <- getI32
+  (_, qry) <- getS
+  (_, scope) <- getDoc
+  return (fromIntegral sLen1, BsonCodeWScope qry scope)
 getVal DataInt = liftM ((,) 4 . BsonInt32 . fromIntegral) getI32
 getVal DataTimestamp = fail "DataTimestamp not yet supported" -- TODO
 
@@ -240,7 +245,7 @@ putType BsonRegex{}    = putDataType DataRegex
 -- putType = putDataType DataRef
 -- putType = putDataType DataCode
 putType BsonSymbol{}   = putDataType DataSymbol
--- putType = putDataType DataCodeWScope
+putType BsonCodeWScope{} = putDataType DataCodeWScope
 putType BsonInt32 {}   = putDataType DataInt
 putType BsonInt64 {}   = putDataType DataLong
 -- putType = putDataType DataTimestamp
@@ -249,7 +254,7 @@ putType BsonMaxKey     = putDataType DataMaxKey
 
 putVal :: BsonValue -> Put
 putVal (BsonDouble d)   = putFloat64le d
-putVal (BsonString s)   = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
+putVal (BsonString s)   = putStrSz s
 putVal (BsonObject o)   = putObj o
 putVal (BsonArray es)   = putOutterObj bs
     where bs = runPut $ forM_ (List.zip [(0::Int) .. ] es) $ \(i, e) ->
@@ -270,6 +275,9 @@ putVal (BsonRegex r opt)= do putS r
 putVal (BsonSymbol s)   = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
 putVal (BsonInt32 i)    = putI32 i
 putVal (BsonInt64 i)    = putI64 i
+putVal (BsonCodeWScope q s) =
+  let bytes = runPut (putStrSz q >> putObj s)
+    in (putI32 $ (+4) $ fromIntegral $ L.length bytes) >> putLazyByteString bytes
 putVal BsonMinKey       = putNothing
 putVal BsonMaxKey       = putNothing
 

Database/MongoDB/Util.hs

@@ -26,7 +26,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 module Database.MongoDB.Util
     (
      putI8, putI32, putI64, putNothing, putNull, putS,
-     getI8, getI32, getI64, getC, getS, getNull,
+     getI8, getI32, getI64, getC, getS, getNull, putStrSz,
     )
 where
 import Control.Exception (assert)
@@ -75,3 +75,6 @@ putNull = putI8 (0::Int)
 
 putS :: L8.ByteString -> Put
 putS s = putLazyByteString s >> putNull
+
+putStrSz :: L.ByteString -> Put
+putStrSz s = putI32 (fromIntegral $ 1 + L8.length s) >> putS s