make changes suggested by HLint
This commit is contained in:
Scott R. Parish
parent
5ae3c4c2ae
commit
d606e47f33
2 changed files with 152 additions and 161 deletions
|
|
@ -92,7 +92,7 @@ connectOnPort host port = do
|
|||
let ns = randomRs (fromIntegral (minBound :: Int32),
|
||||
fromIntegral (maxBound :: Int32)) r
|
||||
nsRef <- newIORef ns
|
||||
return $ Connection { cHandle = h, cRand = nsRef }
|
||||
return Connection { cHandle = h, cRand = nsRef }
|
||||
|
||||
-- | Close database connection
|
||||
conClose :: Connection -> IO ()
|
||||
|
|
@ -100,7 +100,7 @@ conClose = hClose . cHandle
|
|||
|
||||
-- | Information about the databases on the server.
|
||||
databasesInfo :: Connection -> IO BsonDoc
|
||||
databasesInfo c = do
|
||||
databasesInfo c =
|
||||
runCommand c (s2L "admin") $ toBsonDoc [("listDatabases", toBson (1::Int))]
|
||||
|
||||
-- | Return a list of database names on the server.
|
||||
|
|
@ -108,7 +108,7 @@ databaseNames :: Connection -> IO [Database]
|
|||
databaseNames c = do
|
||||
info <- databasesInfo c
|
||||
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])
|
||||
|
||||
-- | Alias for 'conClose'
|
||||
|
|
@ -123,15 +123,14 @@ dropDatabase c db = do
|
|||
|
||||
-- | Get information about the MongoDB server we're connected to.
|
||||
serverInfo :: Connection -> IO BsonDoc
|
||||
serverInfo c = do
|
||||
serverInfo c =
|
||||
runCommand c (s2L "admin") $ toBsonDoc [("buildinfo", toBson (1::Int))]
|
||||
|
||||
-- | Return a list of collections in /Database/.
|
||||
collectionNames :: Connection -> Database -> IO [FullCollection]
|
||||
collectionNames c db = do
|
||||
docs <- quickFind' c (L.append db $ s2L ".system.namespaces") empty
|
||||
let names = flip List.map docs $ \doc ->
|
||||
fromBson $ fromJust $ BSON.lookup "name" doc
|
||||
let names = flip List.map docs $ fromBson . fromJust . BSON.lookup "name"
|
||||
return $ List.filter (L.notElem $ c2w '$') names
|
||||
|
||||
data ColCreateOpt = CCOSize Int64 -- ^ Desired initial size for the
|
||||
|
|
@ -159,9 +158,8 @@ createCollection :: Connection -> FullCollection -> [ColCreateOpt] -> IO ()
|
|||
createCollection c col opts = do
|
||||
(db, col') <- validateCollectionName col
|
||||
dbcols <- collectionNames c db
|
||||
case col `List.elem` dbcols of
|
||||
True -> throwColInvalid $ "Collection already exists: " ++ show col
|
||||
False -> return ()
|
||||
when (col `List.elem` dbcols) $
|
||||
throwColInvalid $ "Collection already exists: " ++ show col
|
||||
let cmd = ("create", toBson col') : List.map colCreateOptToBson opts
|
||||
_ <- runCommand c db $ toBsonDoc cmd
|
||||
return ()
|
||||
|
|
@ -223,10 +221,9 @@ runCommand :: Connection -> Database -> BsonDoc -> IO BsonDoc
|
|||
runCommand c db cmd = do
|
||||
mres <- findOne c (L.append db $ s2L ".$cmd") cmd
|
||||
let res = fromJust mres
|
||||
case fromBson $ fromJust $ BSON.lookup "ok" res :: Int of
|
||||
1 -> return ()
|
||||
_ -> throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++
|
||||
(fromBson $ fromJust $ BSON.lookup "errmsg" res)
|
||||
when (1 /= (fromBson $ fromJust $ BSON.lookup "ok" res :: Int)) $
|
||||
throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++
|
||||
fromBson (fromJust $ BSON.lookup "errmsg" res)
|
||||
return res
|
||||
|
||||
-- | An Itertaor over the results of a query. Use 'nextDoc' to get each
|
||||
|
|
@ -242,15 +239,15 @@ data Cursor = Cursor {
|
|||
}
|
||||
|
||||
data Opcode
|
||||
= OP_REPLY -- 1 Reply to a client request. responseTo is set
|
||||
| OP_MSG -- 1000 generic msg command followed by a string
|
||||
| OP_UPDATE -- 2001 update document
|
||||
| OP_INSERT -- 2002 insert new document
|
||||
| OP_GET_BY_OID -- 2003 is this used?
|
||||
| OP_QUERY -- 2004 query a collection
|
||||
| OP_GET_MORE -- 2005 Get more data from a query. See Cursors
|
||||
| OP_DELETE -- 2006 Delete documents
|
||||
| OP_KILL_CURSORS -- 2007 Tell database client is done with a cursor
|
||||
= OPReply -- 1 Reply to a client request. responseTo is set
|
||||
| OPMsg -- 1000 generic msg command followed by a string
|
||||
| OPUpdate -- 2001 update document
|
||||
| OPInsert -- 2002 insert new document
|
||||
| OPGetByOid -- 2003 is this used?
|
||||
| OPQuery -- 2004 query a collection
|
||||
| OPGetMore -- 2005 Get more data from a query. See Cursors
|
||||
| OPDelete -- 2006 Delete documents
|
||||
| OPKillCursors -- 2007 Tell database client is done with a cursor
|
||||
deriving (Show, Eq)
|
||||
|
||||
data MongoDBInternalError = MongoDBInternalError String
|
||||
|
|
@ -276,7 +273,7 @@ instance Typeable MongoDBCollectionInvalid where
|
|||
instance Exception MongoDBCollectionInvalid
|
||||
|
||||
throwColInvalid :: String -> a
|
||||
throwColInvalid s = throw $ MongoDBCollectionInvalid s
|
||||
throwColInvalid = throw . MongoDBCollectionInvalid
|
||||
|
||||
data MongoDBOperationFailure = MongoDBOperationFailure String
|
||||
deriving (Eq, Show, Read)
|
||||
|
|
@ -290,29 +287,29 @@ instance Typeable MongoDBOperationFailure where
|
|||
instance Exception MongoDBOperationFailure
|
||||
|
||||
throwOpFailure :: String -> a
|
||||
throwOpFailure s = throw $ MongoDBOperationFailure s
|
||||
throwOpFailure = throw . MongoDBOperationFailure
|
||||
|
||||
fromOpcode :: Opcode -> Int32
|
||||
fromOpcode OP_REPLY = 1
|
||||
fromOpcode OP_MSG = 1000
|
||||
fromOpcode OP_UPDATE = 2001
|
||||
fromOpcode OP_INSERT = 2002
|
||||
fromOpcode OP_GET_BY_OID = 2003
|
||||
fromOpcode OP_QUERY = 2004
|
||||
fromOpcode OP_GET_MORE = 2005
|
||||
fromOpcode OP_DELETE = 2006
|
||||
fromOpcode OP_KILL_CURSORS = 2007
|
||||
fromOpcode OPReply = 1
|
||||
fromOpcode OPMsg = 1000
|
||||
fromOpcode OPUpdate = 2001
|
||||
fromOpcode OPInsert = 2002
|
||||
fromOpcode OPGetByOid = 2003
|
||||
fromOpcode OPQuery = 2004
|
||||
fromOpcode OPGetMore = 2005
|
||||
fromOpcode OPDelete = 2006
|
||||
fromOpcode OPKillCursors = 2007
|
||||
|
||||
toOpcode :: Int32 -> Opcode
|
||||
toOpcode 1 = OP_REPLY
|
||||
toOpcode 1000 = OP_MSG
|
||||
toOpcode 2001 = OP_UPDATE
|
||||
toOpcode 2002 = OP_INSERT
|
||||
toOpcode 2003 = OP_GET_BY_OID
|
||||
toOpcode 2004 = OP_QUERY
|
||||
toOpcode 2005 = OP_GET_MORE
|
||||
toOpcode 2006 = OP_DELETE
|
||||
toOpcode 2007 = OP_KILL_CURSORS
|
||||
toOpcode 1 = OPReply
|
||||
toOpcode 1000 = OPMsg
|
||||
toOpcode 2001 = OPUpdate
|
||||
toOpcode 2002 = OPInsert
|
||||
toOpcode 2003 = OPGetByOid
|
||||
toOpcode 2004 = OPQuery
|
||||
toOpcode 2005 = OPGetMore
|
||||
toOpcode 2006 = OPDelete
|
||||
toOpcode 2007 = OPKillCursors
|
||||
toOpcode n = throw $ MongoDBInternalError $ "Got unexpected Opcode: " ++ show n
|
||||
|
||||
-- | The name of a database.
|
||||
|
|
@ -354,22 +351,22 @@ type NumToSkip = Int32
|
|||
type NumToReturn = Int32
|
||||
|
||||
-- | Options that control the behavior of a 'query' operation.
|
||||
data QueryOpt = QO_TailableCursor
|
||||
| QO_SlaveOK
|
||||
| QO_OpLogReplay
|
||||
| QO_NoCursorTimeout
|
||||
deriving (Show)
|
||||
data QueryOpt = QOTailableCursor
|
||||
| QOSlaveOK
|
||||
| QOOpLogReplay
|
||||
| QONoCursorTimeout
|
||||
deriving (Show)
|
||||
|
||||
fromQueryOpts :: [QueryOpt] -> Int32
|
||||
fromQueryOpts opts = List.foldl (.|.) 0 $ fmap toVal opts
|
||||
where toVal QO_TailableCursor = 2
|
||||
toVal QO_SlaveOK = 4
|
||||
toVal QO_OpLogReplay = 8
|
||||
toVal QO_NoCursorTimeout = 16
|
||||
where toVal QOTailableCursor = 2
|
||||
toVal QOSlaveOK = 4
|
||||
toVal QOOpLogReplay = 8
|
||||
toVal QONoCursorTimeout = 16
|
||||
|
||||
-- | Options that effect the behavior of a 'update' operation.
|
||||
data UpdateFlag = UF_Upsert
|
||||
| UF_Multiupdate
|
||||
data UpdateFlag = UFUpsert
|
||||
| UFMultiupdate
|
||||
deriving (Show, Enum)
|
||||
|
||||
fromUpdateFlags :: [UpdateFlag] -> Int32
|
||||
|
|
@ -396,7 +393,7 @@ delete c col sel = do
|
|||
putCol col
|
||||
putI32 0
|
||||
putBsonDoc sel
|
||||
(reqID, msg) <- packMsg c OP_DELETE body
|
||||
(reqID, msg) <- packMsg c OPDelete body
|
||||
L.hPut (cHandle c) msg
|
||||
return reqID
|
||||
|
||||
|
|
@ -411,7 +408,7 @@ insert c col doc = do
|
|||
putI32 0
|
||||
putCol col
|
||||
putBsonDoc doc
|
||||
(reqID, msg) <- packMsg c OP_INSERT body
|
||||
(reqID, msg) <- packMsg c OPInsert body
|
||||
L.hPut (cHandle c) msg
|
||||
return reqID
|
||||
|
||||
|
|
@ -422,7 +419,7 @@ insertMany c col docs = do
|
|||
putI32 0
|
||||
putCol col
|
||||
forM_ docs putBsonDoc
|
||||
(reqID, msg) <- packMsg c OP_INSERT body
|
||||
(reqID, msg) <- packMsg c OPInsert body
|
||||
L.hPut (cHandle c) msg
|
||||
return reqID
|
||||
|
||||
|
|
@ -467,18 +464,18 @@ query c col opts nskip ret sel fsel = do
|
|||
[] -> putNothing
|
||||
_ -> putBsonDoc $ toBsonDoc $ List.zip fsel $
|
||||
repeat $ BsonInt32 1
|
||||
(reqID, msg) <- packMsg c OP_QUERY body
|
||||
(reqID, msg) <- packMsg c OPQuery body
|
||||
L.hPut h msg
|
||||
|
||||
hdr <- getHeader h
|
||||
assert (OP_REPLY == hOp hdr) $ return ()
|
||||
assert (OPReply == hOp hdr) $ return ()
|
||||
assert (hRespTo hdr == reqID) $ return ()
|
||||
reply <- getReply h
|
||||
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
|
||||
cid <- newIORef $ rCursorID reply
|
||||
return $ Cursor {
|
||||
return Cursor {
|
||||
curCon = c,
|
||||
curID = cid,
|
||||
curNumToRet = ret,
|
||||
|
|
@ -497,7 +494,7 @@ update c col flags sel obj = do
|
|||
putI32 $ fromUpdateFlags flags
|
||||
putBsonDoc sel
|
||||
putBsonDoc obj
|
||||
(reqID, msg) <- packMsg c OP_UPDATE body
|
||||
(reqID, msg) <- packMsg c OPUpdate body
|
||||
L.hPut (cHandle c) msg
|
||||
return reqID
|
||||
|
||||
|
|
@ -533,7 +530,7 @@ getReply h = do
|
|||
cursorID <- getI64
|
||||
skip 4 -- startFrom <- getI32
|
||||
skip 4 -- numReturned <- getI32
|
||||
return $ (Reply respFlags cursorID)
|
||||
return $ Reply respFlags cursorID
|
||||
|
||||
|
||||
-- | Return one document or Nothing if there are no more.
|
||||
|
|
@ -541,9 +538,9 @@ getReply h = do
|
|||
nextDoc :: Cursor -> IO (Maybe BsonDoc)
|
||||
nextDoc cur = do
|
||||
closed <- readIORef $ curClosed cur
|
||||
case closed of
|
||||
True -> return Nothing
|
||||
False -> do
|
||||
if closed
|
||||
then return Nothing
|
||||
else do
|
||||
docBytes <- readIORef $ curDocBytes cur
|
||||
cid <- readIORef $ curID cur
|
||||
case L.length docBytes of
|
||||
|
|
@ -571,7 +568,7 @@ allDocs cur = unsafeInterleaveIO $ do
|
|||
doc <- nextDoc cur
|
||||
case doc of
|
||||
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
|
||||
-- the cursor. This means that all of the documents will immediately
|
||||
|
|
@ -581,7 +578,7 @@ allDocs' cur = do
|
|||
doc <- nextDoc cur
|
||||
case doc of
|
||||
Nothing -> return []
|
||||
Just d -> allDocs' cur >>= return . (d :)
|
||||
Just d -> liftM (d :) (allDocs' cur)
|
||||
|
||||
getFirstDoc :: L.ByteString -> (BsonDoc, L.ByteString)
|
||||
getFirstDoc docBytes = flip runGet docBytes $ do
|
||||
|
|
@ -599,11 +596,11 @@ getMore cur = do
|
|||
putCol $ curCol cur
|
||||
putI32 $ curNumToRet cur
|
||||
putI64 cid
|
||||
(reqID, msg) <- packMsg (curCon cur) OP_GET_MORE body
|
||||
(reqID, msg) <- packMsg (curCon cur) OPGetMore body
|
||||
L.hPut h msg
|
||||
|
||||
hdr <- getHeader h
|
||||
assert (OP_REPLY == hOp hdr) $ return ()
|
||||
assert (OPReply == hOp hdr) $ return ()
|
||||
assert (hRespTo hdr == reqID) $ return ()
|
||||
reply <- getReply h
|
||||
assert (rRespFlags reply == 0) $ return ()
|
||||
|
|
@ -628,7 +625,7 @@ finish cur = do
|
|||
putI32 0
|
||||
putI32 1
|
||||
putI64 cid
|
||||
(_reqID, msg) <- packMsg (curCon cur) OP_KILL_CURSORS body
|
||||
(_reqID, msg) <- packMsg (curCon cur) OPKillCursors body
|
||||
L.hPut h msg
|
||||
writeIORef (curClosed cur) True
|
||||
return ()
|
||||
|
|
@ -643,7 +640,7 @@ data Direction = Ascending
|
|||
|
||||
fromDirection :: Direction -> Int
|
||||
fromDirection Ascending = 1
|
||||
fromDirection Descending = (-1)
|
||||
fromDirection Descending = - 1
|
||||
|
||||
-- | Should this index guarantee uniqueness?
|
||||
type Unique = Bool
|
||||
|
|
@ -730,16 +727,12 @@ s2L = L8.fromString
|
|||
validateCollectionName :: FullCollection -> IO (Database, Collection)
|
||||
validateCollectionName col = do
|
||||
let (db, col') = splitFullCol col
|
||||
case s2L ".." `List.elem` (L.group col) of
|
||||
True -> throwColInvalid $ "Collection can't contain \"..\": " ++ show col
|
||||
False -> return ()
|
||||
case (c2w '$') `L.elem` col &&
|
||||
not (s2L "oplog.$mail" `L.isPrefixOf` col' ||
|
||||
s2L "$cmd" `L.isPrefixOf` col') of
|
||||
True -> throwColInvalid $ "Collection can't contain '$': " ++ show col
|
||||
False -> return ()
|
||||
case L.head col == (c2w '.') || L.last col == (c2w '.') of
|
||||
True -> throwColInvalid $
|
||||
"Collection can't start or end with '.': " ++ show col
|
||||
False -> return ()
|
||||
when (s2L ".." `List.elem` L.group col) $
|
||||
throwColInvalid $ "Collection can't contain \"..\": " ++ show col
|
||||
when (c2w '$' `L.elem` col &&
|
||||
not (s2L "oplog.$mail" `L.isPrefixOf` col' ||
|
||||
s2L "$cmd" `L.isPrefixOf` col')) $
|
||||
throwColInvalid $ "Collection can't contain '$': " ++ show col
|
||||
when (L.head col == c2w '.' || L.last col == c2w '.') $
|
||||
throwColInvalid $ "Collection can't start or end with '.': " ++ show col
|
||||
return (db, col')
|
||||
|
|
|
|||
|
|
@ -102,52 +102,52 @@ empty = Map.empty
|
|||
instance BsonDocOps L8.ByteString where
|
||||
toBsonDoc = Map.fromList
|
||||
fromBsonDoc = Map.toList
|
||||
lookup k = Map.lookup k
|
||||
lookup = Map.lookup
|
||||
|
||||
instance BsonDocOps String where
|
||||
toBsonDoc = Map.mapKeys L8.fromString .Map.fromList
|
||||
fromBsonDoc = Map.toList . Map.mapKeys L8.toString
|
||||
lookup k = Map.lookup (L8.fromString k)
|
||||
lookup = Map.lookup . L8.fromString
|
||||
|
||||
data DataType =
|
||||
Data_min_key | -- -1
|
||||
Data_number | -- 1
|
||||
Data_string | -- 2
|
||||
Data_object | -- 3
|
||||
Data_array | -- 4
|
||||
Data_binary | -- 5
|
||||
Data_undefined | -- 6
|
||||
Data_oid | -- 7
|
||||
Data_boolean | -- 8
|
||||
Data_date | -- 9
|
||||
Data_null | -- 10
|
||||
Data_regex | -- 11
|
||||
Data_ref | -- 12
|
||||
Data_code | -- 13
|
||||
Data_symbol | -- 14
|
||||
Data_code_w_scope | -- 15
|
||||
Data_int | -- 16
|
||||
Data_timestamp | -- 17
|
||||
Data_long | -- 18
|
||||
Data_max_key -- 127
|
||||
DataMinKey | -- -1
|
||||
DataNumber | -- 1
|
||||
DataString | -- 2
|
||||
DataObject | -- 3
|
||||
DataArray | -- 4
|
||||
DataBinary | -- 5
|
||||
DataUndefined | -- 6
|
||||
DataOid | -- 7
|
||||
DataBoolean | -- 8
|
||||
DataDate | -- 9
|
||||
DataNull | -- 10
|
||||
DataRegex | -- 11
|
||||
DataRef | -- 12
|
||||
DataCode | -- 13
|
||||
DataSymbol | -- 14
|
||||
DataCodeWScope | -- 15
|
||||
DataInt | -- 16
|
||||
DataTimestamp | -- 17
|
||||
DataLong | -- 18
|
||||
DataMaxKey -- 127
|
||||
deriving (Show, Read, Enum, Eq, Ord)
|
||||
|
||||
toDataType :: Int -> DataType
|
||||
toDataType (-1) = Data_min_key
|
||||
toDataType 127 = Data_max_key
|
||||
toDataType (-1) = DataMinKey
|
||||
toDataType 127 = DataMaxKey
|
||||
toDataType d = toEnum d
|
||||
|
||||
fromDataType :: DataType -> Int
|
||||
fromDataType Data_min_key = (-1)
|
||||
fromDataType Data_max_key = 127
|
||||
fromDataType DataMinKey = - 1
|
||||
fromDataType DataMaxKey = 127
|
||||
fromDataType d = fromEnum d
|
||||
|
||||
data BinarySubType =
|
||||
BSTUNDEFINED_1 |
|
||||
BSTUNDEFINED1 |
|
||||
BSTFunction | -- 1
|
||||
BSTByteArray | -- 2
|
||||
BSTUUID | -- 3
|
||||
BSTUNDEFINED_2 |
|
||||
BSTUNDEFINED2 |
|
||||
BSTMD5 | -- 5
|
||||
BSTUserDefined
|
||||
deriving (Show, Read, Enum, Eq, Ord)
|
||||
|
|
@ -167,43 +167,41 @@ putBsonDoc :: BsonDoc -> Put
|
|||
putBsonDoc = putObj
|
||||
|
||||
getVal :: DataType -> Get (Integer, BsonValue)
|
||||
getVal Data_number = getFloat64le >>= return . (,) 8 . BsonDouble
|
||||
getVal Data_string = do
|
||||
getVal DataNumber = liftM ((,) 8 . BsonDouble) getFloat64le
|
||||
getVal DataString = do
|
||||
sLen1 <- getI32
|
||||
(_sLen2, s) <- getS
|
||||
return (fromIntegral $ 4 + sLen1, BsonString s)
|
||||
getVal Data_object = getDoc >>= \(len, obj) -> return (len, BsonObject obj)
|
||||
getVal Data_array = do
|
||||
getVal DataObject = getDoc >>= \(len, obj) -> return (len, BsonObject obj)
|
||||
getVal DataArray = do
|
||||
(len, arr) <- getRawObj
|
||||
let arr2 = Map.fold (:) [] arr -- reverse and remove key
|
||||
return (len, BsonArray arr2)
|
||||
getVal Data_binary = do
|
||||
getVal DataBinary = do
|
||||
skip 4
|
||||
st <- getI8
|
||||
len2 <- getI32
|
||||
bs <- getLazyByteString $ fromIntegral len2
|
||||
return (4 + 1 + 4 + fromIntegral len2, BsonBinary (toBinarySubType st) bs)
|
||||
getVal Data_undefined = return (1, BsonUndefined)
|
||||
getVal Data_oid = getLazyByteString 12 >>= return . (,) 12 . BsonObjectId
|
||||
getVal Data_boolean =
|
||||
getI8 >>= return . (,) (1::Integer) . BsonBool . (/= (0::Int))
|
||||
getVal Data_date =
|
||||
getI64 >>= return . (,) 8 . BsonDate . flip (/) 1000 . realToFrac
|
||||
getVal Data_null = return (1, BsonNull)
|
||||
getVal Data_regex = fail "Data_code not yet supported" -- TODO
|
||||
getVal Data_ref = fail "Data_ref is deprecated"
|
||||
getVal Data_code = fail "Data_code not yet supported" -- TODO
|
||||
getVal Data_symbol = do
|
||||
getVal DataUndefined = return (1, BsonUndefined)
|
||||
getVal DataOid = liftM ((,) 12 . BsonObjectId) $ getLazyByteString 12
|
||||
getVal DataBoolean = liftM ((,) (1::Integer) . BsonBool . (/= (0::Int))) getI8
|
||||
getVal DataDate = liftM ((,) 8 . BsonDate . flip (/) 1000 . realToFrac) getI64
|
||||
getVal DataNull = return (1, BsonNull)
|
||||
getVal DataRegex = fail "DataCode not yet supported" -- TODO
|
||||
getVal DataRef = fail "DataRef is deprecated"
|
||||
getVal DataCode = fail "DataCode not yet supported" -- TODO
|
||||
getVal DataSymbol = do
|
||||
sLen1 <- getI32
|
||||
(_sLen2, s) <- getS
|
||||
return (fromIntegral $ 4 + sLen1, BsonString s)
|
||||
getVal Data_code_w_scope = fail "Data_code_w_scope not yet supported" -- TODO
|
||||
getVal Data_int = getI32 >>= return . (,) 4 . BsonInt32 . fromIntegral
|
||||
getVal Data_timestamp = fail "Data_timestamp not yet supported" -- TODO
|
||||
getVal DataCodeWScope = fail "DataCodeWScope not yet supported" -- TODO
|
||||
getVal DataInt = liftM ((,) 4 . BsonInt32 . fromIntegral) getI32
|
||||
getVal DataTimestamp = fail "DataTimestamp not yet supported" -- TODO
|
||||
|
||||
getVal Data_long = getI64 >>= return . (,) 8 . BsonInt64
|
||||
getVal Data_min_key = return (0, BsonMinKey)
|
||||
getVal Data_max_key = return (0, BsonMaxKey)
|
||||
getVal DataLong = liftM ((,) 8 . BsonInt64) getI64
|
||||
getVal DataMinKey = return (0, BsonMinKey)
|
||||
getVal DataMaxKey = return (0, BsonMaxKey)
|
||||
|
||||
getInnerObj :: Int32 -> BsonDoc -> Get BsonDoc
|
||||
getInnerObj 1 obj = return obj
|
||||
|
|
@ -212,7 +210,7 @@ getInnerObj bytesLeft obj = do
|
|||
(keySz, key) <- getS
|
||||
(valSz, val) <- getVal typ
|
||||
getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $
|
||||
(Map.insert key val) obj
|
||||
Map.insert key val obj
|
||||
|
||||
getRawObj :: Get (Integer, BsonDoc)
|
||||
getRawObj = do
|
||||
|
|
@ -228,26 +226,26 @@ getDataType :: Get DataType
|
|||
getDataType = liftM toDataType getI8
|
||||
|
||||
putType :: BsonValue -> Put
|
||||
putType BsonDouble{} = putDataType Data_number
|
||||
putType BsonString{} = putDataType Data_string
|
||||
putType BsonObject{} = putDataType Data_object
|
||||
putType BsonArray{} = putDataType Data_array
|
||||
putType BsonBinary{} = putDataType Data_binary
|
||||
putType BsonUndefined = putDataType Data_undefined
|
||||
putType BsonObjectId{} = putDataType Data_oid
|
||||
putType BsonBool{} = putDataType Data_boolean
|
||||
putType BsonDate{} = putDataType Data_date
|
||||
putType BsonNull = putDataType Data_null
|
||||
putType BsonRegex{} = putDataType Data_regex
|
||||
-- putType = putDataType Data_ref
|
||||
-- putType = putDataType Data_code
|
||||
putType BsonSymbol{} = putDataType Data_symbol
|
||||
-- putType = putDataType Data_code_w_scope
|
||||
putType BsonInt32 {} = putDataType Data_int
|
||||
putType BsonInt64 {} = putDataType Data_long
|
||||
-- putType = putDataType Data_timestamp
|
||||
putType BsonMinKey = putDataType Data_min_key
|
||||
putType BsonMaxKey = putDataType Data_max_key
|
||||
putType BsonDouble{} = putDataType DataNumber
|
||||
putType BsonString{} = putDataType DataString
|
||||
putType BsonObject{} = putDataType DataObject
|
||||
putType BsonArray{} = putDataType DataArray
|
||||
putType BsonBinary{} = putDataType DataBinary
|
||||
putType BsonUndefined = putDataType DataUndefined
|
||||
putType BsonObjectId{} = putDataType DataOid
|
||||
putType BsonBool{} = putDataType DataBoolean
|
||||
putType BsonDate{} = putDataType DataDate
|
||||
putType BsonNull = putDataType DataNull
|
||||
putType BsonRegex{} = putDataType DataRegex
|
||||
-- putType = putDataType DataRef
|
||||
-- putType = putDataType DataCode
|
||||
putType BsonSymbol{} = putDataType DataSymbol
|
||||
-- putType = putDataType DataCodeWScope
|
||||
putType BsonInt32 {} = putDataType DataInt
|
||||
putType BsonInt64 {} = putDataType DataLong
|
||||
-- putType = putDataType DataTimestamp
|
||||
putType BsonMinKey = putDataType DataMinKey
|
||||
putType BsonMaxKey = putDataType DataMaxKey
|
||||
|
||||
putVal :: BsonValue -> Put
|
||||
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 (BsonArray es) = putOutterObj bs
|
||||
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
|
||||
putI8 $ fromBinarySubType t
|
||||
putI32 $ fromIntegral $ L.length bs
|
||||
|
|
@ -375,22 +373,22 @@ instance Convertible Bool BsonValue where
|
|||
safeConvert = return . BsonBool
|
||||
|
||||
instance Convertible Int BsonValue where
|
||||
safeConvert i = if i >= (fromIntegral (minBound::Int32)) &&
|
||||
i <= (fromIntegral (maxBound::Int32))
|
||||
safeConvert i = if i >= fromIntegral (minBound::Int32) &&
|
||||
i <= fromIntegral (maxBound::Int32)
|
||||
then return $ BsonInt32 $ fromIntegral i
|
||||
else return $ BsonInt64 $ fromIntegral i
|
||||
|
||||
instance Convertible Integer BsonValue where
|
||||
safeConvert i = if i >= (fromIntegral (minBound::Int32)) &&
|
||||
i <= (fromIntegral (maxBound::Int32))
|
||||
safeConvert i = if i >= fromIntegral (minBound::Int32) &&
|
||||
i <= fromIntegral (maxBound::Int32)
|
||||
then return $ BsonInt32 $ fromIntegral i
|
||||
else return $ BsonInt64 $ fromIntegral i
|
||||
|
||||
instance Convertible Int32 BsonValue where
|
||||
safeConvert i = return $ BsonInt32 i
|
||||
safeConvert = return . BsonInt32
|
||||
|
||||
instance Convertible Int64 BsonValue where
|
||||
safeConvert i = return $ BsonInt64 i
|
||||
safeConvert = return . BsonInt64
|
||||
|
||||
instance (Convertible a BsonValue) =>
|
||||
Convertible (Maybe a) BsonValue where
|
||||
|
|
|
|||
Loading…
Reference in a new issue