added whereClause, tidied code

This commit is contained in:
Rick Richardson 2010-02-05 08:31:01 -05:00
parent e606b1bc1f
commit 58fbd2005f
3 changed files with 41 additions and 11 deletions

View file

@ -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,

View file

@ -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

View file

@ -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