snaplet-mongoDB-0.2: src/Snap/Snaplet/MongoDB/MongoValue.hs
{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeFamilies #-}
{-# LANGUAGE TupleSections, TypeSynonymInstances, RankNTypes, ScopedTypeVariables, IncoherentInstances #-}
module Snap.Snaplet.MongoDB.MongoValue
( MongoValue (..)
, BSON.Value (..)
-- , BSON.Document (..)
, BSON.Field (..)
, BSON.ObjectId (..)
, nullObjectId
, expected
-- , lookMaybe
, lookupThrow
) where
import Prelude hiding (lookup, or)
import Control.Applicative
import Control.Monad.Error
import Data.Bson (Field ((:=)), ObjectId (..))
import qualified Data.Bson as BSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Char
import qualified Data.CompactString.UTF8 as CS
import Data.Int
import Data.List (find)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Data.Time
import Data.Time.Clock.POSIX
import Text.Printf
-- | This type class represents all types which can be marshalled too and from the BSON format.
class MongoValue a where
toValue :: a -> BSON.Value
fromValue :: (Applicative m, Monad m) => BSON.Value -> ErrorT String m a
expected :: (Monad m) => String -> BSON.Value -> ErrorT String m a
expected what was =
throwError $ printf "Expected %s; found %s" what (describeType was)
where
describeType :: BSON.Value -> String
describeType (BSON.Float _) = "Float"
describeType (BSON.String _) = "String"
describeType (BSON.Doc _) = "Document"
describeType (BSON.Array n) = printf "Array (BSON.with %i elements)" (length n)
describeType (BSON.Bin _) = "Binary"
describeType (BSON.Fun _) = "Function"
describeType (BSON.Uuid _) = "UUID"
describeType (BSON.Md5 _) = "MD5"
describeType (BSON.UserDef _) = "UserDefined"
describeType (BSON.ObjId _) = "ObjectId"
describeType (BSON.Bool _) = "Bool"
describeType (BSON.UTC _) = "UTCTime"
describeType (BSON.Null ) = "null"
describeType (BSON.RegEx _) = "RegEx"
describeType (BSON.JavaScr _) = "JavaScript"
describeType (BSON.Sym _) = "Symbol"
describeType (BSON.Int32 _) = "Int32"
describeType (BSON.Int64 _) = "Int64"
describeType (BSON.Stamp _) = "Stamp"
describeType (BSON.MinMax _) = "MinMax"
-- | Represents a null 'ObjectId' (all zeros).
nullObjectId :: ObjectId
nullObjectId = Oid 0 0
lookMaybe :: T.Text -> BSON.Document -> Maybe BSON.Value
lookMaybe name doc =
let name' = textToCompactString name in maybe Nothing (Just . BSON.value) $ find ((name' ==) . BSON.label) doc
lookupThrow :: (Applicative m, Monad m, MongoValue a) => T.Text -> BSON.Document -> ErrorT String m a
lookupThrow name doc =
case lookMaybe name doc of
Just val -> fromValue val
Nothing -> throwError $ printf "Could not find field '%s'" (T.unpack name)
instance MongoValue BSON.Value where
toValue = id
fromValue = return . id
instance MongoValue BSON.Document where
toValue = BSON.Doc
fromValue (BSON.Doc d) = pure d
fromValue v = expected "Document" v
instance MongoValue () where
toValue _ = BSON.Null
fromValue BSON.Null = pure ()
fromValue v = expected "null" v
instance MongoValue Bool where
toValue = BSON.Bool
fromValue (BSON.Bool x) = pure x
fromValue v = expected "boolean" v
instance MongoValue BSON.UString where
toValue = BSON.String
fromValue (BSON.String x ) = pure x
fromValue (BSON.Sym (BSON.Symbol x)) = pure x
fromValue v = expected "string or symbol" v
instance MongoValue T.Text where
toValue = BSON.String . textToCompactString
fromValue (BSON.String x ) = pure $! compactStringToText x
fromValue (BSON.Sym (BSON.Symbol x)) = pure $! compactStringToText x
fromValue v = expected "string or symbol" v
instance MongoValue LT.Text where
toValue = BSON.String . lazyTextToCompactString
fromValue (BSON.String x ) = pure $! compactStringToLazyText x
fromValue (BSON.Sym (BSON.Symbol x)) = pure $! compactStringToLazyText x
fromValue v = expected "string or symbol" v
instance MongoValue (Maybe BSON.Value) where
toValue Nothing = BSON.Null
toValue (Just x) = x
fromValue BSON.Null = pure Nothing
fromValue x = pure (Just x)
instance (MongoValue a) => MongoValue (Maybe a) where
toValue Nothing = BSON.Null
toValue (Just x) = toValue x
fromValue BSON.Null = pure Nothing
fromValue x = Just <$> (fromValue x)
instance (MongoValue a) => MongoValue [a] where
toValue = BSON.Array . map toValue
fromValue (BSON.Array x) = mapM fromValue x
fromValue v = expected "array" v
instance (MongoValue a, MongoValue b) => MongoValue (Either a b) where
toValue (Left x) = BSON.Doc [ "_type" := (BSON.String $ BSON.u "Left" ), "value" := toValue x ]
toValue (Right y) = BSON.Doc [ "_type" := (BSON.String $ BSON.u "Right"), "value" := toValue y ]
fromValue (BSON.Doc doc) = do
side <- fmap (map toLower) $ BSON.lookup "_type" doc
case side of
("left" :: String) -> (return . Left) =<< fromValue =<< BSON.look "value" doc
("right" :: String) -> (return . Right) =<< fromValue =<< BSON.look "value" doc
other -> throwError $ "Expected either 'left' or 'right', found '" ++ other ++ "'"
fromValue v = expected "document" v
roundTo :: (RealFrac a) => a -> a -> a
roundTo mult n = fromIntegral (round (n / mult)) * mult
instance MongoValue UTCTime where
toValue = BSON.UTC . posixSecondsToUTCTime . roundTo (1 / 1000) . utcTimeToPOSIXSeconds
fromValue (BSON.UTC x) = pure x
fromValue v = expected "UTCTime" v
instance MongoValue POSIXTime where
toValue = BSON.UTC . posixSecondsToUTCTime . roundTo (1 / 1000)
fromValue (BSON.UTC x) = pure $! utcTimeToPOSIXSeconds x
fromValue v = expected "UTCTime" v
instance MongoValue BS.ByteString where
toValue = BSON.Bin . BSON.Binary
fromValue (BSON.Bin (BSON.Binary x)) = pure x
fromValue v = expected "binary" v
instance MongoValue BSL.ByteString where
toValue = BSON.Bin . BSON.Binary . BS.concat . BSL.toChunks
fromValue (BSON.Bin (BSON.Binary x)) = pure $! BSL.fromChunks [x]
fromValue v = expected "binary" v
fitInt :: forall m b a. (Applicative m, Monad m, PrintfArg a, Integral a, Integral b, Bounded b) => String -> a -> ErrorT String m b
fitInt t n =
let l = minBound :: b
h = maxBound :: b
in if fromIntegral l <= n && n <= fromIntegral h
then pure $! fromIntegral n
else throwError $ printf "Integer value %i was out of range for type %s" n t
instance MongoValue Int32 where
toValue = BSON.Int32
fromValue (BSON.Int32 x) = pure x
fromValue (BSON.Int64 x) = fitInt "Int32" x
fromValue (BSON.Float x) = pure $! round x
fromValue v = expected "Int32, Int64 or Float" v
instance MongoValue Int64 where
toValue = BSON.Int64
fromValue (BSON.Int32 x) = pure $! fromIntegral x
fromValue (BSON.Int64 x) = pure x
fromValue (BSON.Float x) = pure $! round x
fromValue v = expected "Int32, Int64 or Float" v
instance MongoValue Int where
toValue = BSON.Int64 . fromIntegral
fromValue (BSON.Int32 x) = pure $! fromIntegral x
fromValue (BSON.Int64 x) = pure $! fromEnum x
fromValue (BSON.Float x) = pure $! round x
fromValue v = expected "Int32, Int64 or Float" v
instance MongoValue Integer where
toValue = BSON.Int64 . fromIntegral
fromValue (BSON.Int32 x) = pure $! fromIntegral x
fromValue (BSON.Int64 x) = pure $! fromIntegral x
fromValue (BSON.Float x) = pure $! round x
fromValue v = expected "Int32, Int64 or Float" v
instance MongoValue Float where
toValue = BSON.Float . realToFrac
fromValue (BSON.Float x) = pure $! realToFrac x
fromValue (BSON.Int32 x) = pure $! fromIntegral x
fromValue (BSON.Int64 x) = pure $! fromIntegral x
fromValue v = expected "Int32, Int64 or Float" v
instance MongoValue Double where
toValue = BSON.Float
fromValue (BSON.Float x) = pure x
fromValue (BSON.Int32 x) = pure $! fromIntegral x
fromValue (BSON.Int64 x) = pure $! fromIntegral x
fromValue v = expected "Int32 or Int64" v
instance MongoValue ObjectId where
toValue = BSON.ObjId
fromValue (BSON.ObjId x) = pure x
fromValue v = expected "ObjectId" v
instance (MongoValue a, MongoValue b) => MongoValue (a, b) where
toValue (x, y) = BSON.Array [toValue x, toValue y]
fromValue v @ (BSON.Array xs) =
case xs of
[x, y] -> (,) <$> fromValue x <*> fromValue y
_ -> expected "Array (with 2 elements)" v
fromValue v = expected "Array (with 2 elements)" v
instance (MongoValue a, MongoValue b, MongoValue c) => MongoValue (a, b, c) where
toValue (x, y, z) = BSON.Array [toValue x, toValue y, toValue z]
fromValue v @ (BSON.Array xs) =
case xs of
[x, y, z] -> (,,) <$> fromValue x <*> fromValue y <*> fromValue z
_ -> expected "Array (with 3 elements)" v
fromValue v = expected "Array (with 3 elements)" v
-- | Instance of the 'MongoValue' type class for a map of strict 'T.Text' to some value which also an instance of the
-- 'MongoValue' type class. This type class is provided for more efficient storage of maps with textual keys.
--
-- For example, the map @M.fromList [("cat", 1), ("dog", 2), ("mat", 3)]@ would yield the JSON equivalent of:
-- @{ cat: 1, dog: 2, mat: 3 }@.
--
instance (MongoValue val) => MongoValue (M.Map T.Text val) where
toValue m = BSON.Doc $ map (\(k, v) -> textToCompactString k := toValue v) $ M.toList m
fromValue (BSON.Doc m) = do
elements <- mapM (\ (k := v) -> do
val <- fromValue v
pure (compactStringToText k, val)) m
pure $! M.fromList elements
fromValue v = expected "Document" v
-- | Instance of the 'MongoValue' type class for a map of lazy 'LT.Text' to some value which also an instance of the
-- 'MongoValue' type class. This type class is provided for more efficient storage of maps with textual keys.
--
-- For example, the map @M.fromList [("cat", 1), ("dog", 2), ("mat", 3)]@ would yield the JSON equivalent of:
-- @{ cat: 1, dog: 2, mat: 3 }@.
--
instance (MongoValue val) => MongoValue (M.Map LT.Text val) where
toValue m = BSON.Doc $ map (\(k, v) -> lazyTextToCompactString k := toValue v) $ M.toList m
fromValue (BSON.Doc m) = do
elements <- mapM (\ (k := v) -> do
val <- fromValue v
pure (compactStringToLazyText k, val)) m
pure $! M.fromList elements
fromValue v = expected "Document" v
instance (Ord key, MongoValue key, MongoValue val) => MongoValue (M.Map key val) where
toValue = toValue . M.toList
fromValue v = M.fromList <$> fromValue v
compactStringToText :: CS.CompactString -> T.Text
compactStringToText = T.decodeUtf8 . CS.toByteString
textToCompactString :: T.Text -> CS.CompactString
textToCompactString = CS.fromByteString_ . T.encodeUtf8
compactStringToLazyText :: CS.CompactString -> LT.Text
compactStringToLazyText =
LT.decodeUtf8 . (\x -> BSL.fromChunks [x]) . CS.toByteString
lazyTextToCompactString :: LT.Text -> CS.CompactString
lazyTextToCompactString =
CS.fromByteString_ . BS.concat . BSL.toChunks . LT.encodeUtf8
-- Local Variables:
-- mode : Haskell
-- fill-column : 120
-- default-justification : left
-- End: