bson 0.3.1 → 0.3.2

raw patch · 5 files changed

+334/−319 lines, 5 filesnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• Data/Bson.hs +206/−214
• Data/Bson/Binary.hs +114/−103
• bson.cabal +5/−2
• tests/Data/Bson/Tests.hs +2/−0

@@ -0,0 +1,7 @@+# 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.3.2] - 2015-10-28++### Added+- Old binary UUID subtype.

@@ -10,22 +10,24 @@ {-# LANGUAGE TypeSynonymInstances #-}  module Data.Bson (-	-- * 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+  -- * 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)+#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))+#endif import Control.Monad (foldM) import Data.Bits (shift, (.|.)) import Data.Int (Int32, Int64)@@ -68,8 +70,8 @@ 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' :: Double) + 1+  sigDigits 0 = 1+  sigDigits n' = truncate (logBase 16 $ fromIntegral n' :: Double) + 1  -- * Document @@ -79,13 +81,12 @@ -- | 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+  where chunks = T.split (== '.') l  look :: (Monad 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 value of field in document and cast to expected type. Fail (Nothing) if field not found or value not of expected type.@@ -98,9 +99,9 @@ at :: (Val v) => Label -> Document -> v -- ^ Typed value of field in document. Error if missing or wrong type. at k doc = result-	where-		result = fromMaybe err (lookup k doc)-		err = error $ "expected (" ++ show k ++ " :: " ++ show (typeOf result) ++ ") in " ++ show doc+  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@@ -112,10 +113,10 @@  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 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+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 @@ -133,7 +134,7 @@ k =? ma = maybeToList (fmap (k =:) ma)  instance Show Field where-	showsPrec d (k := v) = showParen (d > 0) $ showString (' ' : T.unpack k) . showString ": " . showsPrec 1 v+  showsPrec d (k := v) = showParen (d > 0) $ showString (' ' : T.unpack k) . showString ": " . showsPrec 1 v  type Label = Text -- ^ The name of a BSON field@@ -141,66 +142,65 @@ -- * Value  -- | A BSON value is one of the following types of values-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)+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 = fval (showsPrec d)+  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 :: (Val a, Monad m) => Value -> m a -- ^ Convert Value to expected type, or fail (Nothing) if not of that type 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+  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.@@ -214,185 +214,177 @@  -- | Haskell types of this class correspond to BSON value types class (Typeable a, Show a, Eq a) => Val a where--	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)+  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 Text where-	val = String-	cast' (String x) = Just x-	cast' (Sym (Symbol x)) = Just x-	cast' _ = Nothing+  val                    = String+  cast' (String x)       = Just x+  cast' (Sym (Symbol x)) = Just 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+  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 Field where-	val x = valList [x]-	valList = Doc-	cast' _ = Nothing-	cast'List v = case v of-		Doc x -> Just x-		_ -> Nothing+  val x   = valList [x]+  valList = Doc+  cast' _ = Nothing+  cast'List v = case v of+                 Doc x -> Just x+                 _     -> Nothing  instance Val Value where-	val = id-	cast' = Just+  val   = id+  cast' = Just  instance (Val a) => Val [a] where-	val = valList-	cast' = cast'List+  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-	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+  val           = UTC . posixSecondsToUTCTime . roundTo (1/1000)+  cast' (UTC x) = Just (utcTimeToPOSIXSeconds x)+  cast' _       = Nothing  instance (Val a) => Val (Maybe a) where-	val = valMaybe-	cast' = cast'Maybe+  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 :: (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 `asTypeOf` result) <= n && n <= fromIntegral (maxBound `asTypeOf` result)-		then Just result-		else Nothing-	where-		result = fromIntegral 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 @@ -436,13 +428,13 @@ -- ^ 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@@ -451,19 +443,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 . 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)+  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

@@ -1,15 +1,22 @@ -- | 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)+#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,@@ -38,66 +45,70 @@ 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 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+  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)-			0x04 -> 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+        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)  putTag = putWord8 getTag = getWord8@@ -122,44 +133,44 @@  putCString :: Text -> Put putCString x = do-	putByteString $ TE.encodeUtf8 x-	putWord8 0+  putByteString $ TE.encodeUtf8 x+  putWord8 0  getCString :: Get Text getCString = TE.decodeUtf8 . SC.concat . LC.toChunks <$> getLazyByteStringNul  putString :: Text -> Put putString x = let b = TE.encodeUtf8 x in do-	putInt32 $ toEnum (SC.length b + 1)-	putByteString b-	putWord8 0+  putInt32 $ toEnum (SC.length b + 1)+  putByteString b+  putWord8 0  getString :: Get Text getString = do-	len <- subtract 1 <$> getInt32-	b <- getByteString (fromIntegral len)-	getWord8-	return $ TE.decodeUtf8 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) (LC.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 4 <$> getInt32-	b <- getLazyByteString (fromIntegral len)-	return (runGet getFields b)+  len <- subtract 4 <$> getInt32+  b <- getLazyByteString (fromIntegral len)+  return (runGet getFields b)  where-	getFields = lookAhead getWord8 >>= \done -> if done == 0-		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 = (T.pack $! show i) := v+  where f i v = (T.pack $! show i) := v  getArray :: Get [Value] getArray = map value <$> getDocument@@ -168,33 +179,33 @@  putBinary :: Subtype -> ByteString -> Put putBinary t x = let len = toEnum (SC.length x) in do-	putInt32 len-	putTag t-	putByteString x+  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@@ -221,15 +232,15 @@  putClosure :: Text -> Document -> Put putClosure x y = let b = runPut (putString x >> putDocument y) in do-	putInt32 $ (toEnum . fromEnum) (LC.length b + 4)  -- including this length field-	putLazyByteString b+  putInt32 $ (toEnum . fromEnum) (LC.length b + 4)  -- including this length field+  putLazyByteString b  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>

@@ -1,5 +1,5 @@ Name:          bson-Version:       0.3.1+Version:       0.3.2 Synopsis:      BSON documents are JSON-like objects with a standard binary                encoding. Description:   A BSON Document is an untyped (dynamically type-checked) record.@@ -21,6 +21,7 @@ License-file:  LICENSE Cabal-version: >= 1.10 Build-type:    Simple+Extra-Source-Files: CHANGELOG.md  Library   Build-depends:      base < 5@@ -34,7 +35,7 @@                     , text >= 0.11    Default-Language: Haskell2010-  Default-Extensions: BangPatterns+  Default-Extensions: BangPatterns, CPP    Exposed-modules:  Data.Bson,                     Data.Bson.Binary@@ -62,3 +63,5 @@                     , mtl >= 2                     , network                     , text >= 0.11+  Default-Language: Haskell2010+  Default-Extensions: CPP

@@ -4,7 +4,9 @@     ( tests     ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>))+#endif import Data.Int (Int32, Int64) import Data.Time.Calendar (Day(ModifiedJulianDay)) import Data.Time.Clock.POSIX (POSIXTime)