module Data.Bson (
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
) 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 Data.ByteString.Char8 (ByteString, pack)
import Data.Digest.OpenSSL.MD5 (md5sum)
import Numeric (readHex, showHex)
import Network.BSD (getHostName)
import System.Posix.Process (getProcessID)
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
import Data.Maybe (maybeToList, mapMaybe)
import Control.Monad.Identity
roundTo :: (RealFrac a) => a -> a -> a
roundTo mult n = fromIntegral (round (n / mult)) * mult
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 ByteString deriving (Typeable, Show, Read, Eq)
newtype Function = Function ByteString deriving (Typeable, Show, Read, Eq)
newtype UUID = UUID ByteString deriving (Typeable, Show, Read, Eq)
newtype MD5 = MD5 ByteString deriving (Typeable, Show, Read, Eq)
newtype UserDefined = UserDefined 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 d (Oid x y) = showParen (d > 10) $ showString "Oid " . showHex x . showChar ' ' . showHex 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 (fst . head . readHex . take 6 . md5sum . 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