diff --git a/Database/MongoDB.hs b/Database/MongoDB.hs index cd3161b..22e4715 100644 --- a/Database/MongoDB.hs +++ b/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, diff --git a/Database/MongoDB/BSON.hs b/Database/MongoDB/BSON.hs index b8bfb5a..9eb2451 100644 --- a/Database/MongoDB/BSON.hs +++ b/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 diff --git a/Database/MongoDB/Util.hs b/Database/MongoDB/Util.hs index a67c712..a187cab 100644 --- a/Database/MongoDB/Util.hs +++ b/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