module Data.Bson (
module Data.UString,
Document, look, lookup, valueAt, at, include, exclude, merge,
Field(..), (=:), (=?),
Label,
Value(..), Val(..), fval, cast, typed, typeOfVal,
Binary(..), Function(..), UUID(..), MD5(..), UserDefined(..),
Regex(..), Javascript(..), Symbol(..), MongoStamp(..), MinMaxKey(..),
ObjectId(..), timestamp, genObjectId
#ifdef TEST
, composite
, roundTo
#endif
) 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)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX
import Data.Time.Format ()
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 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 qualified Text.ParserCombinators.ReadP as R
import qualified Text.ParserCombinators.ReadPrec as R (lift, readS_to_Prec)
import Text.Read (Read(..))
getProcessID :: IO Int
getProcessID = c_getpid
foreign import ccall unsafe "getpid"
c_getpid :: IO Int
roundTo :: (RealFrac a) => a -> a -> a
roundTo mult n = fromIntegral (round (n / mult)) * mult
showHexLen :: (Integral n) => Int -> n -> ShowS
showHexLen d n = showString (replicate (d sigDigits n) '0') . showHex n where
sigDigits 0 = 1
sigDigits n' = truncate (logBase 16 $ fromIntegral n') + 1
type Document = [Field]
look :: (Monad m) => Label -> Document -> m Value
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 k doc = cast =<< look k doc
valueAt :: Label -> Document -> Value
valueAt k = runIdentity . look k
at :: forall v. (Val v) => Label -> Document -> v
at k doc = maybe err id (lookup k doc) where
err = error $ "expected (" ++ show k ++ " :: " ++ show (typeOf (undefined :: v)) ++ ") in " ++ show doc
include :: [Label] -> Document -> Document
include keys doc = mapMaybe (\k -> find ((k ==) . label) doc) keys
exclude :: [Label] -> Document -> Document
exclude keys doc = filter (\(k := _) -> notElem k keys) doc
merge :: Document -> Document -> Document
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
infix 0 :=, =:, =?
data Field = (:=) {label :: !Label, value :: Value} deriving (Typeable, Eq)
(=:) :: (Val v) => Label -> v -> Field
k =: v = k := val v
(=?) :: (Val a) => Label -> Maybe a -> Document
k =? ma = maybeToList (fmap (k =:) ma)
instance Show Field where
showsPrec d (k := v) = showParen (d > 0) $ showString (' ' : unpack k) . showString ": " . showsPrec 1 v
type Label = UString
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)
instance Show Value where
showsPrec d v = fval (showsPrec d) v
fval :: (forall a . (Val a) => a -> b) -> Value -> b
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
cast :: forall m a. (Val a, Monad m) => Value -> m a
cast v = maybe notType return (cast' v) where
notType = fail $ "expected " ++ show (typeOf (undefined :: a)) ++ ": " ++ show v
typed :: (Val a) => Value -> a
typed = runIdentity . cast
typeOfVal :: Value -> TypeRep
typeOfVal = fval typeOf
class (Typeable a, Show a, Eq a) => Val a where
val :: a -> Value
cast' :: Value -> Maybe a
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
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
instance Val UString 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 Document where
val = Doc
cast' (Doc x) = Just x
cast' _ = Nothing
instance Val [Value] where
val = Array
cast' (Array x) = Just x
cast' _ = Nothing
instance (Val a) => Val [a] where
val = Array . map val
cast' (Array x) = mapM cast x
cast' _ = Nothing
instance Val Binary where
val = Bin
cast' (Bin x) = Just x
cast' _ = Nothing
instance Val Function where
val = Fun
cast' (Fun x) = Just x
cast' _ = Nothing
instance Val UUID where
val = Uuid
cast' (Uuid x) = Just x
cast' _ = Nothing
instance Val MD5 where
val = Md5
cast' (Md5 x) = Just x
cast' _ = Nothing
instance Val UserDefined where
val = UserDef
cast' (UserDef x) = Just x
cast' _ = Nothing
instance Val ObjectId where
val = ObjId
cast' (ObjId x) = Just x
cast' _ = Nothing
instance Val Bool where
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
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)
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)
instance Val Regex where
val = RegEx
cast' (RegEx x) = Just x
cast' _ = Nothing
instance Val Javascript where
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
instance Val Int32 where
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
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
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
instance Val MongoStamp where
val = Stamp
cast' (Stamp x) = Just x
cast' _ = Nothing
instance Val MinMaxKey where
val = MinMax
cast' (MinMax x) = Just x
cast' _ = Nothing
fitInt :: forall n m. (Integral n, Integral m, Bounded m) => n -> Maybe m
fitInt n = if fromIntegral (minBound :: m) <= n && n <= fromIntegral (maxBound :: m)
then Just (fromIntegral n)
else Nothing
newtype Binary = Binary BS.ByteString deriving (Typeable, Show, Read, Eq)
newtype Function = Function BS.ByteString deriving (Typeable, Show, Read, Eq)
newtype UUID = UUID BS.ByteString deriving (Typeable, Show, Read, Eq)
newtype MD5 = MD5 BS.ByteString deriving (Typeable, Show, Read, Eq)
newtype UserDefined = UserDefined BS.ByteString deriving (Typeable, Show, Read, Eq)
data Regex = Regex UString UString deriving (Typeable, Show, Read, Eq)
data Javascript = Javascript Document UString deriving (Typeable, Show, Eq)
newtype Symbol = Symbol UString deriving (Typeable, Show, Read, Eq)
newtype MongoStamp = MongoStamp Int64 deriving (Typeable, Show, Read, Eq)
data MinMaxKey = MinKey | MaxKey deriving (Typeable, Show, Read, Eq)
data ObjectId = Oid Word32 Word64 deriving (Typeable, Eq, Ord)
instance Show ObjectId where
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)
timestamp :: ObjectId -> UTCTime
timestamp (Oid time _) = posixSecondsToUTCTime (fromIntegral time)
genObjectId :: IO ObjectId
genObjectId = do
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)
counter :: IORef Word24
counter = unsafePerformIO (newIORef 0)
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
type Word24 = Word32
wrap24 :: Word24 -> Word24
wrap24 n = n `mod` 0x1000000
makeWord24 :: [Word8] -> Word24
makeWord24 = foldl (\a b -> a `shift` 8 .|. fromIntegral b) 0