bson 0.1.7 → 0.4.0.1
raw patch · 9 files changed
Files
- CHANGELOG.md +32/−0
- Data/Bson.hs +280/−244
- Data/Bson/Binary.hs +149/−124
- Data/UString.hs +0/−36
- bson.cabal +69/−47
- test/main.hs +0/−29
- tests/Data/Bson/Binary/Tests.hs +8/−0
- tests/Data/Bson/Tests.hs +152/−0
- tests/Tests.hs +12/−0
+ CHANGELOG.md view
@@ -0,0 +1,32 @@+# Change Log+All notable changes to this project will be documented in this file.+This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Package_versioning_policy).+## [0.4.0.1] - 2020-03-22++### Fixed+- MonadFail usage++## [0.4.0.0] - 2020-02-08++### Fixed+- Compatibility with GHC 8.8++## [0.3.2.8] - 2019-06-13++### Fixed+- Compatibility with network 3++## [0.3.2.7] - 2018-12-17++### Fixed+- Fix compilation on GHC < 7.10++## [0.3.2.6] - 2018-05-14++### Added+- Simple deprecated types: 0x0C and 0x06++## [0.3.2] - 2015-10-28++### Added+- Old binary UUID subtype.
Data/Bson.hs view
@@ -1,93 +1,116 @@-{- | A BSON document is a JSON-like object with a standard binary encoding defined at bsonspec.org. This implements version 1.0 of that spec.--Use the GHC language extension /OverloadedStrings/ to automatically convert String literals to UString (UTF8) -}+-- | A BSON document is a JSON-like object with a standard binary encoding+-- defined at bsonspec.org. This implements version 1.0 of that spec.+--+-- Use the GHC language extension /OverloadedStrings/ to automatically convert+-- String literals to Text -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, RankNTypes, OverlappingInstances, IncoherentInstances, ScopedTypeVariables, ForeignFunctionInterface, BangPatterns, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-} module Data.Bson (- -- * UTF-8 String- module Data.UString,- -- * Document- Document, look, lookup, valueAt, at, include, exclude, merge,- -- * Field- Field(..), (=:), (=?),- Label,- -- * Value- Value(..), Val(..), fval, cast, typed, typeOfVal,- -- * Special Bson value types- Binary(..), Function(..), UUID(..), MD5(..), UserDefined(..),- Regex(..), Javascript(..), Symbol(..), MongoStamp(..), MinMaxKey(..),- -- ** ObjectId- ObjectId(..), timestamp, genObjectId-#ifdef TEST- , composite- , roundTo-#endif+ -- * Document+ Document, (!?), look, lookup, valueAt, at, include, exclude, merge,+ -- * Field+ Field(..), (=:), (=?),+ Label,+ -- * Value+ Value(..), Val(..), fval, cast, typed, typeOfVal,+ -- * Special Bson value types+ Binary(..), Function(..), UUID(..), MD5(..), UserDefined(..),+ Regex(..), Javascript(..), Symbol(..), MongoStamp(..), MinMaxKey(..),+ -- ** ObjectId+ ObjectId(..), timestamp, genObjectId, showHexLen ) where -import Prelude hiding (lookup)-import Control.Applicative ((<$>), (<*>))-import Data.Typeable hiding (cast)-import Data.Int-import Data.Word-import Data.UString (UString, u, unpack) -- plus Show and IsString instances+import Prelude hiding (fail, lookup)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+#if MIN_VERSION_base(4, 9, 0)+import Control.Monad.Fail (MonadFail(fail))+#endif+import Control.Monad (foldM)+import Data.Bits (shift, (.|.))+import Data.Int (Int32, Int64)+import Data.IORef (IORef, newIORef, atomicModifyIORef)+import Data.List (find, findIndex)+import Data.Maybe (maybeToList, mapMaybe, fromJust, fromMaybe) import Data.Time.Clock (UTCTime)-import Data.Time.Clock.POSIX+import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime,+ utcTimeToPOSIXSeconds, getPOSIXTime) import Data.Time.Format () -- for Show and Read instances of UTCTime-import Data.List (find, findIndex)-import Data.Bits (shift, (.|.))-import qualified Data.ByteString as BS (ByteString, unpack, take)-import qualified Data.ByteString.Char8 as BSC (pack)-import qualified Crypto.Hash.MD5 as MD5 (hash)+import Data.Typeable hiding (cast)+import Data.Word (Word8, Word16, Word32, Word64) import Numeric (readHex, showHex)-import Network.BSD (getHostName) import System.IO.Unsafe (unsafePerformIO)-import Data.IORef-import Data.Maybe (maybeToList, mapMaybe)-import Control.Monad.Identity+import Text.Read (Read(..))++import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as SC import qualified Text.ParserCombinators.ReadP as R import qualified Text.ParserCombinators.ReadPrec as R (lift, readS_to_Prec)-import Text.Read (Read(..)) +import Control.Monad.Identity (runIdentity)+import Network.BSD (getHostName)+import Data.Text (Text)++import qualified Data.Text as T+import qualified Crypto.Hash.MD5 as MD5+ getProcessID :: IO Int -- ^ Get the current process id. getProcessID = c_getpid +#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+foreign import ccall unsafe "_getpid"+ c_getpid :: IO Int+#else foreign import ccall unsafe "getpid" c_getpid :: IO Int+#endif roundTo :: (RealFrac a) => a -> a -> a -- ^ Round second number to nearest multiple of first number. Eg: roundTo (1/1000) 0.12345 = 0.123-roundTo mult n = fromIntegral (round (n / mult)) * mult+roundTo mult n = fromIntegral (round (n / mult) :: Integer) * mult showHexLen :: (Show n, Integral n) => Int -> n -> ShowS -- ^ showHex of n padded with leading zeros if necessary to fill d digits showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n where- sigDigits 0 = 1- sigDigits n' = truncate (logBase 16 $ fromIntegral n') + 1+ sigDigits 0 = 1+ sigDigits n' = truncate (logBase 16 $ fromIntegral n' :: Double) + 1 -- * Document type Document = [Field] -- ^ A BSON document is a list of 'Field's -look :: (Monad m) => Label -> Document -> m Value+-- | Recursively lookup a nested field in a Document.+(!?) :: Val a => Document -> Label -> Maybe a+doc !? l = foldM (flip lookup) doc (init chunks) >>= lookup (last chunks)+ where chunks = T.split (== '.') l++look :: (MonadFail m) => Label -> Document -> m Value -- ^ Value of field in document, or fail (Nothing) if field not found-look k doc = maybe notFound (return . value) (find ((k ==) . label) doc) where- notFound = fail $ "expected " ++ show k ++ " in " ++ show doc+look k doc = maybe notFound (return . value) (find ((k ==) . label) doc)+ where notFound = fail $ "expected " ++ show k ++ " in " ++ show doc -lookup :: (Val v, Monad m) => Label -> Document -> m v+lookup :: (Val v, MonadFail m) => Label -> Document -> m v -- ^ Lookup value of field in document and cast to expected type. Fail (Nothing) if field not found or value not of expected type. lookup k doc = cast =<< look k doc valueAt :: Label -> Document -> Value -- ^ Value of field in document. Error if missing.-valueAt k = runIdentity . look k+valueAt k = fromJust . look k -at :: forall v. (Val v) => Label -> Document -> v+at :: (Val v) => Label -> Document -> v -- ^ Typed value of field in document. Error if missing or wrong type.-at k doc = maybe err id (lookup k doc) where- err = error $ "expected (" ++ show k ++ " :: " ++ show (typeOf (undefined :: v)) ++ ") in " ++ show doc+at k doc = result+ where+ result = fromMaybe err (lookup k doc)+ err = error $ "expected (" ++ show k ++ " :: " ++ show (typeOf result) ++ ") in " ++ show doc include :: [Label] -> Document -> Document -- ^ Only include fields of document in label list@@ -95,20 +118,20 @@ exclude :: [Label] -> Document -> Document -- ^ Exclude fields from document in label list-exclude keys doc = filter (\(k := _) -> notElem k keys) doc+exclude keys = filter (\(k := _) -> notElem k keys) merge :: Document -> Document -> Document -- ^ Merge documents with preference given to first one when both have the same label. I.e. for every (k := v) in first argument, if k exists in second argument then replace its value with v, otherwise add (k := v) to second argument.-merge es doc = foldl f doc es where- f doc (k := v) = case findIndex ((k ==) . label) doc of- Nothing -> doc ++ [k := v]- Just i -> let (x, _ : y) = splitAt i doc in x ++ [k := v] ++ y+merge es docInitial = foldl f docInitial es+ where f doc (k := v) = case findIndex ((k ==) . label) doc of+ Nothing -> doc ++ [k := v]+ Just i -> let (x, _ : y) = splitAt i doc in x ++ [k := v] ++ y -- * Field infix 0 :=, =:, =? -data Field = (:=) {label :: !Label, value :: Value} deriving (Typeable, Eq)+data Field = (:=) {label :: !Label, value :: Value} deriving (Typeable, Eq, Ord) -- ^ A BSON field is a named value, where the name (label) is a string and the value is a BSON 'Value' (=:) :: (Val v) => Label -> v -> Field@@ -120,74 +143,77 @@ k =? ma = maybeToList (fmap (k =:) ma) instance Show Field where- showsPrec d (k := v) = showParen (d > 0) $ showString (' ' : unpack k) . showString ": " . showsPrec 1 v+ showsPrec d (k := v) = showParen (d > 0) $ showString (' ' : T.unpack k) . showString ": " . showsPrec 1 v -type Label = UString+type Label = Text -- ^ The name of a BSON field -- * Value -- | A BSON value is one of the following types of values-data Value =- Float Double |- String UString |- Doc Document |- Array [Value] |- Bin Binary |- Fun Function |- Uuid UUID |- Md5 MD5 |- UserDef UserDefined |- ObjId ObjectId |- Bool Bool |- UTC UTCTime |- Null |- RegEx Regex |- JavaScr Javascript |- Sym Symbol |- Int32 Int32 |- Int64 Int64 |- Stamp MongoStamp |- MinMax MinMaxKey- deriving (Typeable, Eq)+data Value = Float Double+ | String Text+ | Doc Document+ | Array [Value]+ | Bin Binary+ | Fun Function+ | Uuid UUID+ | Md5 MD5+ | UserDef UserDefined+ | ObjId ObjectId+ | Bool Bool+ | UTC UTCTime+ | Null+ | RegEx Regex+ | JavaScr Javascript+ | Sym Symbol+ | Int32 Int32+ | Int64 Int64+ | Stamp MongoStamp+ | MinMax MinMaxKey+ deriving (Typeable, Eq, Ord) instance Show Value where- showsPrec d v = fval (showsPrec d) v+ showsPrec d = fval (showsPrec d) fval :: (forall a . (Val a) => a -> b) -> Value -> b -- ^ Apply generic function to typed value fval f v = case v of- Float x -> f x- String x -> f x- Doc x -> f x- Array x -> f x- Bin x -> f x- Fun x -> f x- Uuid x -> f x- Md5 x -> f x- UserDef x -> f x- ObjId x -> f x- Bool x -> f x- UTC x -> f x- Null -> f (Nothing :: Maybe Value)- RegEx x -> f x- JavaScr x -> f x- Sym x -> f x- Int32 x -> f x- Int64 x -> f x- Stamp x -> f x- MinMax x -> f x+ Float x -> f x+ String x -> f x+ Doc x -> f x+ Array x -> f x+ Bin x -> f x+ Fun x -> f x+ Uuid x -> f x+ Md5 x -> f x+ UserDef x -> f x+ ObjId x -> f x+ Bool x -> f x+ UTC x -> f x+ Null -> f (Nothing :: Maybe Value)+ RegEx x -> f x+ JavaScr x -> f x+ Sym x -> f x+ Int32 x -> f x+ Int64 x -> f x+ Stamp x -> f x+ MinMax x -> f x -- * Value conversion -cast :: forall m a. (Val a, Monad m) => Value -> m a+cast :: (Val a, MonadFail m) => Value -> m a -- ^ Convert Value to expected type, or fail (Nothing) if not of that type-cast v = maybe notType return (cast' v) where- notType = fail $ "expected " ++ show (typeOf (undefined :: a)) ++ ": " ++ show v+cast v = maybe notType return castingResult+ where+ castingResult = cast' v+ unMaybe :: Maybe a -> a+ unMaybe = undefined+ notType = fail $ "expected " ++ show (typeOf $ unMaybe castingResult) ++ ": " ++ show v typed :: (Val a) => Value -> a -- ^ Convert Value to expected type. Error if not that type.-typed = runIdentity . cast+typed = fromJust . cast typeOfVal :: Value -> TypeRep -- ^ Type of typed value@@ -197,217 +223,227 @@ -- | Haskell types of this class correspond to BSON value types class (Typeable a, Show a, Eq a) => Val a where- val :: a -> Value- cast' :: Value -> Maybe a+ val :: a -> Value+ valList :: [a] -> Value+ valList = Array . map val+ valMaybe :: Maybe a -> Value+ valMaybe = maybe Null val+ cast' :: Value -> Maybe a+ cast'List :: Value -> Maybe [a]+ cast'List (Array x) = mapM cast x+ cast'List _ = Nothing+ cast'Maybe :: Value -> Maybe (Maybe a)+ cast'Maybe Null = Just Nothing+ cast'Maybe v = fmap Just (cast' v) instance Val Double where- val = Float- cast' (Float x) = Just x- cast' (Int32 x) = Just (fromIntegral x)- cast' (Int64 x) = Just (fromIntegral x)- cast' _ = Nothing+ val = Float+ cast' (Float x) = Just x+ cast' (Int32 x) = Just (fromIntegral x)+ cast' (Int64 x) = Just (fromIntegral x)+ cast' _ = Nothing instance Val Float where- val = Float . realToFrac- cast' (Float x) = Just (realToFrac x)- cast' (Int32 x) = Just (fromIntegral x)- cast' (Int64 x) = Just (fromIntegral x)- cast' _ = Nothing+ val = Float . realToFrac+ cast' (Float x) = Just (realToFrac x)+ cast' (Int32 x) = Just (fromIntegral x)+ cast' (Int64 x) = Just (fromIntegral x)+ cast' _ = Nothing -instance Val UString where- val = String- cast' (String x) = Just x- cast' (Sym (Symbol x)) = Just x- cast' _ = Nothing+instance Val Text where+ val = String+ cast' (String x) = Just x+ cast' (Sym (Symbol x)) = Just x+ cast' _ = Nothing -instance Val String where- val = String . u- cast' (String x) = Just (unpack x)- cast' (Sym (Symbol x)) = Just (unpack x)- cast' _ = Nothing+instance Val Char where+ val x = valList [x]+ valList = String . T.pack+ cast' v = cast'List v >>= safeHead+ where safeHead list = case list of+ x:_ -> Just x+ _ -> Nothing+ cast'List (String x) = Just $ T.unpack x+ cast'List (Sym (Symbol x)) = Just $ T.unpack x+ cast'List _ = Nothing -instance Val Document where- val = Doc- cast' (Doc x) = Just x- cast' _ = Nothing+instance Val Field where+ val x = valList [x]+ valList = Doc+ cast' _ = Nothing+ cast'List v = case v of+ Doc x -> Just x+ _ -> Nothing -instance Val [Value] where- val = Array- cast' (Array x) = Just x- cast' _ = Nothing+instance Val Value where+ val = id+ cast' = Just instance (Val a) => Val [a] where- val = Array . map val- cast' (Array x) = mapM cast x- cast' _ = Nothing+ val = valList+ cast' = cast'List instance Val Binary where- val = Bin- cast' (Bin x) = Just x- cast' _ = Nothing+ val = Bin+ cast' (Bin x) = Just x+ cast' _ = Nothing instance Val Function where- val = Fun- cast' (Fun x) = Just x- cast' _ = Nothing+ val = Fun+ cast' (Fun x) = Just x+ cast' _ = Nothing instance Val UUID where- val = Uuid- cast' (Uuid x) = Just x- cast' _ = Nothing+ val = Uuid+ cast' (Uuid x) = Just x+ cast' _ = Nothing instance Val MD5 where- val = Md5- cast' (Md5 x) = Just x- cast' _ = Nothing+ val = Md5+ cast' (Md5 x) = Just x+ cast' _ = Nothing instance Val UserDefined where- val = UserDef- cast' (UserDef x) = Just x- cast' _ = Nothing+ val = UserDef+ cast' (UserDef x) = Just x+ cast' _ = Nothing instance Val ObjectId where- val = ObjId- cast' (ObjId x) = Just x- cast' _ = Nothing+ val = ObjId+ cast' (ObjId x) = Just x+ cast' _ = Nothing instance Val Bool where- val = Bool- cast' (Bool x) = Just x- cast' _ = Nothing+ val = Bool+ cast' (Bool x) = Just x+ cast' _ = Nothing instance Val UTCTime where- val = UTC . posixSecondsToUTCTime . roundTo (1/1000) . utcTimeToPOSIXSeconds- cast' (UTC x) = Just x- cast' _ = Nothing+ val = UTC+ cast' (UTC x) = Just x+ cast' _ = Nothing instance Val POSIXTime where- val = UTC . posixSecondsToUTCTime . roundTo (1/1000)- cast' (UTC x) = Just (utcTimeToPOSIXSeconds x)- cast' _ = Nothing--instance Val (Maybe Value) where- val Nothing = Null- val (Just v) = v- cast' Null = Just Nothing- cast' v = Just (Just v)+ val = UTC . posixSecondsToUTCTime . roundTo (1/1000)+ cast' (UTC x) = Just (utcTimeToPOSIXSeconds x)+ cast' _ = Nothing instance (Val a) => Val (Maybe a) where- val Nothing = Null- val (Just a) = val a- cast' Null = Just Nothing- cast' v = fmap Just (cast' v)+ val = valMaybe+ cast' = cast'Maybe instance Val Regex where- val = RegEx- cast' (RegEx x) = Just x- cast' _ = Nothing+ val = RegEx+ cast' (RegEx x) = Just x+ cast' _ = Nothing instance Val Javascript where- val = JavaScr- cast' (JavaScr x) = Just x- cast' _ = Nothing+ val = JavaScr+ cast' (JavaScr x) = Just x+ cast' _ = Nothing instance Val Symbol where- val = Sym- cast' (Sym x) = Just x- cast' (String x) = Just (Symbol x)- cast' _ = Nothing+ val = Sym+ cast' (Sym x) = Just x+ cast' (String x) = Just (Symbol x)+ cast' _ = Nothing instance Val Int32 where- val = Int32- cast' (Int32 x) = Just x- cast' (Int64 x) = fitInt x- cast' (Float x) = Just (round x)- cast' _ = Nothing+ val = Int32+ cast' (Int32 x) = Just x+ cast' (Int64 x) = fitInt x+ cast' (Float x) = Just (round x)+ cast' _ = Nothing instance Val Int64 where- val = Int64- cast' (Int64 x) = Just x- cast' (Int32 x) = Just (fromIntegral x)- cast' (Float x) = Just (round x)- cast' _ = Nothing+ val = Int64+ cast' (Int64 x) = Just x+ cast' (Int32 x) = Just (fromIntegral x)+ cast' (Float x) = Just (round x)+ cast' _ = Nothing instance Val Int where- val n = maybe (Int64 $ fromIntegral n) Int32 (fitInt n)- cast' (Int32 x) = Just (fromIntegral x)- cast' (Int64 x) = Just (fromEnum x)- cast' (Float x) = Just (round x)- cast' _ = Nothing+ val n = maybe (Int64 $ fromIntegral n) Int32 (fitInt n)+ cast' (Int32 x) = Just (fromIntegral x)+ cast' (Int64 x) = Just (fromEnum x)+ cast' (Float x) = Just (round x)+ cast' _ = Nothing instance Val Integer where- val n = maybe (maybe err Int64 $ fitInt n) Int32 (fitInt n) where- err = error $ show n ++ " is too large for Bson Int Value"- cast' (Int32 x) = Just (fromIntegral x)- cast' (Int64 x) = Just (fromIntegral x)- cast' (Float x) = Just (round x)- cast' _ = Nothing+ val n = maybe (maybe err Int64 $ fitInt n) Int32 (fitInt n)+ where err = error $ show n ++ " is too large for Bson Int Value"+ cast' (Int32 x) = Just (fromIntegral x)+ cast' (Int64 x) = Just (fromIntegral x)+ cast' (Float x) = Just (round x)+ cast' _ = Nothing instance Val MongoStamp where- val = Stamp- cast' (Stamp x) = Just x- cast' _ = Nothing+ val = Stamp+ cast' (Stamp x) = Just x+ cast' _ = Nothing instance Val MinMaxKey where- val = MinMax- cast' (MinMax x) = Just x- cast' _ = Nothing+ val = MinMax+ cast' (MinMax x) = Just x+ cast' _ = Nothing -fitInt :: forall n m. (Integral n, Integral m, Bounded m) => n -> Maybe m+fitInt :: (Integral n, Integral m, Bounded m) => n -> Maybe m -- ^ If number fits in type m then cast to m, otherwise Nothing-fitInt n = if fromIntegral (minBound :: m) <= n && n <= fromIntegral (maxBound :: m)- then Just (fromIntegral n)- else Nothing+fitInt n =+ if fromIntegral (minBound `asTypeOf` result) <= n && n <= fromIntegral (maxBound `asTypeOf` result)+ then Just result+ else Nothing+ where result = fromIntegral n -- * Haskell types corresponding to special Bson value types -- ** Binary types -newtype Binary = Binary BS.ByteString deriving (Typeable, Show, Read, Eq)+newtype Binary = Binary S.ByteString deriving (Typeable, Show, Read, Eq, Ord) -newtype Function = Function BS.ByteString deriving (Typeable, Show, Read, Eq)+newtype Function = Function S.ByteString deriving (Typeable, Show, Read, Eq, Ord) -newtype UUID = UUID BS.ByteString deriving (Typeable, Show, Read, Eq)+newtype UUID = UUID S.ByteString deriving (Typeable, Show, Read, Eq, Ord) -newtype MD5 = MD5 BS.ByteString deriving (Typeable, Show, Read, Eq)+newtype MD5 = MD5 S.ByteString deriving (Typeable, Show, Read, Eq, Ord) -newtype UserDefined = UserDefined BS.ByteString deriving (Typeable, Show, Read, Eq)+newtype UserDefined = UserDefined S.ByteString deriving (Typeable, Show, Read, Eq, Ord) -- ** Regex -data Regex = Regex UString UString deriving (Typeable, Show, Read, Eq)+data Regex = Regex Text Text deriving (Typeable, Show, Read, Eq, Ord) -- ^ The first string is the regex pattern, the second is the regex options string. Options are identified by characters, which must be listed in alphabetical order. Valid options are *i* for case insensitive matching, *m* for multiline matching, *x* for verbose mode, *l* to make \\w, \\W, etc. locale dependent, *s* for dotall mode (\".\" matches everything), and *u* to make \\w, \\W, etc. match unicode. -- ** Javascript -data Javascript = Javascript Document UString deriving (Typeable, Show, Eq)+data Javascript = Javascript Document Text deriving (Typeable, Show, Eq, Ord) -- ^ Javascript code with possibly empty environment mapping variables to values that the code may reference -- ** Symbol -newtype Symbol = Symbol UString deriving (Typeable, Show, Read, Eq)+newtype Symbol = Symbol Text deriving (Typeable, Show, Read, Eq, Ord) -- ** MongoStamp -newtype MongoStamp = MongoStamp Int64 deriving (Typeable, Show, Read, Eq)+newtype MongoStamp = MongoStamp Int64 deriving (Typeable, Show, Read, Eq, Ord) -- ** MinMax -data MinMaxKey = MinKey | MaxKey deriving (Typeable, Show, Read, Eq)+data MinMaxKey = MinKey | MaxKey deriving (Typeable, Show, Read, Eq, Ord) -- ** ObjectId -data ObjectId = Oid Word32 Word64 deriving (Typeable, Eq, Ord)+data ObjectId = Oid {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word64 deriving (Typeable, Eq, Ord) -- ^ A BSON ObjectID is a 12-byte value consisting of a 4-byte timestamp (seconds since epoch), a 3-byte machine id, a 2-byte process id, and a 3-byte counter. Note that the timestamp and counter fields must be stored big endian unlike the rest of BSON. This is because they are compared byte-by-byte and we want to ensure a mostly increasing order. instance Show ObjectId where- showsPrec _ (Oid x y) = showHexLen 8 x . showHexLen 16 y+ showsPrec _ (Oid x y) = showHexLen 8 x . showHexLen 16 y instance Read ObjectId where- readPrec = do- [(x, "")] <- readHex <$> R.lift (R.count 8 R.get)- y <- R.readS_to_Prec $ const readHex- return (Oid x y)+ readPrec = do+ [(x, "")] <- readHex <$> R.lift (R.count 8 R.get)+ y <- R.readS_to_Prec $ const readHex+ return (Oid x y) timestamp :: ObjectId -> UTCTime -- ^ Time when objectId was created@@ -416,19 +452,19 @@ genObjectId :: IO ObjectId -- ^ Create a fresh ObjectId genObjectId = do- time <- truncate <$> getPOSIXTime- pid <- fromIntegral <$> getProcessID- inc <- nextCount- return $ Oid time (composite machineId pid inc)+ time <- truncate <$> getPOSIXTime+ pid <- fromIntegral <$> getProcessID+ inc <- nextCount+ return $ Oid time (composite machineId pid inc) where- machineId :: Word24- machineId = unsafePerformIO (makeWord24 . BS.unpack . BS.take 3 . MD5.hash . BSC.pack <$> getHostName)- {-# NOINLINE machineId #-}- counter :: IORef Word24- counter = unsafePerformIO (newIORef 0)- {-# NOINLINE counter #-}- nextCount :: IO Word24- nextCount = atomicModifyIORef counter $ \n -> (wrap24 (n + 1), n)+ machineId :: Word24+ machineId = unsafePerformIO (makeWord24 . S.unpack . S.take 3 . MD5.hash . SC.pack <$> getHostName)+ {-# NOINLINE machineId #-}+ counter :: IORef Word24+ counter = unsafePerformIO (newIORef 0)+ {-# NOINLINE counter #-}+ nextCount :: IO Word24+ nextCount = atomicModifyIORef counter $ \n -> (wrap24 (n + 1), n) composite :: Word24 -> Word16 -> Word24 -> Word64 composite mid pid inc = fromIntegral mid `shift` 40 .|. fromIntegral pid `shift` 24 .|. fromIntegral inc
Data/Bson/Binary.hs view
@@ -1,90 +1,116 @@ -- | Standard binary encoding of BSON documents, version 1.0. See bsonspec.org -module Data.Bson.Binary (- putDocument, getDocument,- putDouble, getDouble,- putInt32, getInt32,- putInt64, getInt64,- putCString, getCString-) where+module Data.Bson.Binary+ ( putDocument+ , getDocument+ , putDouble+ , getDouble+ , putInt32+ , getInt32+ , putInt64+ , getInt64+ , putCString+ , getCString+ ) where import Prelude hiding (length, concat)-import Data.Bson-import Data.Int-import Data.Word-import Data.Binary.Put-import Data.Binary.Get-import Data.Binary.IEEE754-import Data.ByteString.Char8 (ByteString, pack, length, concat)-import qualified Data.ByteString.Lazy.Char8 as L (ByteString, toChunks, length)-import qualified Data.CompactString.UTF8 as U-import Data.Time.Clock (UTCTime)-import Data.Time.Clock.POSIX-import Control.Applicative ((<$>), (<*>))+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>), (<*))+#endif import Control.Monad (when)+import Data.Binary.Get (Get, runGet, getWord8, getWord32be, getWord64be,+ getWord32le, getWord64le, getLazyByteStringNul,+ getLazyByteString, getByteString, lookAhead)+import Data.Binary.Put (Put, runPut, putWord8, putWord32le, putWord64le,+ putWord32be, putWord64be, putLazyByteString,+ putByteString)+import Data.Binary.IEEE754 (getFloat64le, putFloat64le)+import Data.ByteString (ByteString)+import Data.Int (Int32, Int64)+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Data.Word (Word8) +import qualified Data.ByteString.Char8 as SC+import qualified Data.ByteString.Lazy.Char8 as LC++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++import Data.Bson (Document, Value(..), ObjectId(..), MongoStamp(..), Symbol(..),+ Javascript(..), UserDefined(..), Regex(..), MinMaxKey(..),+ Binary(..), UUID(..), Field(..), MD5(..), Function(..))+ putField :: Field -> Put -- ^ Write binary representation of element putField (k := v) = case v of- Float x -> putTL 0x01 >> putDouble x- String x -> putTL 0x02 >> putString x- Doc x -> putTL 0x03 >> putDocument x- Array x -> putTL 0x04 >> putArray x- Bin (Binary x) -> putTL 0x05 >> putBinary 0x00 x- Fun (Function x) -> putTL 0x05 >> putBinary 0x01 x- Uuid (UUID x) -> putTL 0x05 >> putBinary 0x03 x- Md5 (MD5 x) -> putTL 0x05 >> putBinary 0x05 x- UserDef (UserDefined x) -> putTL 0x05 >> putBinary 0x80 x- ObjId x -> putTL 0x07 >> putObjectId x- Bool x -> putTL 0x08 >> putBool x- UTC x -> putTL 0x09 >> putUTC x- Null -> putTL 0x0A- RegEx x -> putTL 0x0B >> putRegex x- JavaScr (Javascript env code) -> if null env- then putTL 0x0D >> putString code- else putTL 0x0F >> putClosure code env- Sym x -> putTL 0x0E >> putSymbol x- Int32 x -> putTL 0x10 >> putInt32 x- Int64 x -> putTL 0x12 >> putInt64 x- Stamp x -> putTL 0x11 >> putMongoStamp x- MinMax x -> case x of- MinKey -> putTL 0xFF- MaxKey -> putTL 0x7F+ Float x -> putTL 0x01 >> putDouble x+ String x -> putTL 0x02 >> putString x+ Doc x -> putTL 0x03 >> putDocument x+ Array x -> putTL 0x04 >> putArray x+ Bin (Binary x) -> putTL 0x05 >> putBinary 0x00 x+ Fun (Function x) -> putTL 0x05 >> putBinary 0x01 x+ Uuid (UUID x) -> putTL 0x05 >> putBinary 0x04 x+ Md5 (MD5 x) -> putTL 0x05 >> putBinary 0x05 x+ UserDef (UserDefined x) -> putTL 0x05 >> putBinary 0x80 x+ ObjId x -> putTL 0x07 >> putObjectId x+ Bool x -> putTL 0x08 >> putBool x+ UTC x -> putTL 0x09 >> putUTC x+ Null -> putTL 0x0A+ RegEx x -> putTL 0x0B >> putRegex x+ JavaScr (Javascript env code) ->+ if null env+ then putTL 0x0D >> putString code+ else putTL 0x0F >> putClosure code env+ Sym x -> putTL 0x0E >> putSymbol x+ Int32 x -> putTL 0x10 >> putInt32 x+ Int64 x -> putTL 0x12 >> putInt64 x+ Stamp x -> putTL 0x11 >> putMongoStamp x+ MinMax x ->+ case x of+ MinKey -> putTL 0xFF+ MaxKey -> putTL 0x7F where- putTL t = putTag t >> putLabel k+ putTL t = putTag t >> putLabel k getField :: Get Field -- ^ Read binary representation of Element getField = do- t <- getTag- k <- getLabel- v <- case t of- 0x01 -> Float <$> getDouble- 0x02 -> String <$> getString- 0x03 -> Doc <$> getDocument- 0x04 -> Array <$> getArray- 0x05 -> getBinary >>= \(s, b) -> case s of- 0x00 -> return $ Bin (Binary b)- 0x01 -> return $ Fun (Function b)- 0x03 -> return $ Uuid (UUID b)- 0x05 -> return $ Md5 (MD5 b)- 0x80 -> return $ UserDef (UserDefined b)- _ -> fail $ "unknown Bson binary subtype " ++ show s- 0x07 -> ObjId <$> getObjectId- 0x08 -> Bool <$> getBool- 0x09 -> UTC <$> getUTC- 0x0A -> return Null- 0x0B -> RegEx <$> getRegex- 0x0D -> JavaScr . Javascript [] <$> getString- 0x0F -> JavaScr . uncurry (flip Javascript) <$> getClosure- 0x0E -> Sym <$> getSymbol- 0x10 -> Int32 <$> getInt32- 0x12 -> Int64 <$> getInt64- 0x11 -> Stamp <$> getMongoStamp- 0xFF -> return (MinMax MinKey)- 0x7F -> return (MinMax MaxKey)- _ -> fail $ "unknown Bson value type " ++ show t- return (k := v)+ t <- getTag+ k <- getLabel+ v <- case t of+ 0x01 -> Float <$> getDouble+ 0x02 -> String <$> getString+ 0x03 -> Doc <$> getDocument+ 0x04 -> Array <$> getArray+ 0x05 -> getBinary >>= \(s, b) ->+ case s of+ 0x00 -> return $ Bin (Binary b)+ 0x01 -> return $ Fun (Function b)+ 0x02 -> return $ Bin (Binary b)+ 0x03 -> return $ Uuid (UUID b)+ 0x04 -> return $ Uuid (UUID b)+ 0x05 -> return $ Md5 (MD5 b)+ 0x80 -> return $ UserDef (UserDefined b)+ _ -> fail $ "unknown Bson binary subtype " ++ show s+ 0x06 -> return Null+ 0x07 -> ObjId <$> getObjectId+ 0x08 -> Bool <$> getBool+ 0x09 -> UTC <$> getUTC+ 0x0A -> return Null+ 0x0B -> RegEx <$> getRegex+ 0x0C -> ObjId <$> getObjectId <* getString+ 0x0D -> JavaScr . Javascript [] <$> getString+ 0x0E -> Sym <$> getSymbol+ 0x0F -> JavaScr . uncurry (flip Javascript) <$> getClosure+ 0x10 -> Int32 <$> getInt32+ 0x11 -> Stamp <$> getMongoStamp+ 0x12 -> Int64 <$> getInt64+ 0xFF -> return (MinMax MinKey)+ 0x7F -> return (MinMax MaxKey)+ _ -> fail $ "unknown Bson value type " ++ show t+ return (k := v) putTag = putWord8 getTag = getWord8@@ -107,47 +133,46 @@ getInt64 :: Get Int64 getInt64 = fromIntegral <$> getWord64le -putCString :: UString -> Put+putCString :: Text -> Put putCString x = do- putByteString (U.toByteString x)- putWord8 0+ putByteString $ TE.encodeUtf8 x+ putWord8 0 -getCString :: Get UString-getCString = U.fromByteString_ . concat . L.toChunks <$> getLazyByteStringNul+getCString :: Get Text+getCString = TE.decodeUtf8 . SC.concat . LC.toChunks <$> getLazyByteStringNul -putString :: UString -> Put-putString x = let b = U.toByteString x in do- putInt32 $ toEnum (length b + 1)- putByteString b- putWord8 0+putString :: Text -> Put+putString x = let b = TE.encodeUtf8 x in do+ putInt32 $ toEnum (SC.length b + 1)+ putByteString b+ putWord8 0 -getString :: Get UString+getString :: Get Text getString = do- len <- subtract 1 <$> getInt32- b <- getByteString (fromIntegral len)- getWord8- return (U.fromByteString_ b)+ len <- subtract 1 <$> getInt32+ b <- getByteString (fromIntegral len)+ getWord8+ return $ TE.decodeUtf8 b putDocument :: Document -> Put putDocument es = let b = runPut (mapM_ putField es) in do- putInt32 $ (toEnum . fromEnum) (L.length b + 5) -- include length and null terminator- putLazyByteString b- putWord8 0+ putInt32 $ (toEnum . fromEnum) (LC.length b + 5) -- include length and null terminator+ putLazyByteString b+ putWord8 0 getDocument :: Get Document getDocument = do- len <- subtract 5 <$> getInt32- b <- getLazyByteString (fromIntegral len)- getWord8- return (runGet getFields b)+ len <- subtract 4 <$> getInt32+ b <- getLazyByteString (fromIntegral len)+ return (runGet getFields b) where- getFields = isEmpty >>= \done -> if done- then return []- else (:) <$> getField <*> getFields+ getFields = lookAhead getWord8 >>= \done -> if done == 0+ then return []+ else (:) <$> getField <*> getFields putArray :: [Value] -> Put putArray vs = putDocument (zipWith f [0..] vs)- where f i v = (U.pack $! show i) := v+ where f i v = (T.pack $! show i) := v getArray :: Get [Value] getArray = map value <$> getDocument@@ -155,34 +180,34 @@ type Subtype = Word8 putBinary :: Subtype -> ByteString -> Put-putBinary t x = let len = toEnum (length x) in do- putInt32 len- putTag t- putByteString x+putBinary t x = let len = toEnum (SC.length x) in do+ putInt32 len+ putTag t+ putByteString x getBinary :: Get (Subtype, ByteString) getBinary = do- len <- getInt32- t <- getTag- x <- getByteString (fromIntegral len)- return (t, x)+ len <- getInt32+ t <- getTag+ x <- getByteString (fromIntegral len)+ return (t, x) {-putBinary :: Subtype -> ByteString -> Put -- When Binary subtype (0x02) insert extra length field before bytes putBinary t x = let len = toEnum (length x) in do- putInt32 $ len + if t == 0x02 then 4 else 0- putTag t- when (t == 0x02) (putInt32 len)- putByteString x-}+ putInt32 $ len + if t == 0x02 then 4 else 0+ putTag t+ when (t == 0x02) (putInt32 len)+ putByteString x-} {-getBinary :: Get (Subtype, ByteString) -- When Binary subtype (0x02) there is an extra length field before bytes getBinary = do- len <- getInt32- t <- getTag- len' <- if t == 0x02 then getInt32 else return len- x <- getByteString (fromIntegral len')- return (t, x)-}+ len <- getInt32+ t <- getTag+ len' <- if t == 0x02 then getInt32 else return len+ x <- getByteString (fromIntegral len')+ return (t, x)-} putRegex (Regex x y) = putCString x >> putCString y getRegex = Regex <$> getCString <*> getCString@@ -207,17 +232,17 @@ -- stored as milliseconds since Unix epoch getUTC = posixSecondsToUTCTime . (/ 1000) . fromIntegral <$> getInt64 -putClosure :: UString -> Document -> Put+putClosure :: Text -> Document -> Put putClosure x y = let b = runPut (putString x >> putDocument y) in do- putInt32 $ (toEnum . fromEnum) (L.length b + 4) -- including this length field- putLazyByteString b+ putInt32 $ (toEnum . fromEnum) (LC.length b + 4) -- including this length field+ putLazyByteString b -getClosure :: Get (UString, Document)+getClosure :: Get (Text, Document) getClosure = do- getInt32- x <- getString- y <- getDocument- return (x, y)+ getInt32+ x <- getString+ y <- getDocument+ return (x, y) {- Authors: Tony Hannan <tony@10gen.com>
− Data/UString.hs
@@ -1,36 +0,0 @@--- | UTF-8 String--{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}--module Data.UString (- UString, u,- module Data.CompactString.UTF8,- module Data.CompactString-) where--import Data.CompactString () -- Show and IsString instances-import Data.CompactString.UTF8-import qualified Data.CompactString as S-import qualified Data.CompactString.Encodings as E-import Text.Read (Read(..))-import Data.Typeable-import Control.Applicative ((<$>))--deriving instance Typeable1 S.CompactString--deriving instance Typeable E.UTF8--instance Read CompactString where- readPrec = pack <$> readPrec--type UString = CompactString--- ^ UTF-8 String--u :: String -> UString-u = pack---{- Authors: Tony Hannan <tony@10gen.com>- Copyright 2010 10gen Inc.- Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -}
bson.cabal view
@@ -1,56 +1,78 @@-Name: bson-Version: 0.1.7-Synopsis: BSON documents are JSON-like objects with a standard binary encoding-Description: A BSON Document is an untyped (dynamically type-checked) record. I.e. it is a list of name-value pairs, where a Value is a single sum type with constructors for basic types (Bool, Int, Float, String, and Time), compound types (List, and (embedded) Document), and special types (Binary, Javascript, ObjectId, RegEx, and a few others).- .- A BSON Document is serialized to a standard binary encoding defined at <http://bsonspec.org>. This implements version 1 of that spec.+Name: bson+Version: 0.4.0.1+Synopsis: BSON documents are JSON-like objects with a standard binary+ encoding.+Description: A BSON Document is an untyped (dynamically type-checked) record.+ I.e. it is a list of name-value pairs, where a Value is a single+ sum type with constructors for basic types (Bool, Int, Float,+ String, and Time), compound types (List, and (embedded) Document),+ and special types (Binary, Javascript, ObjectId, RegEx, and a few+ others). -Category: Data-Homepage: http://github.com/TonyGen/bson-haskell-Author: Tony Hannan-Maintainer: Tony Hannan <tonyhannan@gmail.com>-Copyright: Copyright (c) 2010-2012 10gen Inc.-License: OtherLicense-License-file: LICENSE-cabal-version: >= 1.8-build-type: Simple+ A BSON Document is serialized to a standard binary encoding+ defined at <http://bsonspec.org>. This implements version 1 of+ that spec.+Category: Data+Homepage: http://github.com/mongodb-haskell/bson+Author: Tony Hannan+Maintainer: Fedor Gogolev <knsd@knsd.net>, Greg Weber <greg@gregweber.info>+Copyright: Copyright (c) 2010-2012 10gen Inc.+License: Apache-2.0+License-file: LICENSE+Cabal-version: >= 1.10+Build-type: Simple+Extra-Source-Files: CHANGELOG.md +Flag _old-network+ description: Control whether to use <http://hackage.haskell.org/package/network-bsd network-bsd>+ manual: False+ Library- Build-Depends: base < 5,- time,- bytestring,- network,- cryptohash,- binary,- data-binary-ieee754,- compact-string-fix,- mtl >= 2+ Build-depends: base >= 4.9.0.0 && < 5+ , time+ , bytestring+ , binary >= 0.5 && < 0.9+ , cryptohash-md5 == 0.11.*+ , data-binary-ieee754+ , mtl >= 2+ , text >= 0.11 - Exposed-modules: Data.UString,- Data.Bson,- Data.Bson.Binary+ if flag(_old-network)+ -- "Network.BSD" is only available in network < 2.9+ build-depends: network < 2.9+ else+ -- "Network.BSD" has been moved into its own package `network-bsd`+ build-depends: network-bsd >= 2.7 && < 2.9 - ghc-prof-options: -auto-all+ Default-Language: Haskell2010+ Default-Extensions: BangPatterns, CPP -test-suite test- type: exitcode-stdio-1.0- main-is: main.hs- hs-source-dirs: test, .+ Exposed-modules: Data.Bson,+ Data.Bson.Binary - build-depends: HUnit- , hspec >= 0.6.1 && < 0.7- , file-location >= 0.4 && < 0.5- , base >= 4 && < 5- , bson- , QuickCheck == 2.4.*+Source-repository head+ Type: git+ Location: https://github.com/mongodb-haskell/bson - , mtl >= 2- , network- , cryptohash- , bytestring- , time- , data-binary-ieee754- , compact-string-fix- , file-location+Test-suite bson-tests+ Type: exitcode-stdio-1.0+ Hs-source-dirs: tests+ Main-is: Tests.hs+ Other-modules: Data.Bson.Binary.Tests+ Data.Bson.Tests+ Ghc-options: -Wall -fno-warn-orphans - cpp-options: -DTEST+ -- NB: we depend here on the intra-package lib:bson componant+ Build-depends: bson+ -- test-specific dependencies+ , test-framework >= 0.4+ , test-framework-quickcheck2 >= 0.2+ , QuickCheck >= 2.4+ -- dependency constraints inherited from lib:bson component+ , base+ , time+ , bytestring+ , text++ Default-Language: Haskell2010+ Default-Extensions: CPP
− test/main.hs
@@ -1,29 +0,0 @@--- import Test.HUnit hiding (Test)-import Test.Hspec.Monadic (Specs, describe, it, hspecX)-import Test.Hspec.HUnit()-import Test.Hspec.QuickCheck(prop)-import Test.QuickCheck-import Data.Bson-import FileLocation (debug)--main :: IO ()-main = hspecX specs--instance Arbitrary ObjectId where- arbitrary = do- t <- arbitrary- p <- arbitrary- m <- arbitrary- i <- arbitrary- return $ Oid t $ composite m p i--specs :: Specs-specs = do- describe "ObjectId" $ do- prop "read <-> show" $ \objId ->- (debug . read . show . debug) objId == (objId :: ObjectId)-- describe "roundTo" $ do- prop "round" $ \d ->- let r = roundTo (1 / 10) (d :: Double)- in r == roundTo (1 / 10) r
+ tests/Data/Bson/Binary/Tests.hs view
@@ -0,0 +1,8 @@+module Data.Bson.Binary.Tests+ ( tests+ ) where++import Test.Framework (Test, testGroup)++tests :: Test+tests = testGroup "Data.Bson.Binary.Tests" []
+ tests/Data/Bson/Tests.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-}++module Data.Bson.Tests+ ( tests+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+#if MIN_VERSION_base(4,9,0)+import Control.Monad.Fail(MonadFail(..))+#endif+import Data.Int (Int32, Int64)+import Data.Time.Calendar (Day(ModifiedJulianDay))+import Data.Time.Clock.POSIX (POSIXTime)+import Data.Time.Clock (UTCTime(..), addUTCTime)+import qualified Data.ByteString as S++import Data.Text (Text)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary(..), elements, oneof, Property, (===))+import qualified Data.Text as T++import Data.Bson (Val(cast', val), ObjectId(..), MinMaxKey(..), MongoStamp(..),+ Symbol(..), Javascript(..), Regex(..), UserDefined(..),+ MD5(..), UUID(..), Function(..), Binary(..), Field((:=)),+ -- Document,+ Value(..))+import qualified Data.Bson as Bson++instance Arbitrary S.ByteString where+ arbitrary = S.pack <$> arbitrary++instance Arbitrary Text where+ arbitrary = T.pack <$> arbitrary++instance Arbitrary POSIXTime where+ arbitrary = fromInteger <$> arbitrary++instance Arbitrary UTCTime where+ arbitrary = do+ a <- arbitrary+ b <- arbitrary+ return $ addUTCTime (fromRational b)+ $ UTCTime (ModifiedJulianDay a) 0++instance Arbitrary ObjectId where+ arbitrary = Oid <$> arbitrary <*> arbitrary++instance Arbitrary MinMaxKey where+ arbitrary = elements [MinKey, MaxKey]++instance Arbitrary MongoStamp where+ arbitrary = MongoStamp <$> arbitrary++instance Arbitrary Symbol where+ arbitrary = Symbol <$> arbitrary++instance Arbitrary Javascript where+ arbitrary = Javascript <$> arbitrary <*> arbitrary++instance Arbitrary Regex where+ arbitrary = Regex <$> arbitrary <*> arbitrary++instance Arbitrary UserDefined where+ arbitrary = UserDefined <$> arbitrary++instance Arbitrary MD5 where+ arbitrary = MD5 <$> arbitrary++instance Arbitrary UUID where+ arbitrary = UUID <$> arbitrary++instance Arbitrary Function where+ arbitrary = Function <$> arbitrary++instance Arbitrary Binary where+ arbitrary = Binary <$> arbitrary++instance Arbitrary Field where+ arbitrary = (:=) <$> arbitrary <*> arbitrary++instance Arbitrary Value where+ arbitrary = oneof+ [ Bson.Float <$> arbitrary+ , Bson.String <$> arbitrary+ , Bson.Doc <$> arbitrary+ , Bson.Array <$> arbitrary+ , Bson.Bin <$> arbitrary+ , Bson.Fun <$> arbitrary+ , Bson.Uuid <$> arbitrary+ , Bson.Md5 <$> arbitrary+ , Bson.UserDef <$> arbitrary+ , Bson.ObjId <$> arbitrary+ , Bson.UTC <$> arbitrary+ , Bson.RegEx <$> arbitrary+ , Bson.JavaScr <$> arbitrary+ , Bson.Sym <$> arbitrary+ , Bson.Int32 <$> arbitrary+ , Bson.Int64 <$> arbitrary+ , Bson.Stamp <$> arbitrary+ , Bson.MinMax <$> arbitrary+ , return Bson.Null+ ]++testVal :: Val a => a -> Bool+testVal a = case cast' . val $ a of+ Nothing -> False+ Just a' -> a == a'++#if MIN_VERSION_base(4,9,0)+instance MonadFail (Either String) where+ fail = Left++testLookMonadFail :: Property+testLookMonadFail =+ (Bson.look "key" [] :: Either String Value)+ -- This is as opposed to an exception thrown from Prelude.fail:+ === Left "expected \"key\" in []"+#endif++tests :: Test+tests = testGroup "Data.Bson.Tests"+ [ testProperty "Val Bool" (testVal :: Bool -> Bool)+ , testProperty "Val Double" (testVal :: Double -> Bool)+ , testProperty "Val Float" (testVal :: Float -> Bool)+ , testProperty "Val Int" (testVal :: Int -> Bool)+ , testProperty "Val Int32" (testVal :: Int32 -> Bool)+ , testProperty "Val Int64" (testVal :: Int64 -> Bool)+ , testProperty "Val Integer" (testVal :: Integer -> Bool)+ , testProperty "Val String" (testVal :: String -> Bool)+ , testProperty "Val POSIXTime" (testVal :: POSIXTime -> Bool)+ , testProperty "Val UTCTime" (testVal :: UTCTime -> Bool)+ , testProperty "Val ObjectId" (testVal :: ObjectId -> Bool)+ , testProperty "Val MinMaxKey" (testVal :: MinMaxKey -> Bool)+ , testProperty "Val MongoStamp" (testVal :: MongoStamp -> Bool)+ , testProperty "Val Symbol" (testVal :: Symbol -> Bool)+ -- , testProperty "Val Javascript" (testVal :: Javascript -> Bool)+ , testProperty "Val Regex" (testVal :: Regex -> Bool)+ , testProperty "Val UserDefined" (testVal :: UserDefined -> Bool)+ , testProperty "Val MD5" (testVal :: MD5 -> Bool)+ , testProperty "Val UUID" (testVal :: UUID -> Bool)+ , testProperty "Val Function" (testVal :: Function -> Bool)+ , testProperty "Val Binary" (testVal :: Binary -> Bool)+ -- , testProperty "Val Document" (testVal :: Document -> Bool)+ , testProperty "Val Text" (testVal :: Text -> Bool)++#if MIN_VERSION_base(4,9,0)+ , testProperty "'look' uses MonadFail.fail" testLookMonadFail+#endif+ ]
+ tests/Tests.hs view
@@ -0,0 +1,12 @@+module Main where++import Test.Framework (defaultMain)++import qualified Data.Bson.Tests+import qualified Data.Bson.Binary.Tests++main :: IO ()+main = defaultMain+ [ Data.Bson.Tests.tests+ , Data.Bson.Binary.Tests.tests+ ]