BSON: use Integers to represent oid's, oid generation

This commit is contained in:
Scott R. Parish 2010-03-13 00:23:05 -06:00
parent 6045cc5c4b
commit e7c58bf4d7
3 changed files with 41 additions and 3 deletions

View file

@ -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
View file

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

View file

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