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

make changes suggested by HLint

Browse source
This commit is contained in:
Scott R. Parish 2010-01-24 20:58:49 -06:00
parent 5ae3c4c2ae
commit d606e47f33
2 changed files with 152 additions and 161 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

159
Database/MongoDB.hs
View file

@ -92,7 +92,7 @@ connectOnPort host port = do
let ns = randomRs (fromIntegral (minBound :: Int32), let ns = randomRs (fromIntegral (minBound :: Int32),
fromIntegral (maxBound :: Int32)) r fromIntegral (maxBound :: Int32)) r
nsRef <- newIORef ns nsRef <- newIORef ns
return $ Connection { cHandle = h, cRand = nsRef } return Connection { cHandle = h, cRand = nsRef }
-- | Close database connection -- | Close database connection
conClose :: Connection -> IO () conClose :: Connection -> IO ()
@ -100,7 +100,7 @@ conClose = hClose . cHandle
-- | Information about the databases on the server. -- | Information about the databases on the server.
databasesInfo :: Connection -> IO BsonDoc databasesInfo :: Connection -> IO BsonDoc
databasesInfo c = do databasesInfo c =
runCommand c (s2L "admin") $ toBsonDoc [("listDatabases", toBson (1::Int))] runCommand c (s2L "admin") $ toBsonDoc [("listDatabases", toBson (1::Int))]
-- | Return a list of database names on the server. -- | Return a list of database names on the server.
@ -108,7 +108,7 @@ databaseNames :: Connection -> IO [Database]
databaseNames c = do databaseNames c = do
info <- databasesInfo c info <- databasesInfo c
let (BsonArray dbs) = fromJust $ Map.lookup (s2L "databases") info let (BsonArray dbs) = fromJust $ Map.lookup (s2L "databases") info
names = catMaybes $ List.map (Map.lookup (s2L "name") . fromBson) dbs names = mapMaybe (Map.lookup (s2L "name") . fromBson) dbs
return $ List.map fromBson (names::[BsonValue]) return $ List.map fromBson (names::[BsonValue])
-- | Alias for 'conClose' -- | Alias for 'conClose'
@ -123,15 +123,14 @@ dropDatabase c db = do
-- | Get information about the MongoDB server we're connected to. -- | Get information about the MongoDB server we're connected to.
serverInfo :: Connection -> IO BsonDoc serverInfo :: Connection -> IO BsonDoc
serverInfo c = do serverInfo c =
runCommand c (s2L "admin") $ toBsonDoc [("buildinfo", toBson (1::Int))] runCommand c (s2L "admin") $ toBsonDoc [("buildinfo", toBson (1::Int))]
-- | Return a list of collections in /Database/. -- | Return a list of collections in /Database/.
collectionNames :: Connection -> Database -> IO [FullCollection] collectionNames :: Connection -> Database -> IO [FullCollection]
collectionNames c db = do collectionNames c db = do
docs <- quickFind' c (L.append db $ s2L ".system.namespaces") empty docs <- quickFind' c (L.append db $ s2L ".system.namespaces") empty
let names = flip List.map docs $ \doc -> let names = flip List.map docs $ fromBson . fromJust . BSON.lookup "name"
fromBson $ fromJust $ BSON.lookup "name" doc
return $ List.filter (L.notElem $ c2w '$') names return $ List.filter (L.notElem $ c2w '$') names
data ColCreateOpt = CCOSize Int64 -- ^ Desired initial size for the data ColCreateOpt = CCOSize Int64 -- ^ Desired initial size for the
@ -159,9 +158,8 @@ createCollection :: Connection -> FullCollection -> [ColCreateOpt] -> IO ()
createCollection c col opts = do createCollection c col opts = do
(db, col') <- validateCollectionName col (db, col') <- validateCollectionName col
dbcols <- collectionNames c db dbcols <- collectionNames c db
case col `List.elem` dbcols of when (col `List.elem` dbcols) $
True -> throwColInvalid $ "Collection already exists: " ++ show col throwColInvalid $ "Collection already exists: " ++ show col
False -> return ()
let cmd = ("create", toBson col') : List.map colCreateOptToBson opts let cmd = ("create", toBson col') : List.map colCreateOptToBson opts
_ <- runCommand c db $ toBsonDoc cmd _ <- runCommand c db $ toBsonDoc cmd
return () return ()
@ -223,10 +221,9 @@ runCommand :: Connection -> Database -> BsonDoc -> IO BsonDoc
runCommand c db cmd = do runCommand c db cmd = do
mres <- findOne c (L.append db $ s2L ".$cmd") cmd mres <- findOne c (L.append db $ s2L ".$cmd") cmd
let res = fromJust mres let res = fromJust mres
case fromBson $ fromJust $ BSON.lookup "ok" res :: Int of when (1 /= (fromBson $ fromJust $ BSON.lookup "ok" res :: Int)) $
1 -> return () throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++
_ -> throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++ fromBson (fromJust $ BSON.lookup "errmsg" res)
(fromBson $ fromJust $ BSON.lookup "errmsg" res)
return res return res
-- | An Itertaor over the results of a query. Use 'nextDoc' to get each -- | An Itertaor over the results of a query. Use 'nextDoc' to get each
@ -242,15 +239,15 @@ data Cursor = Cursor {
} }
data Opcode data Opcode
= OP_REPLY -- 1 Reply to a client request. responseTo is set = OPReply -- 1 Reply to a client request. responseTo is set
| OP_MSG -- 1000 generic msg command followed by a string | OPMsg -- 1000 generic msg command followed by a string
| OP_UPDATE -- 2001 update document | OPUpdate -- 2001 update document
| OP_INSERT -- 2002 insert new document | OPInsert -- 2002 insert new document
| OP_GET_BY_OID -- 2003 is this used? | OPGetByOid -- 2003 is this used?
| OP_QUERY -- 2004 query a collection | OPQuery -- 2004 query a collection
| OP_GET_MORE -- 2005 Get more data from a query. See Cursors | OPGetMore -- 2005 Get more data from a query. See Cursors
| OP_DELETE -- 2006 Delete documents | OPDelete -- 2006 Delete documents
| OP_KILL_CURSORS -- 2007 Tell database client is done with a cursor | OPKillCursors -- 2007 Tell database client is done with a cursor
deriving (Show, Eq) deriving (Show, Eq)
data MongoDBInternalError = MongoDBInternalError String data MongoDBInternalError = MongoDBInternalError String
@ -276,7 +273,7 @@ instance Typeable MongoDBCollectionInvalid where
instance Exception MongoDBCollectionInvalid instance Exception MongoDBCollectionInvalid
throwColInvalid :: String -> a throwColInvalid :: String -> a
throwColInvalid s = throw $ MongoDBCollectionInvalid s throwColInvalid = throw . MongoDBCollectionInvalid
data MongoDBOperationFailure = MongoDBOperationFailure String data MongoDBOperationFailure = MongoDBOperationFailure String
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
@ -290,29 +287,29 @@ instance Typeable MongoDBOperationFailure where
instance Exception MongoDBOperationFailure instance Exception MongoDBOperationFailure
throwOpFailure :: String -> a throwOpFailure :: String -> a
throwOpFailure s = throw $ MongoDBOperationFailure s throwOpFailure = throw . MongoDBOperationFailure
fromOpcode :: Opcode -> Int32 fromOpcode :: Opcode -> Int32
fromOpcode OP_REPLY = 1 fromOpcode OPReply = 1
fromOpcode OP_MSG = 1000 fromOpcode OPMsg = 1000
fromOpcode OP_UPDATE = 2001 fromOpcode OPUpdate = 2001
fromOpcode OP_INSERT = 2002 fromOpcode OPInsert = 2002
fromOpcode OP_GET_BY_OID = 2003 fromOpcode OPGetByOid = 2003
fromOpcode OP_QUERY = 2004 fromOpcode OPQuery = 2004
fromOpcode OP_GET_MORE = 2005 fromOpcode OPGetMore = 2005
fromOpcode OP_DELETE = 2006 fromOpcode OPDelete = 2006
fromOpcode OP_KILL_CURSORS = 2007 fromOpcode OPKillCursors = 2007
toOpcode :: Int32 -> Opcode toOpcode :: Int32 -> Opcode
toOpcode 1 = OP_REPLY toOpcode 1 = OPReply
toOpcode 1000 = OP_MSG toOpcode 1000 = OPMsg
toOpcode 2001 = OP_UPDATE toOpcode 2001 = OPUpdate
toOpcode 2002 = OP_INSERT toOpcode 2002 = OPInsert
toOpcode 2003 = OP_GET_BY_OID toOpcode 2003 = OPGetByOid
toOpcode 2004 = OP_QUERY toOpcode 2004 = OPQuery
toOpcode 2005 = OP_GET_MORE toOpcode 2005 = OPGetMore
toOpcode 2006 = OP_DELETE toOpcode 2006 = OPDelete
toOpcode 2007 = OP_KILL_CURSORS toOpcode 2007 = OPKillCursors
toOpcode n = throw $ MongoDBInternalError $ "Got unexpected Opcode: " ++ show n toOpcode n = throw $ MongoDBInternalError $ "Got unexpected Opcode: " ++ show n
-- | The name of a database. -- | The name of a database.
@ -354,22 +351,22 @@ type NumToSkip = Int32
type NumToReturn = Int32 type NumToReturn = Int32
-- | Options that control the behavior of a 'query' operation. -- | Options that control the behavior of a 'query' operation.
data QueryOpt = QO_TailableCursor data QueryOpt = QOTailableCursor
| QO_SlaveOK | QOSlaveOK
| QO_OpLogReplay | QOOpLogReplay
| QO_NoCursorTimeout | QONoCursorTimeout
deriving (Show) deriving (Show)
fromQueryOpts :: [QueryOpt] -> Int32 fromQueryOpts :: [QueryOpt] -> Int32
fromQueryOpts opts = List.foldl (.|.) 0 $ fmap toVal opts fromQueryOpts opts = List.foldl (.|.) 0 $ fmap toVal opts
where toVal QO_TailableCursor = 2 where toVal QOTailableCursor = 2
toVal QO_SlaveOK = 4 toVal QOSlaveOK = 4
toVal QO_OpLogReplay = 8 toVal QOOpLogReplay = 8
toVal QO_NoCursorTimeout = 16 toVal QONoCursorTimeout = 16
-- | Options that effect the behavior of a 'update' operation. -- | Options that effect the behavior of a 'update' operation.
data UpdateFlag = UF_Upsert data UpdateFlag = UFUpsert
| UF_Multiupdate | UFMultiupdate
deriving (Show, Enum) deriving (Show, Enum)
fromUpdateFlags :: [UpdateFlag] -> Int32 fromUpdateFlags :: [UpdateFlag] -> Int32
@ -396,7 +393,7 @@ delete c col sel = do
putCol col putCol col
putI32 0 putI32 0
putBsonDoc sel putBsonDoc sel
(reqID, msg) <- packMsg c OP_DELETE body (reqID, msg) <- packMsg c OPDelete body
L.hPut (cHandle c) msg L.hPut (cHandle c) msg
return reqID return reqID
@ -411,7 +408,7 @@ insert c col doc = do
putI32 0 putI32 0
putCol col putCol col
putBsonDoc doc putBsonDoc doc
(reqID, msg) <- packMsg c OP_INSERT body (reqID, msg) <- packMsg c OPInsert body
L.hPut (cHandle c) msg L.hPut (cHandle c) msg
return reqID return reqID
@ -422,7 +419,7 @@ insertMany c col docs = do
putI32 0 putI32 0
putCol col putCol col
forM_ docs putBsonDoc forM_ docs putBsonDoc
(reqID, msg) <- packMsg c OP_INSERT body (reqID, msg) <- packMsg c OPInsert body
L.hPut (cHandle c) msg L.hPut (cHandle c) msg
return reqID return reqID
@ -467,18 +464,18 @@ query c col opts nskip ret sel fsel = do
[] -> putNothing [] -> putNothing
_ -> putBsonDoc $ toBsonDoc $ List.zip fsel $ _ -> putBsonDoc $ toBsonDoc $ List.zip fsel $
repeat $ BsonInt32 1 repeat $ BsonInt32 1
(reqID, msg) <- packMsg c OP_QUERY body (reqID, msg) <- packMsg c OPQuery body
L.hPut h msg L.hPut h msg
hdr <- getHeader h hdr <- getHeader h
assert (OP_REPLY == hOp hdr) $ return () assert (OPReply == hOp hdr) $ return ()
assert (hRespTo hdr == reqID) $ return () assert (hRespTo hdr == reqID) $ return ()
reply <- getReply h reply <- getReply h
assert (rRespFlags reply == 0) $ return () assert (rRespFlags reply == 0) $ return ()
docBytes <- (L.hGet h $ fromIntegral $ hMsgLen hdr - 16 - 20) >>= newIORef docBytes <- L.hGet h (fromIntegral $ hMsgLen hdr - 16 - 20) >>= newIORef
closed <- newIORef False closed <- newIORef False
cid <- newIORef $ rCursorID reply cid <- newIORef $ rCursorID reply
return $ Cursor { return Cursor {
curCon = c, curCon = c,
curID = cid, curID = cid,
curNumToRet = ret, curNumToRet = ret,
@ -497,7 +494,7 @@ update c col flags sel obj = do
putI32 $ fromUpdateFlags flags putI32 $ fromUpdateFlags flags
putBsonDoc sel putBsonDoc sel
putBsonDoc obj putBsonDoc obj
(reqID, msg) <- packMsg c OP_UPDATE body (reqID, msg) <- packMsg c OPUpdate body
L.hPut (cHandle c) msg L.hPut (cHandle c) msg
return reqID return reqID
@ -533,7 +530,7 @@ getReply h = do
cursorID <- getI64 cursorID <- getI64
skip 4 -- startFrom <- getI32 skip 4 -- startFrom <- getI32
skip 4 -- numReturned <- getI32 skip 4 -- numReturned <- getI32
return $ (Reply respFlags cursorID) return $ Reply respFlags cursorID
-- | Return one document or Nothing if there are no more. -- | Return one document or Nothing if there are no more.
@ -541,9 +538,9 @@ getReply h = do
nextDoc :: Cursor -> IO (Maybe BsonDoc) nextDoc :: Cursor -> IO (Maybe BsonDoc)
nextDoc cur = do nextDoc cur = do
closed <- readIORef $ curClosed cur closed <- readIORef $ curClosed cur
case closed of if closed
True -> return Nothing then return Nothing
False -> do else do
docBytes <- readIORef $ curDocBytes cur docBytes <- readIORef $ curDocBytes cur
cid <- readIORef $ curID cur cid <- readIORef $ curID cur
case L.length docBytes of case L.length docBytes of
@ -571,7 +568,7 @@ allDocs cur = unsafeInterleaveIO $ 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 -> liftM (d :) (allDocs cur)
-- | 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 -- the cursor. This means that all of the documents will immediately
@ -581,7 +578,7 @@ 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 -> liftM (d :) (allDocs' cur)
getFirstDoc :: L.ByteString -> (BsonDoc, L.ByteString) getFirstDoc :: L.ByteString -> (BsonDoc, L.ByteString)
getFirstDoc docBytes = flip runGet docBytes $ do getFirstDoc docBytes = flip runGet docBytes $ do
@ -599,11 +596,11 @@ getMore cur = do
putCol $ curCol cur putCol $ curCol cur
putI32 $ curNumToRet cur putI32 $ curNumToRet cur
putI64 cid putI64 cid
(reqID, msg) <- packMsg (curCon cur) OP_GET_MORE body (reqID, msg) <- packMsg (curCon cur) OPGetMore body
L.hPut h msg L.hPut h msg
hdr <- getHeader h hdr <- getHeader h
assert (OP_REPLY == hOp hdr) $ return () assert (OPReply == hOp hdr) $ return ()
assert (hRespTo hdr == reqID) $ return () assert (hRespTo hdr == reqID) $ return ()
reply <- getReply h reply <- getReply h
assert (rRespFlags reply == 0) $ return () assert (rRespFlags reply == 0) $ return ()
@ -628,7 +625,7 @@ finish cur = do
putI32 0 putI32 0
putI32 1 putI32 1
putI64 cid putI64 cid
(_reqID, msg) <- packMsg (curCon cur) OP_KILL_CURSORS body (_reqID, msg) <- packMsg (curCon cur) OPKillCursors body
L.hPut h msg L.hPut h msg
writeIORef (curClosed cur) True writeIORef (curClosed cur) True
return () return ()
@ -643,7 +640,7 @@ data Direction = Ascending
fromDirection :: Direction -> Int fromDirection :: Direction -> Int
fromDirection Ascending = 1 fromDirection Ascending = 1
fromDirection Descending = (-1) fromDirection Descending = - 1
-- | Should this index guarantee uniqueness? -- | Should this index guarantee uniqueness?
type Unique = Bool type Unique = Bool
@ -730,16 +727,12 @@ s2L = L8.fromString
validateCollectionName :: FullCollection -> IO (Database, Collection) validateCollectionName :: FullCollection -> IO (Database, Collection)
validateCollectionName col = do validateCollectionName col = do
let (db, col') = splitFullCol col let (db, col') = splitFullCol col
case s2L ".." `List.elem` (L.group col) of when (s2L ".." `List.elem` L.group col) $
True -> throwColInvalid $ "Collection can't contain \"..\": " ++ show col throwColInvalid $ "Collection can't contain \"..\": " ++ show col
False -> return () when (c2w '$' `L.elem` col &&
case (c2w '$') `L.elem` col && not (s2L "oplog.$mail" `L.isPrefixOf` col' ||
not (s2L "oplog.$mail" `L.isPrefixOf` col' || s2L "$cmd" `L.isPrefixOf` col')) $
s2L "$cmd" `L.isPrefixOf` col') of throwColInvalid $ "Collection can't contain '$': " ++ show col
True -> throwColInvalid $ "Collection can't contain '$': " ++ show col when (L.head col == c2w '.' || L.last col == c2w '.') $
False -> return () throwColInvalid $ "Collection can't start or end with '.': " ++ show col
case L.head col == (c2w '.') || L.last col == (c2w '.') of
True -> throwColInvalid $
"Collection can't start or end with '.': " ++ show col
False -> return ()
return (db, col') return (db, col')

154
Database/MongoDB/BSON.hs
View file

@ -102,52 +102,52 @@ empty = Map.empty
instance BsonDocOps L8.ByteString where instance BsonDocOps L8.ByteString where
toBsonDoc = Map.fromList toBsonDoc = Map.fromList
fromBsonDoc = Map.toList fromBsonDoc = Map.toList
lookup k = Map.lookup k lookup = Map.lookup
instance BsonDocOps String where instance BsonDocOps String where
toBsonDoc = Map.mapKeys L8.fromString .Map.fromList toBsonDoc = Map.mapKeys L8.fromString .Map.fromList
fromBsonDoc = Map.toList . Map.mapKeys L8.toString fromBsonDoc = Map.toList . Map.mapKeys L8.toString
lookup k = Map.lookup (L8.fromString k) lookup = Map.lookup . L8.fromString
data DataType = data DataType =
Data_min_key | -- -1 DataMinKey | -- -1
Data_number | -- 1 DataNumber | -- 1
Data_string | -- 2 DataString | -- 2
Data_object | -- 3 DataObject | -- 3
Data_array | -- 4 DataArray | -- 4
Data_binary | -- 5 DataBinary | -- 5
Data_undefined | -- 6 DataUndefined | -- 6
Data_oid | -- 7 DataOid | -- 7
Data_boolean | -- 8 DataBoolean | -- 8
Data_date | -- 9 DataDate | -- 9
Data_null | -- 10 DataNull | -- 10
Data_regex | -- 11 DataRegex | -- 11
Data_ref | -- 12 DataRef | -- 12
Data_code | -- 13 DataCode | -- 13
Data_symbol | -- 14 DataSymbol | -- 14
Data_code_w_scope | -- 15 DataCodeWScope | -- 15
Data_int | -- 16 DataInt | -- 16
Data_timestamp | -- 17 DataTimestamp | -- 17
Data_long | -- 18 DataLong | -- 18
Data_max_key -- 127 DataMaxKey -- 127
deriving (Show, Read, Enum, Eq, Ord) deriving (Show, Read, Enum, Eq, Ord)
toDataType :: Int -> DataType toDataType :: Int -> DataType
toDataType (-1) = Data_min_key toDataType (-1) = DataMinKey
toDataType 127 = Data_max_key toDataType 127 = DataMaxKey
toDataType d = toEnum d toDataType d = toEnum d
fromDataType :: DataType -> Int fromDataType :: DataType -> Int
fromDataType Data_min_key = (-1) fromDataType DataMinKey = - 1
fromDataType Data_max_key = 127 fromDataType DataMaxKey = 127
fromDataType d = fromEnum d fromDataType d = fromEnum d
data BinarySubType = data BinarySubType =
BSTUNDEFINED_1 | BSTUNDEFINED1 |
BSTFunction | -- 1 BSTFunction | -- 1
BSTByteArray | -- 2 BSTByteArray | -- 2
BSTUUID | -- 3 BSTUUID | -- 3
BSTUNDEFINED_2 | BSTUNDEFINED2 |
BSTMD5 | -- 5 BSTMD5 | -- 5
BSTUserDefined BSTUserDefined
deriving (Show, Read, Enum, Eq, Ord) deriving (Show, Read, Enum, Eq, Ord)
@ -167,43 +167,41 @@ putBsonDoc :: BsonDoc -> Put
putBsonDoc = putObj putBsonDoc = putObj
getVal :: DataType -> Get (Integer, BsonValue) getVal :: DataType -> Get (Integer, BsonValue)
getVal Data_number = getFloat64le >>= return . (,) 8 . BsonDouble getVal DataNumber = liftM ((,) 8 . BsonDouble) getFloat64le
getVal Data_string = do getVal DataString = do
sLen1 <- getI32 sLen1 <- getI32
(_sLen2, s) <- getS (_sLen2, s) <- getS
return (fromIntegral $ 4 + sLen1, BsonString s) return (fromIntegral $ 4 + sLen1, BsonString s)
getVal Data_object = getDoc >>= \(len, obj) -> return (len, BsonObject obj) getVal DataObject = getDoc >>= \(len, obj) -> return (len, BsonObject obj)
getVal Data_array = do getVal DataArray = 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, BsonArray arr2) return (len, BsonArray arr2)
getVal Data_binary = do getVal DataBinary = 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, BsonBinary (toBinarySubType st) bs) return (4 + 1 + 4 + fromIntegral len2, BsonBinary (toBinarySubType st) bs)
getVal Data_undefined = return (1, BsonUndefined) getVal DataUndefined = return (1, BsonUndefined)
getVal Data_oid = getLazyByteString 12 >>= return . (,) 12 . BsonObjectId getVal DataOid = liftM ((,) 12 . BsonObjectId) $ getLazyByteString 12
getVal Data_boolean = getVal DataBoolean = liftM ((,) (1::Integer) . BsonBool . (/= (0::Int))) getI8
getI8 >>= return . (,) (1::Integer) . BsonBool . (/= (0::Int)) getVal DataDate = liftM ((,) 8 . BsonDate . flip (/) 1000 . realToFrac) getI64
getVal Data_date = getVal DataNull = return (1, BsonNull)
getI64 >>= return . (,) 8 . BsonDate . flip (/) 1000 . realToFrac getVal DataRegex = fail "DataCode not yet supported" -- TODO
getVal Data_null = return (1, BsonNull) getVal DataRef = fail "DataRef is deprecated"
getVal Data_regex = fail "Data_code not yet supported" -- TODO getVal DataCode = fail "DataCode not yet supported" -- TODO
getVal Data_ref = fail "Data_ref is deprecated" getVal DataSymbol = do
getVal Data_code = fail "Data_code not yet supported" -- TODO
getVal Data_symbol = do
sLen1 <- getI32 sLen1 <- getI32
(_sLen2, s) <- getS (_sLen2, s) <- getS
return (fromIntegral $ 4 + sLen1, BsonString s) return (fromIntegral $ 4 + sLen1, BsonString s)
getVal Data_code_w_scope = fail "Data_code_w_scope not yet supported" -- TODO getVal DataCodeWScope = fail "DataCodeWScope not yet supported" -- TODO
getVal Data_int = getI32 >>= return . (,) 4 . BsonInt32 . fromIntegral getVal DataInt = liftM ((,) 4 . BsonInt32 . fromIntegral) getI32
getVal Data_timestamp = fail "Data_timestamp not yet supported" -- TODO getVal DataTimestamp = fail "DataTimestamp not yet supported" -- TODO
getVal Data_long = getI64 >>= return . (,) 8 . BsonInt64 getVal DataLong = liftM ((,) 8 . BsonInt64) getI64
getVal Data_min_key = return (0, BsonMinKey) getVal DataMinKey = return (0, BsonMinKey)
getVal Data_max_key = return (0, BsonMaxKey) getVal DataMaxKey = return (0, BsonMaxKey)
getInnerObj :: Int32 -> BsonDoc -> Get BsonDoc getInnerObj :: Int32 -> BsonDoc -> Get BsonDoc
getInnerObj 1 obj = return obj getInnerObj 1 obj = return obj
@ -212,7 +210,7 @@ getInnerObj bytesLeft obj = do
(keySz, key) <- getS (keySz, key) <- getS
(valSz, val) <- getVal typ (valSz, val) <- getVal typ
getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $ getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $
(Map.insert key val) obj Map.insert key val obj
getRawObj :: Get (Integer, BsonDoc) getRawObj :: Get (Integer, BsonDoc)
getRawObj = do getRawObj = do
@ -228,26 +226,26 @@ getDataType :: Get DataType
getDataType = liftM toDataType getI8 getDataType = liftM toDataType getI8
putType :: BsonValue -> Put putType :: BsonValue -> Put
putType BsonDouble{} = putDataType Data_number putType BsonDouble{} = putDataType DataNumber
putType BsonString{} = putDataType Data_string putType BsonString{} = putDataType DataString
putType BsonObject{} = putDataType Data_object putType BsonObject{} = putDataType DataObject
putType BsonArray{} = putDataType Data_array putType BsonArray{} = putDataType DataArray
putType BsonBinary{} = putDataType Data_binary putType BsonBinary{} = putDataType DataBinary
putType BsonUndefined = putDataType Data_undefined putType BsonUndefined = putDataType DataUndefined
putType BsonObjectId{} = putDataType Data_oid putType BsonObjectId{} = putDataType DataOid
putType BsonBool{} = putDataType Data_boolean putType BsonBool{} = putDataType DataBoolean
putType BsonDate{} = putDataType Data_date putType BsonDate{} = putDataType DataDate
putType BsonNull = putDataType Data_null putType BsonNull = putDataType DataNull
putType BsonRegex{} = putDataType Data_regex putType BsonRegex{} = putDataType DataRegex
-- putType = putDataType Data_ref -- putType = putDataType DataRef
-- putType = putDataType Data_code -- putType = putDataType DataCode
putType BsonSymbol{} = putDataType Data_symbol putType BsonSymbol{} = putDataType DataSymbol
-- putType = putDataType Data_code_w_scope -- putType = putDataType DataCodeWScope
putType BsonInt32 {} = putDataType Data_int putType BsonInt32 {} = putDataType DataInt
putType BsonInt64 {} = putDataType Data_long putType BsonInt64 {} = putDataType DataLong
-- putType = putDataType Data_timestamp -- putType = putDataType DataTimestamp
putType BsonMinKey = putDataType Data_min_key putType BsonMinKey = putDataType DataMinKey
putType BsonMaxKey = putDataType Data_max_key putType BsonMaxKey = putDataType DataMaxKey
putVal :: BsonValue -> Put putVal :: BsonValue -> Put
putVal (BsonDouble d) = putFloat64le d putVal (BsonDouble d) = putFloat64le d
@ -255,7 +253,7 @@ putVal (BsonString s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
putVal (BsonObject o) = putObj o putVal (BsonObject o) = putObj o
putVal (BsonArray 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 (BsonBinary 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
@ -375,22 +373,22 @@ instance Convertible Bool BsonValue where
safeConvert = return . BsonBool safeConvert = return . BsonBool
instance Convertible Int BsonValue where instance Convertible Int BsonValue where
safeConvert i = if i >= (fromIntegral (minBound::Int32)) && safeConvert i = if i >= fromIntegral (minBound::Int32) &&
i <= (fromIntegral (maxBound::Int32)) i <= fromIntegral (maxBound::Int32)
then return $ BsonInt32 $ fromIntegral i then return $ BsonInt32 $ fromIntegral i
else return $ BsonInt64 $ fromIntegral i else return $ BsonInt64 $ fromIntegral i
instance Convertible Integer BsonValue where instance Convertible Integer BsonValue where
safeConvert i = if i >= (fromIntegral (minBound::Int32)) && safeConvert i = if i >= fromIntegral (minBound::Int32) &&
i <= (fromIntegral (maxBound::Int32)) i <= fromIntegral (maxBound::Int32)
then return $ BsonInt32 $ fromIntegral i then return $ BsonInt32 $ fromIntegral i
else return $ BsonInt64 $ fromIntegral i else return $ BsonInt64 $ fromIntegral i
instance Convertible Int32 BsonValue where instance Convertible Int32 BsonValue where
safeConvert i = return $ BsonInt32 i safeConvert = return . BsonInt32
instance Convertible Int64 BsonValue where instance Convertible Int64 BsonValue where
safeConvert i = return $ BsonInt64 i safeConvert = return . BsonInt64
instance (Convertible a BsonValue) => instance (Convertible a BsonValue) =>
Convertible (Maybe a) BsonValue where Convertible (Maybe a) BsonValue where