-- | 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

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,
                        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 :: Field -> Put
putField (Label
k := Value
v) = case Value
v of
  Float Double
x                       -> Word8 -> Put
putTL Word8
0x01 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Put
putDouble Double
x
  String Label
x                      -> Word8 -> Put
putTL Word8
0x02 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Label -> Put
putString Label
x
  Doc Document
x                         -> Word8 -> Put
putTL Word8
0x03 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Document -> Put
putDocument Document
x
  Array [Value]
x                       -> Word8 -> Put
putTL Word8
0x04 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Value] -> Put
putArray [Value]
x
  Bin (Binary ByteString
x)                -> Word8 -> Put
putTL Word8
0x05 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> ByteString -> Put
putBinary Word8
0x00 ByteString
x
  Fun (Function ByteString
x)              -> Word8 -> Put
putTL Word8
0x05 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> ByteString -> Put
putBinary Word8
0x01 ByteString
x
  Uuid (UUID ByteString
x)                 -> Word8 -> Put
putTL Word8
0x05 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> ByteString -> Put
putBinary Word8
0x04 ByteString
x
  Md5 (MD5 ByteString
x)                   -> Word8 -> Put
putTL Word8
0x05 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> ByteString -> Put
putBinary Word8
0x05 ByteString
x
  UserDef (UserDefined ByteString
x)       -> Word8 -> Put
putTL Word8
0x05 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> ByteString -> Put
putBinary Word8
0x80 ByteString
x
  ObjId ObjectId
x                       -> Word8 -> Put
putTL Word8
0x07 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ObjectId -> Put
putObjectId ObjectId
x
  Bool Bool
x                        -> Word8 -> Put
putTL Word8
0x08 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Put
putBool Bool
x
  UTC UTCTime
x                         -> Word8 -> Put
putTL Word8
0x09 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UTCTime -> Put
putUTC UTCTime
x
  Value
Null                          -> Word8 -> Put
putTL Word8
0x0A
  RegEx Regex
x                       -> Word8 -> Put
putTL Word8
0x0B Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Regex -> Put
putRegex Regex
x
  JavaScr (Javascript Document
env Label
code) ->
    if Document -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
env
    then Word8 -> Put
putTL Word8
0x0D Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Label -> Put
putString Label
code
    else Word8 -> Put
putTL Word8
0x0F Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Label -> Document -> Put
putClosure Label
code Document
env
  Sym Symbol
x                         -> Word8 -> Put
putTL Word8
0x0E Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Symbol -> Put
putSymbol Symbol
x
  Int32 Int32
x                       -> Word8 -> Put
putTL Word8
0x10 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int32 -> Put
putInt32 Int32
x
  Int64 Int64
x                       -> Word8 -> Put
putTL Word8
0x12 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int64 -> Put
putInt64 Int64
x
  Stamp MongoStamp
x                       -> Word8 -> Put
putTL Word8
0x11 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MongoStamp -> Put
putMongoStamp MongoStamp
x
  MinMax MinMaxKey
x                      ->
    case MinMaxKey
x of
     MinMaxKey
MinKey -> Word8 -> Put
putTL Word8
0xFF
     MinMaxKey
MaxKey -> Word8 -> Put
putTL Word8
0x7F
 where
  putTL :: Word8 -> Put
putTL Word8
t = Word8 -> Put
putTag Word8
t Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Label -> Put
putLabel Label
k

getField :: Get Field
-- ^ Read binary representation of Element
getField :: Get Field
getField = do
  Word8
t <- Get Word8
getTag
  Label
k <- Get Label
getLabel
  Value
v <- case Word8
t of
        Word8
0x01 -> Double -> Value
Float (Double -> Value) -> Get Double -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Double
getDouble
        Word8
0x02 -> Label -> Value
String (Label -> Value) -> Get Label -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Label
getString
        Word8
0x03 -> Document -> Value
Doc (Document -> Value) -> Get Document -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Document
getDocument
        Word8
0x04 -> [Value] -> Value
Array ([Value] -> Value) -> Get [Value] -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [Value]
getArray
        Word8
0x05 -> Get (Word8, ByteString)
getBinary Get (Word8, ByteString)
-> ((Word8, ByteString) -> Get Value) -> Get Value
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Word8
s, ByteString
b) ->
          case Word8
s of
           Word8
0x00 -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ Binary -> Value
Bin (ByteString -> Binary
Binary ByteString
b)
           Word8
0x01 -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ Function -> Value
Fun (ByteString -> Function
Function ByteString
b)
           Word8
0x02 -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ Binary -> Value
Bin (ByteString -> Binary
Binary ByteString
b)
           Word8
0x03 -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ UUID -> Value
Uuid (ByteString -> UUID
UUID ByteString
b)
           Word8
0x04 -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ UUID -> Value
Uuid (ByteString -> UUID
UUID ByteString
b)
           Word8
0x05 -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ MD5 -> Value
Md5 (ByteString -> MD5
MD5 ByteString
b)
           Word8
0x80 -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Get Value) -> Value -> Get Value
forall a b. (a -> b) -> a -> b
$ UserDefined -> Value
UserDef (ByteString -> UserDefined
UserDefined ByteString
b)
           Word8
_ -> String -> Get Value
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Value) -> String -> Get Value
forall a b. (a -> b) -> a -> b
$ String
"unknown Bson binary subtype " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
s
        Word8
0x06 -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
        Word8
0x07 -> ObjectId -> Value
ObjId (ObjectId -> Value) -> Get ObjectId -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ObjectId
getObjectId
        Word8
0x08 -> Bool -> Value
Bool (Bool -> Value) -> Get Bool -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Bool
getBool
        Word8
0x09 -> UTCTime -> Value
UTC (UTCTime -> Value) -> Get UTCTime -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get UTCTime
getUTC
        Word8
0x0A -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
        Word8
0x0B -> Regex -> Value
RegEx (Regex -> Value) -> Get Regex -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Regex
getRegex
        Word8
0x0C -> ObjectId -> Value
ObjId (ObjectId -> Value) -> Get ObjectId -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ObjectId
getObjectId Get Value -> Get Label -> Get Value
forall a b. Get a -> Get b -> Get a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Get Label
getString
        Word8
0x0D -> Javascript -> Value
JavaScr (Javascript -> Value) -> (Label -> Javascript) -> Label -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Label -> Javascript
Javascript [] (Label -> Value) -> Get Label -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Label
getString
        Word8
0x0E -> Symbol -> Value
Sym (Symbol -> Value) -> Get Symbol -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Symbol
getSymbol
        Word8
0x0F -> Javascript -> Value
JavaScr (Javascript -> Value)
-> ((Label, Document) -> Javascript) -> (Label, Document) -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label -> Document -> Javascript)
-> (Label, Document) -> Javascript
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Document -> Label -> Javascript)
-> Label -> Document -> Javascript
forall a b c. (a -> b -> c) -> b -> a -> c
flip Document -> Label -> Javascript
Javascript) ((Label, Document) -> Value) -> Get (Label, Document) -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Label, Document)
getClosure
        Word8
0x10 -> Int32 -> Value
Int32 (Int32 -> Value) -> Get Int32 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32
        Word8
0x11 -> MongoStamp -> Value
Stamp (MongoStamp -> Value) -> Get MongoStamp -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MongoStamp
getMongoStamp
        Word8
0x12 -> Int64 -> Value
Int64 (Int64 -> Value) -> Get Int64 -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
getInt64
        Word8
0xFF -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (MinMaxKey -> Value
MinMax MinMaxKey
MinKey)
        Word8
0x7F -> Value -> Get Value
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (MinMaxKey -> Value
MinMax MinMaxKey
MaxKey)
        Word8
_ -> String -> Get Value
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Value) -> String -> Get Value
forall a b. (a -> b) -> a -> b
$ String
"unknown Bson value type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
t
  Field -> Get Field
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Label
k Label -> Value -> Field
:= Value
v)

putTag :: Word8 -> Put
putTag = Word8 -> Put
putWord8
getTag :: Get Word8
getTag = Get Word8
getWord8

putLabel :: Label -> Put
putLabel = Label -> Put
putCString
getLabel :: Get Label
getLabel = Get Label
getCString

putDouble :: Double -> Put
putDouble = Double -> Put
putFloat64le
getDouble :: Get Double
getDouble = Get Double
getFloat64le

putInt32 :: Int32 -> Put
putInt32 :: Int32 -> Put
putInt32 = Word32 -> Put
putWord32le (Word32 -> Put) -> (Int32 -> Word32) -> Int32 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

getInt32 :: Get Int32
getInt32 :: Get Int32
getInt32 = Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int32) -> Get Word32 -> Get Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le

putInt64 :: Int64 -> Put
putInt64 :: Int64 -> Put
putInt64 = Word64 -> Put
putWord64le (Word64 -> Put) -> (Int64 -> Word64) -> Int64 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

getInt64 :: Get Int64
getInt64 :: Get Int64
getInt64 = Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int64) -> Get Word64 -> Get Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64le

putCString :: Text -> Put
putCString :: Label -> Put
putCString Label
x = do
  ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Label -> ByteString
TE.encodeUtf8 Label
x
  Word8 -> Put
putWord8 Word8
0

getCString :: Get Text
getCString :: Get Label
getCString = ByteString -> Label
TE.decodeUtf8 (ByteString -> Label)
-> (ByteString -> ByteString) -> ByteString -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
SC.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LC.toChunks (ByteString -> Label) -> Get ByteString -> Get Label
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getLazyByteStringNul

putString :: Text -> Put
putString :: Label -> Put
putString Label
x = let b :: ByteString
b = Label -> ByteString
TE.encodeUtf8 Label
x in do
  Int32 -> Put
putInt32 (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a. Enum a => Int -> a
toEnum (ByteString -> Int
SC.length ByteString
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ByteString -> Put
putByteString ByteString
b
  Word8 -> Put
putWord8 Word8
0

getString :: Get Text
getString :: Get Label
getString = do
  Int32
len <- Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
subtract Int32
1 (Int32 -> Int32) -> Get Int32 -> Get Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32
  ByteString
b <- Int -> Get ByteString
getByteString (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
  Get Word8
getWord8
  Label -> Get Label
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Label -> Get Label) -> Label -> Get Label
forall a b. (a -> b) -> a -> b
$ ByteString -> Label
TE.decodeUtf8 ByteString
b

putDocument :: Document -> Put
putDocument :: Document -> Put
putDocument Document
es = let b :: ByteString
b = Put -> ByteString
runPut ((Field -> Put) -> Document -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Field -> Put
putField Document
es) in do
  Int32 -> Put
putInt32 (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ (Int -> Int32
forall a. Enum a => Int -> a
toEnum (Int -> Int32) -> (Int64 -> Int) -> Int64 -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a. Enum a => a -> Int
fromEnum) (ByteString -> Int64
LC.length ByteString
b Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
5)  -- include length and null terminator
  ByteString -> Put
putLazyByteString ByteString
b
  Word8 -> Put
putWord8 Word8
0

getDocument :: Get Document
getDocument :: Get Document
getDocument = do
  Int32
len <- Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
subtract Int32
4 (Int32 -> Int32) -> Get Int32 -> Get Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32
  ByteString
b <- Int64 -> Get ByteString
getLazyByteString (Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
  Document -> Get Document
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Get Document -> ByteString -> Document
forall a. Get a -> ByteString -> a
runGet Get Document
getFields ByteString
b)
 where
  getFields :: Get Document
getFields = Get Word8 -> Get Word8
forall a. Get a -> Get a
lookAhead Get Word8
getWord8 Get Word8 -> (Word8 -> Get Document) -> Get Document
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word8
done -> if Word8
done Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0
   then Document -> Get Document
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return []
   else (:) (Field -> Document -> Document)
-> Get Field -> Get (Document -> Document)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Field
getField Get (Document -> Document) -> Get Document -> Get Document
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Document
getFields

putArray :: [Value] -> Put
putArray :: [Value] -> Put
putArray [Value]
vs = Document -> Put
putDocument ((Integer -> Value -> Field) -> [Integer] -> [Value] -> Document
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> Value -> Field
forall {a}. Show a => a -> Value -> Field
f [Integer
0..] [Value]
vs)
  where f :: a -> Value -> Field
f a
i Value
v = (String -> Label
T.pack (String -> Label) -> String -> Label
forall a b. (a -> b) -> a -> b
$! a -> String
forall a. Show a => a -> String
show a
i) Label -> Value -> Field
:= Value
v

getArray :: Get [Value]
getArray :: Get [Value]
getArray = (Field -> Value) -> Document -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Value
value (Document -> [Value]) -> Get Document -> Get [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Document
getDocument

type Subtype = Word8

putBinary :: Subtype -> ByteString -> Put
putBinary :: Word8 -> ByteString -> Put
putBinary Word8
t ByteString
x = let len :: Int32
len = Int -> Int32
forall a. Enum a => Int -> a
toEnum (ByteString -> Int
SC.length ByteString
x) in do
  Int32 -> Put
putInt32 Int32
len
  Word8 -> Put
putTag Word8
t
  ByteString -> Put
putByteString ByteString
x

getBinary :: Get (Subtype, ByteString)
getBinary :: Get (Word8, ByteString)
getBinary = do
  Int32
len <- Get Int32
getInt32
  Word8
t <- Get Word8
getTag
  ByteString
x <- Int -> Get ByteString
getByteString (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
  (Word8, ByteString) -> Get (Word8, ByteString)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8
t, ByteString
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-}

{-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)-}

putRegex :: Regex -> Put
putRegex (Regex Label
x Label
y) = Label -> Put
putCString Label
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Label -> Put
putCString Label
y
getRegex :: Get Regex
getRegex = Label -> Label -> Regex
Regex (Label -> Label -> Regex) -> Get Label -> Get (Label -> Regex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Label
getCString Get (Label -> Regex) -> Get Label -> Get Regex
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Label
getCString

putSymbol :: Symbol -> Put
putSymbol (Symbol Label
x) = Label -> Put
putString Label
x
getSymbol :: Get Symbol
getSymbol = Label -> Symbol
Symbol (Label -> Symbol) -> Get Label -> Get Symbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Label
getString

putMongoStamp :: MongoStamp -> Put
putMongoStamp (MongoStamp Int64
x) = Int64 -> Put
putInt64 Int64
x
getMongoStamp :: Get MongoStamp
getMongoStamp = Int64 -> MongoStamp
MongoStamp (Int64 -> MongoStamp) -> Get Int64 -> Get MongoStamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
getInt64

putObjectId :: ObjectId -> Put
putObjectId (Oid Word32
x Word64
y) = Word32 -> Put
putWord32be Word32
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> Put
putWord64be Word64
y
getObjectId :: Get ObjectId
getObjectId = Word32 -> Word64 -> ObjectId
Oid (Word32 -> Word64 -> ObjectId)
-> Get Word32 -> Get (Word64 -> ObjectId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be Get (Word64 -> ObjectId) -> Get Word64 -> Get ObjectId
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word64
getWord64be

putBool :: Bool -> Put
putBool Bool
x = Word8 -> Put
putWord8 (if Bool
x then Word8
1 else Word8
0)
getBool :: Get Bool
getBool = (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0) (Word8 -> Bool) -> Get Word8 -> Get Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8

putUTC :: UTCTime -> Put
-- store milliseconds since Unix epoch
putUTC :: UTCTime -> Put
putUTC UTCTime
x = Int64 -> Put
putInt64 (Int64 -> Put) -> Int64 -> Put
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Int64
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
x POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000)

getUTC :: Get UTCTime
-- stored as milliseconds since Unix epoch
getUTC :: Get UTCTime
getUTC = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> (Int64 -> POSIXTime) -> Int64 -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Fractional a => a -> a -> a
/ POSIXTime
1000) (POSIXTime -> POSIXTime)
-> (Int64 -> POSIXTime) -> Int64 -> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> UTCTime) -> Get Int64 -> Get UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
getInt64

putClosure :: Text -> Document -> Put
putClosure :: Label -> Document -> Put
putClosure Label
x Document
y = let b :: ByteString
b = Put -> ByteString
runPut (Label -> Put
putString Label
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Document -> Put
putDocument Document
y) in do
  Int32 -> Put
putInt32 (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ (Int -> Int32
forall a. Enum a => Int -> a
toEnum (Int -> Int32) -> (Int64 -> Int) -> Int64 -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a. Enum a => a -> Int
fromEnum) (ByteString -> Int64
LC.length ByteString
b Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4)  -- including this length field
  ByteString -> Put
putLazyByteString ByteString
b

getClosure :: Get (Text, Document)
getClosure :: Get (Label, Document)
getClosure = do
  Get Int32
getInt32
  Label
x <- Get Label
getString
  Document
y <- Get Document
getDocument
  (Label, Document) -> Get (Label, Document)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Label
x, Document
y)


{- 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. -}