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

change BsonDoc representation to maintain order

Browse source 
Turns out that order is sometimes important for BSON documents. Case
in point, "mapreduce" has to be the first field for the map/reduce
command.

To accomidate this we'll switch from using 'Map' to using a tuple-list
(eg '[(L8.ByteString, BsonValue)]'). Luckily most code that was using
toBsonDoc doesn't need to change.

While at it, 'Convertible' is not adding much value, and was causing
ambiguities making it less usefull (was requiring explicit type hints
more then it should have). Thus we are switching to our own conversion
typeclasses.
This commit is contained in:
Scott R. Parish 2010-03-08 06:57:20 -06:00
parent 7587f435a2
commit fb2f09171a
3 changed files with 216 additions and 248 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
Database/MongoDB.hs
View file

@ -70,7 +70,6 @@ import qualified Data.ByteString.Lazy.UTF8 as L8
import Data.Int import Data.Int
import Data.IORef import Data.IORef
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import Data.Typeable import Data.Typeable
import Data.Digest.OpenSSL.MD5 import Data.Digest.OpenSSL.MD5
@ -121,10 +120,10 @@ newConnection servers opts = do
hRef <- openHandle (head servers) >>= newIORef hRef <- openHandle (head servers) >>= newIORef
let c = Connection hRef nsRef let c = Connection hRef nsRef
res <- isMaster c res <- isMaster c
if fromBson (fromLookup $ BSON.lookup "ismaster" res) == (1::Int) || if fromBson (fromLookup $ List.lookup (s2L "ismaster") res) == (1::Int) ||
isJust (List.elemIndex SlaveOK opts) isJust (List.elemIndex SlaveOK opts)
then return c then return c
else case BSON.lookup "remote" res of else case List.lookup (s2L "remote") res of
Nothing -> throwConFailure "Couldn't find master to connect to" Nothing -> throwConFailure "Couldn't find master to connect to"
Just server -> do Just server -> do
hRef' <- openHandle (splitHostPort $ fromBson server) >>= newIORef hRef' <- openHandle (splitHostPort $ fromBson server) >>= newIORef
@ -149,14 +148,14 @@ conClose c = readIORef (cHandle c) >>= hClose
-- | Information about the databases on the server. -- | Information about the databases on the server.
databasesInfo :: Connection -> IO BsonDoc databasesInfo :: Connection -> IO BsonDoc
databasesInfo c = databasesInfo c =
runCommand c (s2L "admin") $ toBsonDoc [("listDatabases", toBson (1::Int))] runCommand c (s2L "admin") $ toBsonDoc [("listDatabases", BsonInt32 1)]
-- | Return a list of database names on the server. -- | Return a list of database names on the server.
databaseNames :: Connection -> IO [Database] databaseNames :: Connection -> IO [Database]
databaseNames c = do databaseNames c = do
info <- databasesInfo c info <- databasesInfo c
let (BsonArray dbs) = fromLookup $ Map.lookup (s2L "databases") info let (BsonArray dbs) = fromLookup $ List.lookup (s2L "databases") info
names = mapMaybe (Map.lookup (s2L "name") . fromBson) dbs names = mapMaybe (List.lookup (s2L "name") . fromBson) dbs
return $ List.map fromBson (names::[BsonValue]) return $ List.map fromBson (names::[BsonValue])
-- | Alias for 'conClose' -- | Alias for 'conClose'
@ -166,7 +165,7 @@ disconnect = conClose
-- | Drop a database. -- | Drop a database.
dropDatabase :: Connection -> Database -> IO () dropDatabase :: Connection -> Database -> IO ()
dropDatabase c db = do dropDatabase c db = do
_ <- runCommand c db $ toBsonDoc [("dropDatabase", toBson (1::Int))] _ <- runCommand c db $ toBsonDoc [("dropDatabase", BsonInt32 1)]
return () return ()
isMaster :: Connection -> IO BsonDoc isMaster :: Connection -> IO BsonDoc
@ -175,7 +174,7 @@ isMaster c = runCommand c (s2L "admin") $ toBsonDoc [("ismaster", BsonInt32 1)]
-- | 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 = serverInfo c =
runCommand c (s2L "admin") $ toBsonDoc [("buildinfo", toBson (1::Int))] runCommand c (s2L "admin") $ toBsonDoc [("buildinfo", BsonInt32 1)]
-- | Shut down the MongoDB server. -- | Shut down the MongoDB server.
-- --
@ -183,13 +182,14 @@ serverInfo c =
-- Note that it will wait until all ongoing operations are complete. -- Note that it will wait until all ongoing operations are complete.
serverShutdown :: Connection -> IO BsonDoc serverShutdown :: Connection -> IO BsonDoc
serverShutdown c = serverShutdown c =
runCommand c (s2L "admin") $ toBsonDoc [("shutdown", toBson (1::Int))] runCommand c (s2L "admin") $ toBsonDoc [("shutdown", BsonInt32 1)]
-- | 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 $ fromBson . fromLookup . BSON.lookup "name" let names = flip List.map docs $
fromBson . fromLookup . List.lookup (s2L "name")
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
@ -267,7 +267,7 @@ validateCollection :: Connection -> FullCollection -> IO String
validateCollection c col = do validateCollection c col = do
let (db, col') = splitFullCol col let (db, col') = splitFullCol col
res <- runCommand c db $ toBsonDoc [("validate", toBson col')] res <- runCommand c db $ toBsonDoc [("validate", toBson col')]
return $ fromBson $ fromLookup $ BSON.lookup "result" res return $ fromBson $ fromLookup $ List.lookup (s2L "result") res
splitFullCol :: FullCollection -> (Database, Collection) splitFullCol :: FullCollection -> (Database, Collection)
splitFullCol col = (L.takeWhile (c2w '.' /=) col, splitFullCol col = (L.takeWhile (c2w '.' /=) col,
@ -287,9 +287,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 = fromLookup mres let res = fromLookup mres
when (1 /= (fromBson $ fromLookup $ BSON.lookup "ok" res :: Int)) $ when (BsonDouble 1.0 /= fromLookup (List.lookup (s2L "ok") res)) $
throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++ throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++
fromBson (fromLookup $ BSON.lookup "errmsg" res) fromBson (fromLookup $ List.lookup (s2L "errmsg") res)
return res return res
-- | An Iterator over the results of a query. Use 'nextDoc' to get each -- | An Iterator over the results of a query. Use 'nextDoc' to get each
@ -472,7 +472,7 @@ countMatching c col sel = do
let (db, col') = splitFullCol col let (db, col') = splitFullCol col
res <- runCommand c db $ toBsonDoc [("count", toBson col'), res <- runCommand c db $ toBsonDoc [("count", toBson col'),
("query", toBson sel)] ("query", toBson sel)]
return $ fromBson $ fromLookup $ BSON.lookup "n" res return $ fromBson $ fromLookup $ List.lookup (s2L "n") res
-- | Delete documents matching /Selector/ from the given /FullCollection/. -- | Delete documents matching /Selector/ from the given /FullCollection/.
delete :: Connection -> FullCollection -> Selector -> IO RequestID delete :: Connection -> FullCollection -> Selector -> IO RequestID
@ -587,7 +587,7 @@ update c col flags sel obj = do
login :: Connection -> Database -> Username -> Password -> IO BsonDoc login :: Connection -> Database -> Username -> Password -> IO BsonDoc
login c db user pass = do login c db user pass = do
doc <- runCommand c db (toBsonDoc [("getnonce", toBson (1 :: Int))]) doc <- runCommand c db (toBsonDoc [("getnonce", toBson (1 :: Int))])
let nonce = fromBson $ fromLookup $ BSON.lookup "nonce" doc :: String let nonce = fromBson $ fromLookup $ List.lookup (s2L "nonce") doc :: String
digest = md5sum $ pack $ nonce ++ user ++ digest = md5sum $ pack $ nonce ++ user ++
md5sum (pack (user ++ ":mongo:" ++ pass)) md5sum (pack (user ++ ":mongo:" ++ pass))
request = toBsonDoc [("authenticate", toBson (1 :: Int)), request = toBsonDoc [("authenticate", toBson (1 :: Int)),
@ -610,7 +610,10 @@ addUser c db user pass = do
fdb = L.append db (s2L ".system.users") fdb = L.append db (s2L ".system.users")
doc <- findOne c fdb userDoc doc <- findOne c fdb userDoc
let pwd = md5sum $ pack (user ++ ":mongo:" ++ pass) let pwd = md5sum $ pack (user ++ ":mongo:" ++ pass)
doc' = Map.insert (s2L "pwd") (toBson pwd) (fromMaybe userDoc doc) doc' = (s2L "pwd", toBson pwd) :
List.deleteBy (\(k1,_) (k2,_) -> (k1 == k2))
(s2L user, undefined)
(fromMaybe userDoc doc)
_ <- save c fdb doc' _ <- save c fdb doc'
return doc' return doc'
@ -620,7 +623,7 @@ addUser c db user pass = do
-- we insert it -- we insert it
save :: Connection -> FullCollection -> BsonDoc -> IO RequestID save :: Connection -> FullCollection -> BsonDoc -> IO RequestID
save c fc doc = save c fc doc =
case Map.lookup (s2L "_id") doc of case List.lookup (s2L "_id") doc of
Nothing -> insert c fc doc Nothing -> insert c fc doc
Just obj -> update c fc [UFUpsert] (toBsonDoc [("_id", obj)]) doc Just obj -> update c fc [UFUpsert] (toBsonDoc [("_id", obj)]) doc

420
Database/MongoDB/BSON.hs
View file

@ -30,7 +30,7 @@ module Database.MongoDB.BSON
BsonDoc, BsonDoc,
BinarySubType(..), BinarySubType(..),
-- * BsonDoc Operations -- * BsonDoc Operations
empty, lookup, empty,
-- * Type Conversion -- * Type Conversion
fromBson, toBson, fromBson, toBson,
fromBsonDoc, toBsonDoc, fromBsonDoc, toBsonDoc,
@ -40,6 +40,8 @@ module Database.MongoDB.BSON
where where
import Prelude hiding (lookup) import Prelude hiding (lookup)
import qualified Control.Arrow as Arrow
import Control.Exception
import Control.Monad import Control.Monad
import Data.Binary import Data.Binary
import Data.Binary.Get import Data.Binary.Get
@ -49,10 +51,9 @@ import Data.ByteString.Char8 as C8 hiding (empty)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.UTF8 as L8 import qualified Data.ByteString.Lazy.UTF8 as L8
import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.UTF8 as S8
import Data.Convertible
import Data.Int import Data.Int
import qualified Data.Map as Map
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Data.Typeable import Data.Typeable
import Database.MongoDB.Util import Database.MongoDB.Util
@ -79,37 +80,11 @@ data BsonValue
| BsonMaxKey | BsonMaxKey
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
instance Typeable BsonValue where type BsonDoc = [(L8.ByteString, BsonValue)]
typeOf _ = mkTypeName "BsonValue"
-- | BSON Document: this is the top-level (but recursive) type that
-- all MongoDB collections work in terms of. It is a mapping between
-- strings ('Data.ByteString.Lazu.UTF8.ByteString') and 'BsonValue's.
-- It can be constructed either from a 'Map' (eg @'BsonDoc' myMap@) or
-- from a associative list (eg @'toBsonDoc' myAL@).
type BsonDoc = Map.Map L8.ByteString BsonValue
class BsonDocOps a where
-- | Construct a BsonDoc from an associative list
toBsonDoc :: [(a, BsonValue)] -> BsonDoc
-- | Unwrap BsonDoc to be a Map
fromBsonDoc :: BsonDoc -> [(a, BsonValue)]
-- | Return the BsonValue for given key, if any.
lookup :: a -> BsonDoc -> Maybe BsonValue
-- | An empty BsonDoc -- | An empty BsonDoc
empty :: BsonDoc empty :: BsonDoc
empty = Map.empty empty = []
instance BsonDocOps L8.ByteString where
toBsonDoc = Map.fromList
fromBsonDoc = Map.toList
lookup = Map.lookup
instance BsonDocOps String where
toBsonDoc = Map.mapKeys L8.fromString .Map.fromList
fromBsonDoc = Map.toList . Map.mapKeys L8.toString
lookup = Map.lookup . L8.fromString
data DataType = data DataType =
DataMinKey | -- -1 DataMinKey | -- -1
@ -176,9 +151,10 @@ getVal DataString = do
return (fromIntegral $ 4 + sLen1, BsonString s) return (fromIntegral $ 4 + sLen1, BsonString s)
getVal DataDoc = getDoc >>= \(len, obj) -> return (len, BsonDoc obj) getVal DataDoc = getDoc >>= \(len, obj) -> return (len, BsonDoc obj)
getVal DataArray = do getVal DataArray = do
(len, arr) <- getRawObj bytes <- getI32
let arr2 = Map.fold (:) [] arr -- reverse and remove key arr <- getInnerArray (bytes - 4)
return (len, BsonArray arr2) getNull
return (fromIntegral bytes, BsonArray arr)
getVal DataBinary = do getVal DataBinary = do
skip 4 skip 4
st <- getI8 st <- getI8
@ -212,22 +188,32 @@ getVal DataLong = liftM ((,) 8 . BsonInt64) getI64
getVal DataMinKey = return (0, BsonMinKey) getVal DataMinKey = return (0, BsonMinKey)
getVal DataMaxKey = return (0, BsonMaxKey) getVal DataMaxKey = return (0, BsonMaxKey)
getInnerObj :: Int32 -> BsonDoc -> Get BsonDoc getInnerObj :: Int32 -> Get BsonDoc
getInnerObj 1 obj = return obj getInnerObj 1 = return []
getInnerObj bytesLeft obj = do getInnerObj bytesLeft = do
typ <- getDataType typ <- getDataType
(keySz, key) <- getS (keySz, key) <- getS
(valSz, val) <- getVal typ (valSz, val) <- getVal typ
getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $ rest <- getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz)
Map.insert key val obj return $ (key, val) : rest
getRawObj :: Get (Integer, BsonDoc) getRawObj :: Get (Integer, BsonDoc)
getRawObj = do getRawObj = do
bytes <- getI32 bytes <- getI32
obj <- getInnerObj (bytes - 4) empty obj <- getInnerObj (bytes - 4)
getNull getNull
return (fromIntegral bytes, obj) return (fromIntegral bytes, obj)
getInnerArray :: Int32 -> Get [BsonValue]
getInnerArray 1 = return []
getInnerArray bytesLeft = do
typ <- getDataType
(keySz, _key) <- getS
(valSz, val) <- getVal typ
rest <- getInnerArray
(bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz)
return $ val : rest
getDoc :: Get (Integer, BsonDoc) getDoc :: Get (Integer, BsonDoc)
getDoc = getRawObj getDoc = getRawObj
@ -288,8 +274,7 @@ putVal BsonMaxKey = putNothing
putObj :: BsonDoc -> Put putObj :: BsonDoc -> Put
putObj obj = putOutterObj bs putObj obj = putOutterObj bs
where bs = runPut $ forM_ (fromBsonDoc obj) $ \(k, v) -> where bs = runPut $ forM_ obj $ \(k, v) -> putType v >> putS k >> putVal v
putType v >> putS k >> putVal v
putOutterObj :: L.ByteString -> Put putOutterObj :: L.ByteString -> Put
putOutterObj bytes = do putOutterObj bytes = do
@ -301,214 +286,189 @@ putOutterObj bytes = do
putDataType :: DataType -> Put putDataType :: DataType -> Put
putDataType = putI8 . fromDataType putDataType = putI8 . fromDataType
class BsonConv a b where class BsonDocConv a where
-- | Convert a BsonValue into a native Haskell type. -- | Convert a BsonDoc into another form such as a Map or a tuple
fromBson :: Convertible a b => a -> b -- list with String keys.
fromBsonDoc :: BsonDoc -> a
-- | Convert a Map or a tuple list with String keys into a BsonDoc.
toBsonDoc :: a -> BsonDoc
instance BsonDocConv [(L8.ByteString, BsonValue)] where
fromBsonDoc = id
toBsonDoc = id
instance BsonDocConv [(String, BsonValue)] where
fromBsonDoc = List.map $ Arrow.first L8.toString
toBsonDoc = List.map $ Arrow.first L8.fromString
instance BsonDocConv (Map.Map L8.ByteString BsonValue) where
fromBsonDoc = Map.fromList
toBsonDoc = Map.toList
instance BsonDocConv (Map.Map String BsonValue) where
fromBsonDoc = Map.fromList . fromBsonDoc
toBsonDoc = toBsonDoc . Map.toList
data BsonUnsupportedConversion = BsonUnsupportedConversion
deriving (Eq, Show, Read)
bsonUnsupportedConversion :: TyCon
bsonUnsupportedConversion =
mkTyCon "Database.MongoDB.BSON.BsonUnsupportedConversion "
instance Typeable BsonUnsupportedConversion where
typeOf _ = mkTyConApp bsonUnsupportedConversion []
instance Exception BsonUnsupportedConversion
throwUnsupConv :: a
throwUnsupConv = throw BsonUnsupportedConversion
class BsonConv a where
-- | Convert a native Haskell type into a BsonValue. -- | Convert a native Haskell type into a BsonValue.
toBson :: Convertible b a => b -> a toBson :: a -> BsonValue
-- | Convert a BsonValue into a native Haskell type.
fromBson :: BsonValue -> a
instance BsonConv BsonValue a where instance BsonConv Double where
fromBson = convert toBson = BsonDouble
toBson = convert fromBson (BsonDouble d) = d
fromBson _ = throwUnsupConv
instance BsonConv (Maybe BsonValue) (Maybe a) where instance BsonConv Float where
fromBson = convert toBson = BsonDouble . realToFrac
toBson = convert fromBson (BsonDouble d) = realToFrac d
fromBson _ = throwUnsupConv
unsupportedError :: (Typeable a, Convertible BsonValue a) => instance BsonConv L8.ByteString where
BsonValue -> ConvertResult a toBson = BsonString
unsupportedError = convError "Unsupported conversion" fromBson (BsonString s) = s
fromBson _ = throwUnsupConv
instance Convertible Double BsonValue where instance BsonConv String where
safeConvert = return . BsonDouble toBson = BsonString . L8.fromString
fromBson (BsonString s) = L8.toString s
fromBson _ = throwUnsupConv
instance Convertible Float BsonValue where instance BsonConv S8.ByteString where
safeConvert = return . BsonDouble . realToFrac toBson bs = BsonString $ L.fromChunks [bs]
fromBson (BsonString s) = C8.concat $ L.toChunks s
fromBson _ = throwUnsupConv
instance Convertible String BsonValue where instance BsonConv BsonDoc where
safeConvert = return . BsonString . L8.fromString toBson = BsonDoc
fromBson (BsonDoc d) = d
fromBson _ = throwUnsupConv
instance Convertible L8.ByteString BsonValue where instance BsonConv [(String, BsonValue)] where
safeConvert = return . BsonString toBson = toBson . toBsonDoc
fromBson (BsonDoc d) = fromBsonDoc d
fromBson _ = throwUnsupConv
instance Convertible S8.ByteString BsonValue where instance BsonConv (Map.Map L8.ByteString BsonValue) where
safeConvert = return . BsonString . L.fromChunks . return toBson = toBson . toBsonDoc
fromBson (BsonDoc d) = fromBsonDoc d
fromBson _ = throwUnsupConv
instance Convertible [Double] BsonValue where instance BsonConv (Map.Map String BsonValue) where
safeConvert ds = BsonArray `liftM` mapM safeConvert ds toBson = toBson . toBsonDoc
fromBson (BsonDoc d) = fromBsonDoc d
fromBson _ = throwUnsupConv
instance Convertible [Float] BsonValue where instance BsonConv POSIXTime where
safeConvert fs = BsonArray `liftM` mapM safeConvert fs toBson = BsonDate
fromBson (BsonDate d) = d
fromBson _ = throwUnsupConv
instance Convertible [String] BsonValue where instance BsonConv Bool where
safeConvert ss = BsonArray `liftM` mapM safeConvert ss toBson = BsonBool
fromBson (BsonBool b) = b
fromBson _ = throwUnsupConv
instance Convertible [L8.ByteString] BsonValue where instance BsonConv Int where
safeConvert bs = BsonArray `liftM` mapM safeConvert bs toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible [S8.ByteString] BsonValue where instance BsonConv Int8 where
safeConvert bs = BsonArray `liftM` mapM safeConvert bs toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible BsonDoc BsonValue where instance BsonConv Int16 where
safeConvert = return . BsonDoc toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible (Map.Map String BsonValue) BsonValue where instance BsonConv Int32 where
safeConvert = return . BsonDoc . Map.mapKeys L8.fromString toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible [(L8.ByteString, BsonValue)] BsonValue where instance BsonConv Int64 where
safeConvert = return . BsonDoc . toBsonDoc toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible [(String, BsonValue)] BsonValue where instance BsonConv Integer where
safeConvert = return . BsonDoc . toBsonDoc toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible [Bool] BsonValue where instance BsonConv Word where
safeConvert bs = BsonArray `liftM` mapM safeConvert bs toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible [POSIXTime] BsonValue where instance BsonConv Word8 where
safeConvert ts = BsonArray `liftM` mapM safeConvert ts toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible [Int] BsonValue where instance BsonConv Word16 where
safeConvert is = BsonArray `liftM` mapM safeConvert is toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible [Integer] BsonValue where instance BsonConv Word32 where
safeConvert is = BsonArray `liftM` mapM safeConvert is toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
| otherwise = BsonInt64 $ fromIntegral i
fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
fromBson _ = throwUnsupConv
instance Convertible [Int32] BsonValue where instance BsonConv Word64 where
safeConvert is = BsonArray `liftM` mapM safeConvert is toBson i | i >= fromIntegral (minBound::Int32) &&
i <= fromIntegral (maxBound::Int32) = BsonInt32 $ fromIntegral i
instance Convertible [Int64] BsonValue where | otherwise = BsonInt64 $ fromIntegral i
safeConvert is = BsonArray `liftM` mapM safeConvert is fromBson (BsonInt32 i) = fromIntegral i
fromBson (BsonInt64 i) = fromIntegral i
instance Convertible POSIXTime BsonValue where fromBson _ = throwUnsupConv
safeConvert = return . BsonDate
instance Convertible Bool BsonValue where
safeConvert = return . BsonBool
instance Convertible Int BsonValue where
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)
then return $ BsonInt32 $ fromIntegral i
else return $ BsonInt64 $ fromIntegral i
instance Convertible Int32 BsonValue where
safeConvert = return . BsonInt32
instance Convertible Int64 BsonValue where
safeConvert = return . BsonInt64
instance (Convertible a BsonValue) =>
Convertible (Maybe a) BsonValue where
safeConvert Nothing = return BsonNull
safeConvert (Just a) = safeConvert a
instance Convertible BsonValue Double where
safeConvert (BsonDouble d) = return d
safeConvert (BsonInt32 i) = safeConvert i
safeConvert (BsonInt64 i) = safeConvert i
safeConvert v = unsupportedError v
instance Convertible BsonValue Float where
safeConvert (BsonDouble d) = safeConvert d
safeConvert (BsonInt32 i) = safeConvert i
safeConvert (BsonInt64 i) = safeConvert i
safeConvert v = unsupportedError v
instance Convertible BsonValue String where
safeConvert (BsonString bs) = return $ L8.toString bs
safeConvert v = unsupportedError v
instance Convertible BsonValue L8.ByteString where
safeConvert (BsonString bs) = return bs
safeConvert v = unsupportedError v
instance Convertible BsonValue S8.ByteString where
safeConvert (BsonString bs) = return $ C8.concat $ L.toChunks bs
safeConvert v = unsupportedError v
instance Convertible BsonValue BsonDoc where
safeConvert (BsonDoc o) = return o
safeConvert v = unsupportedError v
instance Convertible BsonValue (Map.Map String BsonValue) where
safeConvert (BsonDoc o) = return $ Map.mapKeys L8.toString o
safeConvert v = unsupportedError v
instance Convertible BsonValue [(String, BsonValue)] where
safeConvert (BsonDoc o) = return $ fromBsonDoc o
safeConvert v = unsupportedError v
instance Convertible BsonValue [(L8.ByteString, BsonValue)] where
safeConvert (BsonDoc o) = return $ fromBsonDoc o
safeConvert v = unsupportedError v
instance Convertible BsonValue [Double] where
safeConvert (BsonArray a) = mapM safeConvert a
safeConvert v = unsupportedError v
instance Convertible BsonValue [Float] where
safeConvert (BsonArray a) = mapM safeConvert a
safeConvert v = unsupportedError v
instance Convertible BsonValue [String] where
safeConvert (BsonArray a) = mapM safeConvert a
safeConvert v = unsupportedError v
instance Convertible BsonValue [Bool] where
safeConvert (BsonArray a) = mapM safeConvert a
safeConvert v = unsupportedError v
instance Convertible BsonValue [POSIXTime] where
safeConvert (BsonArray a) = mapM safeConvert a
safeConvert v = unsupportedError v
instance Convertible BsonValue [Int32] where
safeConvert (BsonArray a) = mapM safeConvert a
safeConvert v = unsupportedError v
instance Convertible BsonValue [Int64] where
safeConvert (BsonArray a) = mapM safeConvert a
safeConvert v = unsupportedError v
instance Convertible BsonValue Bool where
safeConvert (BsonBool b) = return b
safeConvert v = unsupportedError v
instance Convertible BsonValue POSIXTime where
safeConvert (BsonDate t) = return t
safeConvert v = unsupportedError v
instance Convertible BsonValue Int where
safeConvert (BsonDouble d) = safeConvert d
safeConvert (BsonInt32 d) = safeConvert d
safeConvert (BsonInt64 d) = safeConvert d
safeConvert v = unsupportedError v
instance Convertible BsonValue Integer where
safeConvert (BsonDouble d) = safeConvert d
safeConvert (BsonInt32 d) = safeConvert d
safeConvert (BsonInt64 d) = safeConvert d
safeConvert v = unsupportedError v
instance Convertible BsonValue Int32 where
safeConvert (BsonDouble d) = safeConvert d
safeConvert (BsonInt32 d) = return d
safeConvert (BsonInt64 d) = safeConvert d
safeConvert v = unsupportedError v
instance Convertible BsonValue Int64 where
safeConvert (BsonDouble d) = safeConvert d
safeConvert (BsonInt32 d) = safeConvert d
safeConvert (BsonInt64 d) = return d
safeConvert v = unsupportedError v
instance (Convertible BsonValue a) =>
Convertible (Maybe BsonValue) (Maybe a) where
safeConvert Nothing = return Nothing
safeConvert (Just a) = liftM Just $ safeConvert a

7
TODO
View file

@ -48,7 +48,6 @@ MongoDB
* close * close
* group * group
* distinct * distinct
* map reduce
- cursor object - cursor object
* hasMore * hasMore
@ -98,3 +97,9 @@ deep "lookup" function (other deep Map functions?)
how to make bytestrings less painful how to make bytestrings less painful
custom Show/Read instance that looks more like json custom Show/Read instance that looks more like json
make sure NULLs aren't in created table names make sure NULLs aren't in created table names
update tutorial to match new python one
+ custom types (see python examples)
+ support array conversions again
+ better type conversion errors