BSON: use Integers to represent oid's, oid generation
This commit is contained in:
parent
6045cc5c4b
commit
e7c58bf4d7
3 changed files with 41 additions and 3 deletions
|
@ -36,6 +36,8 @@ module Database.MongoDB.BSON
|
||||||
fromBsonDoc, toBsonDoc,
|
fromBsonDoc, toBsonDoc,
|
||||||
-- * Binary encoding/decoding
|
-- * Binary encoding/decoding
|
||||||
getBsonDoc, putBsonDoc,
|
getBsonDoc, putBsonDoc,
|
||||||
|
-- * ObjectId creation
|
||||||
|
mkObjectIdGen, genObjectId,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
|
@ -47,16 +49,22 @@ import Data.Binary
|
||||||
import Data.Binary.Get
|
import Data.Binary.Get
|
||||||
import Data.Binary.IEEE754
|
import Data.Binary.IEEE754
|
||||||
import Data.Binary.Put
|
import Data.Binary.Put
|
||||||
|
import Data.Bits
|
||||||
import Data.ByteString.Char8 as C8 hiding (empty)
|
import Data.ByteString.Char8 as C8 hiding (empty)
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import qualified Data.ByteString.Lazy.UTF8 as L8
|
import qualified Data.ByteString.Lazy.UTF8 as L8
|
||||||
import qualified Data.ByteString.UTF8 as S8
|
import qualified Data.ByteString.UTF8 as S8
|
||||||
|
import Data.Digest.OpenSSL.MD5
|
||||||
import Data.Int
|
import Data.Int
|
||||||
|
import Data.IORef
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import Data.Time.Clock.POSIX
|
import Data.Time.Clock.POSIX
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import Database.MongoDB.Util
|
import Database.MongoDB.Util
|
||||||
|
import Network.BSD
|
||||||
|
import Numeric
|
||||||
|
import System.Posix.Process
|
||||||
|
|
||||||
-- | BsonValue is the type that can be used as a key in a 'BsonDoc'.
|
-- | BsonValue is the type that can be used as a key in a 'BsonDoc'.
|
||||||
data BsonValue
|
data BsonValue
|
||||||
|
@ -66,7 +74,7 @@ data BsonValue
|
||||||
| BsonArray [BsonValue]
|
| BsonArray [BsonValue]
|
||||||
| BsonUndefined
|
| BsonUndefined
|
||||||
| BsonBinary BinarySubType L.ByteString
|
| BsonBinary BinarySubType L.ByteString
|
||||||
| BsonObjectId L.ByteString
|
| BsonObjectId Integer
|
||||||
| BsonBool !Bool
|
| BsonBool !Bool
|
||||||
| BsonDate POSIXTime
|
| BsonDate POSIXTime
|
||||||
| BsonNull
|
| BsonNull
|
||||||
|
@ -137,6 +145,29 @@ fromBinarySubType :: BinarySubType -> Int8
|
||||||
fromBinarySubType BSTUserDefined = 0x80
|
fromBinarySubType BSTUserDefined = 0x80
|
||||||
fromBinarySubType d = fromIntegral $ fromEnum d
|
fromBinarySubType d = fromIntegral $ fromEnum d
|
||||||
|
|
||||||
|
data ObjectIdGen = ObjectIdGen {
|
||||||
|
oigMachine :: Integer,
|
||||||
|
oigInc :: IORef Integer
|
||||||
|
}
|
||||||
|
|
||||||
|
mkObjectIdGen :: IO ObjectIdGen
|
||||||
|
mkObjectIdGen = do
|
||||||
|
host <- liftM (fst . (!! 0) . readHex . List.take 6 . md5sum . C8.pack)
|
||||||
|
getHostName
|
||||||
|
inc <- newIORef 0
|
||||||
|
return ObjectIdGen {oigMachine = host, oigInc = inc}
|
||||||
|
|
||||||
|
genObjectId :: ObjectIdGen -> IO BsonValue
|
||||||
|
genObjectId oig = do
|
||||||
|
now <- liftM (truncate . (realToFrac :: POSIXTime -> Double)) getPOSIXTime
|
||||||
|
pid <- liftM fromIntegral getProcessID
|
||||||
|
inc <- atomicModifyIORef (oigInc oig) $ \i -> ((i+1) `rem` 0x10000, i)
|
||||||
|
return $ BsonObjectId
|
||||||
|
((now `shiftL` 64) .|.
|
||||||
|
oigMachine oig `shiftL` 40 .|.
|
||||||
|
(0xffff .&. pid) `shiftL` 24 .|.
|
||||||
|
(inc `div` 0x100) `shiftL` 8 .|. (inc `rem` 0x100))
|
||||||
|
|
||||||
getBsonDoc :: Get BsonDoc
|
getBsonDoc :: Get BsonDoc
|
||||||
getBsonDoc = liftM snd getDoc
|
getBsonDoc = liftM snd getDoc
|
||||||
|
|
||||||
|
@ -168,7 +199,11 @@ getVal DataBinary = do
|
||||||
return (hdrLen + fromIntegral len, BsonBinary (toBinarySubType st) bs)
|
return (hdrLen + fromIntegral len, BsonBinary (toBinarySubType st) bs)
|
||||||
|
|
||||||
getVal DataUndefined = return (1, BsonUndefined)
|
getVal DataUndefined = return (1, BsonUndefined)
|
||||||
getVal DataOid = liftM ((,) 12 . BsonObjectId) $ getLazyByteString 12
|
getVal DataOid = do
|
||||||
|
oid1 <- getWord64be
|
||||||
|
oid2 <- getWord32be
|
||||||
|
let oid = (fromIntegral oid1 `shiftL` 32) .|. fromIntegral oid2
|
||||||
|
return (12, BsonObjectId oid)
|
||||||
getVal DataBoolean = liftM ((,) (1::Integer) . BsonBool . (/= (0::Int))) getI8
|
getVal DataBoolean = liftM ((,) (1::Integer) . BsonBool . (/= (0::Int))) getI8
|
||||||
getVal DataDate = liftM ((,) 8 . BsonDate . flip (/) 1000 . realToFrac) getI64
|
getVal DataDate = liftM ((,) 8 . BsonDate . flip (/) 1000 . realToFrac) getI64
|
||||||
getVal DataNull = return (1, BsonNull)
|
getVal DataNull = return (1, BsonNull)
|
||||||
|
@ -260,7 +295,8 @@ putVal (BsonBinary t bs)= do putI32 $ fromIntegral $ 4 + L.length bs
|
||||||
putI32 $ fromIntegral $ L.length bs
|
putI32 $ fromIntegral $ L.length bs
|
||||||
putLazyByteString bs
|
putLazyByteString bs
|
||||||
putVal BsonUndefined = putNothing
|
putVal BsonUndefined = putNothing
|
||||||
putVal (BsonObjectId o) = putLazyByteString o
|
putVal (BsonObjectId o) = putWord64be (fromIntegral $ o `shiftR` 32) >>
|
||||||
|
putWord32be (fromIntegral $ o .&. 0xffffffff)
|
||||||
putVal (BsonBool False) = putI8 0
|
putVal (BsonBool False) = putI8 0
|
||||||
putVal (BsonBool True) = putI8 1
|
putVal (BsonBool True) = putI8 1
|
||||||
putVal (BsonDate pt) = putI64 $ round $ 1000 * (realToFrac pt :: Double)
|
putVal (BsonDate pt) = putI64 $ round $ 1000 * (realToFrac pt :: Double)
|
||||||
|
|
1
TODO
1
TODO
|
@ -105,3 +105,4 @@ update tutorial to match new python one
|
||||||
+ custom types (see python examples)
|
+ custom types (see python examples)
|
||||||
+ support array conversions again
|
+ support array conversions again
|
||||||
+ better type conversion errors
|
+ better type conversion errors
|
||||||
|
+ make BSON an instance of Binary (eg get/put)
|
|
@ -21,6 +21,7 @@ Build-Depends: base < 5,
|
||||||
network,
|
network,
|
||||||
random,
|
random,
|
||||||
time,
|
time,
|
||||||
|
unix,
|
||||||
utf8-string,
|
utf8-string,
|
||||||
nano-md5
|
nano-md5
|
||||||
Build-Type: Simple
|
Build-Type: Simple
|
||||||
|
|
Loading…
Reference in a new issue