Vergara_Tech/mongodb
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

use what appears to be more standard naming, eg BsonValue instead of BSValue

Browse source
This commit is contained in:
Scott R. Parish 2010-01-17 11:41:24 -06:00
parent 7f777c8fb4
commit 4cfd4e7fa3
2 changed files with 101 additions and 101 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
Database/MongoDB.hs
View file

@ -130,8 +130,8 @@ toOpcode 2007 = OP_KILL_CURSORS
toOpcode n = throw $ MongoDBInternalError $ "Got unexpected Opcode: " ++ show n toOpcode n = throw $ MongoDBInternalError $ "Got unexpected Opcode: " ++ show n
type Collection = String type Collection = String
type Selector = BSONObject type Selector = BsonDoc
type FieldSelector = BSONObject type FieldSelector = BsonDoc
type RequestID = Int32 type RequestID = Int32
type NumToSkip = Int32 type NumToSkip = Int32
type NumToReturn = Int32 type NumToReturn = Int32
@ -171,7 +171,7 @@ delete c col sel = do
remove :: Connection -> Collection -> Selector -> IO RequestID remove :: Connection -> Collection -> Selector -> IO RequestID
remove = delete remove = delete
insert :: Connection -> Collection -> BSONObject -> IO RequestID insert :: Connection -> Collection -> BsonDoc -> IO RequestID
insert c col doc = do insert c col doc = do
let body = runPut $ do let body = runPut $ do
putI32 0 putI32 0
@ -181,7 +181,7 @@ insert c col doc = do
L.hPut (cHandle c) msg L.hPut (cHandle c) msg
return reqID return reqID
insertMany :: Connection -> Collection -> [BSONObject] -> IO RequestID insertMany :: Connection -> Collection -> [BsonDoc] -> IO RequestID
insertMany c col docs = do insertMany c col docs = do
let body = runPut $ do let body = runPut $ do
putI32 0 putI32 0
@ -198,11 +198,11 @@ find c col sel = query c col [] 0 0 sel Nothing
{- | Perform a query and return the result as a lazy list. Be sure to {- | Perform a query and return the result as a lazy list. Be sure to
understand the comments about using the lazy list given for 'allDocs'. -} understand the comments about using the lazy list given for 'allDocs'. -}
quickFind :: Connection -> Collection -> Selector -> IO [BSONObject] quickFind :: Connection -> Collection -> Selector -> IO [BsonDoc]
quickFind c col sel = find c col sel >>= allDocs quickFind c col sel = find c col sel >>= allDocs
{- | Perform a query and return the result as a strict list. -} {- | Perform a query and return the result as a strict list. -}
quickFind' :: Connection -> Collection -> Selector -> IO [BSONObject] quickFind' :: Connection -> Collection -> Selector -> IO [BsonDoc]
quickFind' c col sel = find c col sel >>= allDocs' quickFind' c col sel = find c col sel >>= allDocs'
query :: Connection -> Collection -> [QueryOpt] -> NumToSkip -> NumToReturn -> query :: Connection -> Collection -> [QueryOpt] -> NumToSkip -> NumToReturn ->
@ -240,7 +240,7 @@ query c col opts nskip ret sel fsel = do
} }
update :: Connection -> Collection -> update :: Connection -> Collection ->
[UpdateFlag] -> Selector -> BSONObject -> IO RequestID [UpdateFlag] -> Selector -> BsonDoc -> IO RequestID
update c col flags sel obj = do update c col flags sel obj = do
let body = runPut $ do let body = runPut $ do
putI32 0 putI32 0
@ -290,7 +290,7 @@ getReply h = do
{- | Return one document or Nothing if there are no more. {- | Return one document or Nothing if there are no more.
Automatically closes the curosr when last document is read -} Automatically closes the curosr when last document is read -}
nextDoc :: Cursor -> IO (Maybe BSONObject) nextDoc :: Cursor -> IO (Maybe BsonDoc)
nextDoc cur = do nextDoc cur = do
closed <- readIORef $ curClosed cur closed <- readIORef $ curClosed cur
case closed of case closed of
@ -319,7 +319,7 @@ If you don't consume to the end of the list, you must manually close
the cursor or you will leak the cursor, which may also leak on the the cursor or you will leak the cursor, which may also leak on the
database side. database side.
-} -}
allDocs :: Cursor -> IO [BSONObject] allDocs :: Cursor -> IO [BsonDoc]
allDocs cur = unsafeInterleaveIO $ do allDocs cur = unsafeInterleaveIO $ do
doc <- nextDoc cur doc <- nextDoc cur
case doc of case doc of
@ -329,20 +329,20 @@ allDocs cur = unsafeInterleaveIO $ do
{- | Returns a strict list of all (of the rest) of the documents in {- | Returns a strict list of all (of the rest) of the documents in
the cursor. This means that all of the documents will immediately be the cursor. This means that all of the documents will immediately be
read out of the database and loaded into memory. -} read out of the database and loaded into memory. -}
allDocs' :: Cursor -> IO [BSONObject] allDocs' :: Cursor -> IO [BsonDoc]
allDocs' cur = do allDocs' cur = do
doc <- nextDoc cur doc <- nextDoc cur
case doc of case doc of
Nothing -> return [] Nothing -> return []
Just d -> allDocs' cur >>= return . (d :) Just d -> allDocs' cur >>= return . (d :)
getFirstDoc :: L.ByteString -> (BSONObject, L.ByteString) getFirstDoc :: L.ByteString -> (BsonDoc, L.ByteString)
getFirstDoc docBytes = flip runGet docBytes $ do getFirstDoc docBytes = flip runGet docBytes $ do
doc <- get doc <- get
docBytes' <- getRemainingLazyByteString docBytes' <- getRemainingLazyByteString
return (doc, docBytes') return (doc, docBytes')
getMore :: Cursor -> IO (Maybe BSONObject) getMore :: Cursor -> IO (Maybe BsonDoc)
getMore cur = do getMore cur = do
let h = cHandle $ curCon cur let h = cHandle $ curCon cur

178
Database/MongoDB/BSON.hs
View file

@ -25,9 +25,9 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
module Database.MongoDB.BSON module Database.MongoDB.BSON
( (
BSValue(..), BsonValue(..),
BSONObject(..), BsonDoc(..),
toBSONObject, toBsonDoc,
BinarySubType(..) BinarySubType(..)
) )
where where
@ -45,32 +45,32 @@ import qualified Data.List as List
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Database.MongoDB.Util import Database.MongoDB.Util
data BSValue data BsonValue
= BSDouble Double = BsonDouble Double
| BSString L8.ByteString | BsonString L8.ByteString
| BSObject BSONObject | BsonObject BsonDoc
| BSArray [BSValue] | BsonArray [BsonValue]
| BSUndefined | BsonUndefined
| BSBinary BinarySubType L.ByteString | BsonBinary BinarySubType L.ByteString
| BSObjectId L.ByteString | BsonObjectId L.ByteString
| BSBool !Bool | BsonBool !Bool
| BSDate POSIXTime | BsonDate POSIXTime
| BSNull | BsonNull
| BSRegex L8.ByteString String | BsonRegex L8.ByteString String
| BSSymbol L8.ByteString | BsonSymbol L8.ByteString
| BSInt32 Int32 | BsonInt32 Int32
| BSInt64 Int64 | BsonInt64 Int64
| BSMinKey | BsonMinKey
| BSMaxKey | BsonMaxKey
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
newtype BSONObject = BSONObject { newtype BsonDoc = BsonDoc {
fromBSONObject :: Map.Map L8.ByteString BSValue fromBsonDoc :: Map.Map L8.ByteString BsonValue
} }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
toBSONObject :: [(L8.ByteString, BSValue)] -> BSONObject toBsonDoc :: [(L8.ByteString, BsonValue)] -> BsonDoc
toBSONObject = BSONObject . Map.fromList toBsonDoc = BsonDoc . Map.fromList
data DataType = data DataType =
Data_min_key | -- -1 Data_min_key | -- -1
@ -124,51 +124,51 @@ fromBinarySubType :: BinarySubType -> Int
fromBinarySubType BSTUserDefined = 0x80 fromBinarySubType BSTUserDefined = 0x80
fromBinarySubType d = fromEnum d fromBinarySubType d = fromEnum d
instance Binary BSONObject where instance Binary BsonDoc where
get = liftM snd getObj get = liftM snd getDoc
put = putObj put = putObj
getVal :: DataType -> Get (Integer, BSValue) getVal :: DataType -> Get (Integer, BsonValue)
getVal Data_number = getFloat64le >>= return . (,) 8 . BSDouble getVal Data_number = getFloat64le >>= return . (,) 8 . BsonDouble
getVal Data_string = do getVal Data_string = do
sLen1 <- getI32 sLen1 <- getI32
(_sLen2, s) <- getS (_sLen2, s) <- getS
return (fromIntegral $ 4 + sLen1, BSString s) return (fromIntegral $ 4 + sLen1, BsonString s)
getVal Data_object = getObj >>= \(len, obj) -> return (len, BSObject obj) getVal Data_object = getDoc >>= \(len, obj) -> return (len, BsonObject obj)
getVal Data_array = do getVal Data_array = do
(len, arr) <- getRawObj (len, arr) <- getRawObj
let arr2 = Map.fold (:) [] arr -- reverse and remove key let arr2 = Map.fold (:) [] arr -- reverse and remove key
return (len, BSArray arr2) return (len, BsonArray arr2)
getVal Data_binary = do getVal Data_binary = do
skip 4 skip 4
st <- getI8 st <- getI8
len2 <- getI32 len2 <- getI32
bs <- getLazyByteString $ fromIntegral len2 bs <- getLazyByteString $ fromIntegral len2
return (4 + 1 + 4 + fromIntegral len2, BSBinary (toBinarySubType st) bs) return (4 + 1 + 4 + fromIntegral len2, BsonBinary (toBinarySubType st) bs)
getVal Data_undefined = return (1, BSUndefined) getVal Data_undefined = return (1, BsonUndefined)
getVal Data_oid = getLazyByteString 12 >>= return . (,) 12 . BSObjectId getVal Data_oid = getLazyByteString 12 >>= return . (,) 12 . BsonObjectId
getVal Data_boolean = getVal Data_boolean =
getI8 >>= return . (,) (1::Integer) . BSBool . (/= (0::Int)) getI8 >>= return . (,) (1::Integer) . BsonBool . (/= (0::Int))
getVal Data_date = getVal Data_date =
getI64 >>= return . (,) 8 . BSDate . flip (/) 1000 . realToFrac getI64 >>= return . (,) 8 . BsonDate . flip (/) 1000 . realToFrac
getVal Data_null = return (1, BSNull) getVal Data_null = return (1, BsonNull)
getVal Data_regex = fail "Data_code not yet supported" -- TODO getVal Data_regex = fail "Data_code not yet supported" -- TODO
getVal Data_ref = fail "Data_ref is deprecated" getVal Data_ref = fail "Data_ref is deprecated"
getVal Data_code = fail "Data_code not yet supported" -- TODO getVal Data_code = fail "Data_code not yet supported" -- TODO
getVal Data_symbol = do getVal Data_symbol = do
sLen1 <- getI32 sLen1 <- getI32
(_sLen2, s) <- getS (_sLen2, s) <- getS
return (fromIntegral $ 4 + sLen1, BSString s) return (fromIntegral $ 4 + sLen1, BsonString s)
getVal Data_code_w_scope = fail "Data_code_w_scope not yet supported" -- TODO getVal Data_code_w_scope = fail "Data_code_w_scope not yet supported" -- TODO
getVal Data_int = getI32 >>= return . (,) 4 . BSInt32 . fromIntegral getVal Data_int = getI32 >>= return . (,) 4 . BsonInt32 . fromIntegral
getVal Data_timestamp = fail "Data_timestamp not yet supported" -- TODO getVal Data_timestamp = fail "Data_timestamp not yet supported" -- TODO
getVal Data_long = getI64 >>= return . (,) 8 . BSInt64 getVal Data_long = getI64 >>= return . (,) 8 . BsonInt64
getVal Data_min_key = return (0, BSMinKey) getVal Data_min_key = return (0, BsonMinKey)
getVal Data_max_key = return (0, BSMaxKey) getVal Data_max_key = return (0, BsonMaxKey)
getInnerObj :: Int32 -> Get (Map.Map L8.ByteString BSValue) getInnerObj :: Int32 -> Get (Map.Map L8.ByteString BsonValue)
-> Get (Map.Map L8.ByteString BSValue) -> Get (Map.Map L8.ByteString BsonValue)
getInnerObj 1 obj = obj getInnerObj 1 obj = obj
getInnerObj bytesLeft obj = do getInnerObj bytesLeft obj = do
typ <- getDataType typ <- getDataType
@ -177,70 +177,70 @@ getInnerObj bytesLeft obj = do
getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $ getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $
liftM (Map.insert key val) obj liftM (Map.insert key val) obj
getRawObj :: Get (Integer, Map.Map L8.ByteString BSValue) getRawObj :: Get (Integer, Map.Map L8.ByteString BsonValue)
getRawObj = do getRawObj = do
bytes <- getI32 bytes <- getI32
obj <- getInnerObj (bytes - 4) $ return Map.empty obj <- getInnerObj (bytes - 4) $ return Map.empty
getNull getNull
return (fromIntegral bytes, obj) return (fromIntegral bytes, obj)
getObj :: Get (Integer, BSONObject) getDoc :: Get (Integer, BsonDoc)
getObj = getRawObj >>= \(len, obj) -> return (len, BSONObject obj) getDoc = getRawObj >>= \(len, obj) -> return (len, BsonDoc obj)
getDataType :: Get DataType getDataType :: Get DataType
getDataType = liftM toDataType getI8 getDataType = liftM toDataType getI8
putType :: BSValue -> Put putType :: BsonValue -> Put
putType BSDouble{} = putDataType Data_number putType BsonDouble{} = putDataType Data_number
putType BSString{} = putDataType Data_string putType BsonString{} = putDataType Data_string
putType BSObject{} = putDataType Data_object putType BsonObject{} = putDataType Data_object
putType BSArray{} = putDataType Data_array putType BsonArray{} = putDataType Data_array
putType BSBinary{} = putDataType Data_binary putType BsonBinary{} = putDataType Data_binary
putType BSUndefined = putDataType Data_undefined putType BsonUndefined = putDataType Data_undefined
putType BSObjectId{} = putDataType Data_oid putType BsonObjectId{} = putDataType Data_oid
putType BSBool{} = putDataType Data_boolean putType BsonBool{} = putDataType Data_boolean
putType BSDate{} = putDataType Data_date putType BsonDate{} = putDataType Data_date
putType BSNull = putDataType Data_null putType BsonNull = putDataType Data_null
putType BSRegex{} = putDataType Data_regex putType BsonRegex{} = putDataType Data_regex
-- putType = putDataType Data_ref -- putType = putDataType Data_ref
-- putType = putDataType Data_code -- putType = putDataType Data_code
putType BSSymbol{} = putDataType Data_symbol putType BsonSymbol{} = putDataType Data_symbol
-- putType = putDataType Data_code_w_scope -- putType = putDataType Data_code_w_scope
putType BSInt32 {} = putDataType Data_int putType BsonInt32 {} = putDataType Data_int
putType BSInt64 {} = putDataType Data_long putType BsonInt64 {} = putDataType Data_long
-- putType = putDataType Data_timestamp -- putType = putDataType Data_timestamp
putType BSMinKey = putDataType Data_min_key putType BsonMinKey = putDataType Data_min_key
putType BSMaxKey = putDataType Data_max_key putType BsonMaxKey = putDataType Data_max_key
putVal :: BSValue -> Put putVal :: BsonValue -> Put
putVal (BSDouble d) = putFloat64le d putVal (BsonDouble d) = putFloat64le d
putVal (BSString s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s putVal (BsonString s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
putVal (BSObject o) = putObj o putVal (BsonObject o) = putObj o
putVal (BSArray es) = putOutterObj bs putVal (BsonArray es) = putOutterObj bs
where bs = runPut $ forM_ (List.zip [(0::Int) .. ] es) $ \(i, e) -> where bs = runPut $ forM_ (List.zip [(0::Int) .. ] es) $ \(i, e) ->
putType e >> (putS $ L8.fromString $ show i) >> putVal e putType e >> (putS $ L8.fromString $ show i) >> putVal e
putVal (BSBinary t bs)= do putI32 $ fromIntegral $ 4 + L.length bs putVal (BsonBinary t bs)= do putI32 $ fromIntegral $ 4 + L.length bs
putI8 $ fromBinarySubType t putI8 $ fromBinarySubType t
putI32 $ fromIntegral $ L.length bs putI32 $ fromIntegral $ L.length bs
putLazyByteString bs putLazyByteString bs
putVal BSUndefined = putNothing putVal BsonUndefined = putNothing
putVal (BSObjectId o) = putLazyByteString o putVal (BsonObjectId o) = putLazyByteString o
putVal (BSBool False) = putI8 (0::Int) putVal (BsonBool False) = putI8 (0::Int)
putVal (BSBool True) = putI8 (1::Int) putVal (BsonBool True) = putI8 (1::Int)
putVal (BSDate pt) = putI64 $ round $ 1000 * (realToFrac pt :: Double) putVal (BsonDate pt) = putI64 $ round $ 1000 * (realToFrac pt :: Double)
putVal BSNull = putNothing putVal BsonNull = putNothing
putVal (BSRegex r opt)= do putS r putVal (BsonRegex r opt)= do putS r
putByteString $ pack $ List.sort opt putByteString $ pack $ List.sort opt
putNull putNull
putVal (BSSymbol s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s putVal (BsonSymbol s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
putVal (BSInt32 i) = putI32 i putVal (BsonInt32 i) = putI32 i
putVal (BSInt64 i) = putI64 i putVal (BsonInt64 i) = putI64 i
putVal BSMinKey = putNothing putVal BsonMinKey = putNothing
putVal BSMaxKey = putNothing putVal BsonMaxKey = putNothing
putObj :: BSONObject -> Put putObj :: BsonDoc -> Put
putObj obj = putOutterObj bs putObj obj = putOutterObj bs
where bs = runPut $ forM_ (Map.toList (fromBSONObject obj)) $ \(k, v) -> where bs = runPut $ forM_ (Map.toList (fromBsonDoc obj)) $ \(k, v) ->
putType v >> putS k >> putVal v putType v >> putS k >> putVal v
putOutterObj :: L.ByteString -> Put putOutterObj :: L.ByteString -> Put