#ifndef NO_OVERLAP
#endif
module Database.Persist.Store
( PersistValue (..)
, SqlType (..)
, PersistField (..)
, PersistEntity (..)
, PersistStore (..)
, PersistUnique (..)
, PersistFilter (..)
, SomePersistField (..)
, ZT (..)
, insertBy
, getByValue
, getJust
, belongsTo
, belongsToJust
, checkUnique
, DeleteCascade (..)
, PersistException (..)
, Key (..)
, Entity (..)
, getPersistMap
, listToJSON
, mapToJSON
, PersistConfig (..)
) where
import qualified Prelude
import Prelude hiding ((++), show)
import Data.Monoid (mappend)
import Data.Time (Day, TimeOfDay, UTCTime)
import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)
import Data.ByteString.Char8 (ByteString, unpack)
import Control.Applicative
import Data.Typeable (Typeable)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.ByteString.Lazy as L
import qualified Control.Exception as E
import Control.Monad.Trans.Error (Error (..))
import Database.Persist.EntityDef
import Data.Bits (bitSize)
import Control.Monad (liftM, (<=<))
import Control.Arrow (second)
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Web.PathPieces (PathPiece (..))
import qualified Data.Text.Read
import Data.Aeson (Value)
import Data.Aeson.Types (Parser)
import qualified Data.Aeson as A
import qualified Data.Attoparsec.Number as AN
import qualified Data.Vector as V
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.HashMap.Strict as HM
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Base64 as B64
import Data.Aeson (toJSON)
import Data.Aeson.Encode (fromValue)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (toLazyText)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Base (liftBase)
import Control.Monad.IO.Class (MonadIO)
data PersistException
= PersistError T.Text
| PersistMarshalError T.Text
| PersistInvalidField T.Text
| PersistForeignConstraintUnmet T.Text
| PersistMongoDBError T.Text
| PersistMongoDBUnsupported T.Text
deriving (Show, Typeable)
instance E.Exception PersistException
instance Error PersistException where
strMsg = PersistError . T.pack
newtype ZT = ZT ZonedTime deriving (Show, Read, Typeable)
instance Eq ZT where
ZT a /= ZT b = zonedTimeToLocalTime a /= zonedTimeToLocalTime b || zonedTimeZone a /= zonedTimeZone b
instance Ord ZT where
ZT a `compare` ZT b = zonedTimeToUTC a `compare` zonedTimeToUTC b
data PersistValue = PersistText T.Text
| PersistByteString ByteString
| PersistInt64 Int64
| PersistDouble Double
| PersistBool Bool
| PersistDay Day
| PersistTimeOfDay TimeOfDay
| PersistUTCTime UTCTime
| PersistZonedTime ZT
| PersistNull
| PersistList [PersistValue]
| PersistMap [(T.Text, PersistValue)]
| PersistObjectId ByteString
deriving (Show, Read, Eq, Typeable, Ord)
instance PathPiece PersistValue where
fromPathPiece t =
case Data.Text.Read.signed Data.Text.Read.decimal t of
Right (i, t')
| T.null t' -> Just $ PersistInt64 i
_ -> Just $ PersistText t
toPathPiece x =
case fromPersistValue x of
Left e -> error $ T.unpack e
Right y -> y
instance A.ToJSON PersistValue where
toJSON (PersistText t) = A.String $ T.cons 's' t
toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b
toJSON (PersistInt64 i) = A.Number $ fromIntegral i
toJSON (PersistDouble d) = A.Number $ AN.D d
toJSON (PersistBool b) = A.Bool b
toJSON (PersistTimeOfDay t) = A.String $ T.cons 't' $ show t
toJSON (PersistUTCTime u) = A.String $ T.cons 'u' $ show u
toJSON (PersistZonedTime z) = A.String $ T.cons 'z' $ show z
toJSON (PersistDay d) = A.String $ T.cons 'd' $ show d
toJSON PersistNull = A.Null
toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l
toJSON (PersistMap m) = A.object $ map (second A.toJSON) m
toJSON (PersistObjectId o) = A.String $ T.cons 'o' $ TE.decodeUtf8 $ B64.encode o
instance A.FromJSON PersistValue where
parseJSON (A.String t0) =
case T.uncons t0 of
Nothing -> fail "Null string"
Just ('s', t) -> return $ PersistText t
Just ('b', t) -> either (fail "Invalid base64") (return . PersistByteString)
$ B64.decode $ TE.encodeUtf8 t
Just ('t', t) -> fmap PersistTimeOfDay $ readMay t
Just ('u', t) -> fmap PersistUTCTime $ readMay t
Just ('z', t) -> fmap PersistZonedTime $ readMay t
Just ('d', t) -> fmap PersistDay $ readMay t
Just ('o', t) -> either (fail "Invalid base64") (return . PersistObjectId)
$ B64.decode $ TE.encodeUtf8 t
Just (c, _) -> fail $ "Unknown prefix: " `mappend` [c]
where
readMay :: (Read a, Monad m) => T.Text -> m a
readMay t =
case reads $ T.unpack t of
(x, _):_ -> return x
[] -> fail "Could not read"
parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i
parseJSON (A.Number (AN.D d)) = return $ PersistDouble d
parseJSON (A.Bool b) = return $ PersistBool b
parseJSON A.Null = return $ PersistNull
parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a)
parseJSON (A.Object o) =
fmap PersistMap $ mapM go $ HM.toList o
where
go (k, v) = fmap ((,) k) $ A.parseJSON v
data SqlType = SqlString
| SqlInt32
| SqlInt64
| SqlReal
| SqlBool
| SqlDay
| SqlTime
| SqlDayTime
| SqlDayTimeZoned
| SqlBlob
| SqlOther T.Text
deriving (Show, Read, Eq, Typeable, Ord)
class PersistField a where
toPersistValue :: a -> PersistValue
fromPersistValue :: PersistValue -> Either T.Text a
sqlType :: a -> SqlType
isNullable :: a -> Bool
isNullable _ = False
#ifndef NO_OVERLAP
instance PersistField String where
toPersistValue = PersistText . T.pack
fromPersistValue (PersistText s) = Right $ T.unpack s
fromPersistValue (PersistByteString bs) =
Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs
fromPersistValue (PersistInt64 i) = Right $ Prelude.show i
fromPersistValue (PersistDouble d) = Right $ Prelude.show d
fromPersistValue (PersistDay d) = Right $ Prelude.show d
fromPersistValue (PersistTimeOfDay d) = Right $ Prelude.show d
fromPersistValue (PersistUTCTime d) = Right $ Prelude.show d
fromPersistValue (PersistZonedTime (ZT z)) = Right $ Prelude.show z
fromPersistValue PersistNull = Left "Unexpected null"
fromPersistValue (PersistBool b) = Right $ Prelude.show b
fromPersistValue (PersistList _) = Left "Cannot convert PersistList to String"
fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to String"
fromPersistValue (PersistObjectId _) = Left "Cannot convert PersistObjectId to String"
sqlType _ = SqlString
#endif
instance PersistField ByteString where
toPersistValue = PersistByteString
fromPersistValue (PersistByteString bs) = Right bs
fromPersistValue x = T.encodeUtf8 <$> fromPersistValue x
sqlType _ = SqlBlob
instance PersistField T.Text where
toPersistValue = PersistText
fromPersistValue (PersistText s) = Right s
fromPersistValue (PersistByteString bs) =
Right $ T.decodeUtf8With T.lenientDecode bs
fromPersistValue (PersistInt64 i) = Right $ show i
fromPersistValue (PersistDouble d) = Right $ show d
fromPersistValue (PersistDay d) = Right $ show d
fromPersistValue (PersistTimeOfDay d) = Right $ show d
fromPersistValue (PersistUTCTime d) = Right $ show d
fromPersistValue (PersistZonedTime (ZT z)) = Right $ show z
fromPersistValue PersistNull = Left "Unexpected null"
fromPersistValue (PersistBool b) = Right $ show b
fromPersistValue (PersistList _) = Left "Cannot convert PersistList to Text"
fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to Text"
fromPersistValue (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text"
sqlType _ = SqlString
instance PersistField Html where
toPersistValue = PersistText . TL.toStrict . renderHtml
fromPersistValue = fmap (preEscapedToMarkup :: T.Text -> Html) . fromPersistValue
sqlType _ = SqlString
instance PersistField Int where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType x = case bitSize x of
32 -> SqlInt32
_ -> SqlInt64
instance PersistField Int8 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Int16 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Int32 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Int64 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType _ = SqlInt64
instance PersistField Word8 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Word16 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Word32 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x
sqlType _ = SqlInt64
instance PersistField Word64 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x
sqlType _ = SqlInt64
instance PersistField Double where
toPersistValue = PersistDouble
fromPersistValue (PersistDouble d) = Right d
fromPersistValue x = Left $ "Expected Double, received: " ++ show x
sqlType _ = SqlReal
instance PersistField Bool where
toPersistValue = PersistBool
fromPersistValue (PersistBool b) = Right b
fromPersistValue (PersistInt64 i) = Right $ i /= 0
fromPersistValue x = Left $ "Expected Bool, received: " ++ show x
sqlType _ = SqlBool
instance PersistField Day where
toPersistValue = PersistDay
fromPersistValue (PersistDay d) = Right d
fromPersistValue x@(PersistText t) =
case reads $ T.unpack t of
(d, _):_ -> Right d
_ -> Left $ "Expected Day, received " ++ show x
fromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ "Expected Day, received " ++ show x
fromPersistValue x = Left $ "Expected Day, received: " ++ show x
sqlType _ = SqlDay
instance PersistField TimeOfDay where
toPersistValue = PersistTimeOfDay
fromPersistValue (PersistTimeOfDay d) = Right d
fromPersistValue x@(PersistText t) =
case reads $ T.unpack t of
(d, _):_ -> Right d
_ -> Left $ "Expected TimeOfDay, received " ++ show x
fromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ "Expected TimeOfDay, received " ++ show x
fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x
sqlType _ = SqlTime
instance PersistField UTCTime where
toPersistValue = PersistUTCTime
fromPersistValue (PersistUTCTime d) = Right d
fromPersistValue x@(PersistText t) =
case reads $ T.unpack t of
(d, _):_ -> Right d
_ -> Left $ "Expected UTCTime, received " ++ show x
fromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ "Expected UTCTime, received " ++ show x
fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x
sqlType _ = SqlDayTime
instance PersistField ZonedTime where
toPersistValue = PersistZonedTime . ZT
fromPersistValue (PersistZonedTime (ZT z)) = Right z
fromPersistValue x@(PersistText t) =
case reads $ T.unpack t of
(z, _):_ -> Right z
_ -> Left $ "Expected ZonedTime, received " ++ show x
fromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(z, _):_ -> Right z
_ -> Left $ "Expected ZonedTime, received " ++ show x
fromPersistValue x = Left $ "Expected ZonedTime, received: " ++ show x
sqlType _ = SqlDayTimeZoned
instance PersistField a => PersistField (Maybe a) where
toPersistValue Nothing = PersistNull
toPersistValue (Just a) = toPersistValue a
fromPersistValue PersistNull = Right Nothing
fromPersistValue x = fmap Just $ fromPersistValue x
sqlType _ = sqlType (error "this is the problem" :: a)
isNullable _ = True
class PersistEntity val where
data EntityField val :: * -> *
persistFieldDef :: EntityField val typ -> FieldDef
type PersistEntityBackend val :: ((* -> *) -> * -> *)
data Unique val :: ((* -> *) -> * -> *) -> *
entityDef :: val -> EntityDef
toPersistFields :: val -> [SomePersistField]
fromPersistValues :: [PersistValue] -> Either T.Text val
halfDefined :: val
persistUniqueToFieldNames :: Unique val backend -> [(HaskellName, DBName)]
persistUniqueToValues :: Unique val backend -> [PersistValue]
persistUniqueKeys :: val -> [Unique val backend]
persistIdField :: EntityField val (Key (PersistEntityBackend val) val)
instance PersistField a => PersistField [a] where
toPersistValue = PersistList . map toPersistValue
fromPersistValue (PersistList l) = fromPersistList l
fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)
fromPersistValue (PersistByteString bs)
| Just values <- A.decode' (L.fromChunks [bs]) = fromPersistList values
fromPersistValue x = Left $ "Expected PersistList, received: " ++ show x
sqlType _ = SqlString
instance (Ord a, PersistField a) => PersistField (S.Set a) where
toPersistValue = PersistList . map toPersistValue . S.toList
fromPersistValue (PersistList list) =
either Left (Right . S.fromList) $ fromPersistList list
fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)
fromPersistValue (PersistByteString bs)
| Just values <- A.decode' (L.fromChunks [bs]) =
either Left (Right . S.fromList) $ fromPersistList values
fromPersistValue x = Left $ "Expected PersistSet, received: " ++ show x
sqlType _ = SqlString
fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a]
fromPersistList = mapM fromPersistValue
instance (PersistField a, PersistField b) => PersistField (a,b) where
toPersistValue (x,y) = PersistList [toPersistValue x, toPersistValue y]
fromPersistValue (PersistList (vx:vy:[])) =
case (fromPersistValue vx, fromPersistValue vy) of
(Right x, Right y) -> Right (x, y)
(Left e, _) -> Left e
(_, Left e) -> Left e
fromPersistValue x = Left $ "Expected 2 item PersistList, received: " ++ show x
sqlType _ = SqlString
instance PersistField v => PersistField (M.Map T.Text v) where
toPersistValue = PersistMap . map (\(k,v) -> (k, toPersistValue v)) . M.toList
fromPersistValue = fromPersistMap <=< getPersistMap
sqlType _ = SqlString
getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)]
getPersistMap (PersistMap kvs) = Right kvs
getPersistMap (PersistText t) = getPersistMap (PersistByteString $ TE.encodeUtf8 t)
getPersistMap (PersistByteString bs)
| Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs
getPersistMap x = Left $ "Expected PersistMap, received: " ++ show x
fromPersistMap :: PersistField v
=> [(T.Text, PersistValue)]
-> Either T.Text (M.Map T.Text v)
fromPersistMap kvs =
case (
foldl (\eithAssocs (k,v) ->
case (eithAssocs, fromPersistValue v) of
(Left e, _) -> Left e
(_, Left e) -> Left e
(Right assocs, Right v') -> Right ((k,v'):assocs)
) (Right []) kvs
) of
Right vs -> Right $ M.fromList vs
Left e -> Left e
data SomePersistField = forall a. PersistField a => SomePersistField a
instance PersistField SomePersistField where
toPersistValue (SomePersistField a) = toPersistValue a
fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either T.Text T.Text)
sqlType (SomePersistField a) = sqlType a
newtype Key (backend :: (* -> *) -> * -> *) entity = Key { unKey :: PersistValue }
deriving (Show, Read, Eq, Ord, PersistField)
instance A.ToJSON (Key backend entity) where
toJSON (Key val) = A.toJSON val
instance A.FromJSON (Key backend entity) where
parseJSON = fmap Key . A.parseJSON
data Entity entity =
Entity { entityKey :: Key (PersistEntityBackend entity) entity
, entityVal :: entity }
deriving (Eq, Ord, Show, Read)
class (MonadBaseControl IO m, MonadBaseControl IO (backend m)) => PersistStore backend m where
insert :: PersistEntity val => val -> backend m (Key backend val)
insertKey :: PersistEntity val => Key backend val -> val -> backend m ()
repsert :: PersistEntity val => Key backend val -> val -> backend m ()
replace :: PersistEntity val => Key backend val -> val -> backend m ()
delete :: PersistEntity val => Key backend val -> backend m ()
get :: PersistEntity val => Key backend val -> backend m (Maybe val)
class PersistStore backend m => PersistUnique backend m where
getBy :: (PersistEntityBackend val ~ backend, PersistEntity val) => Unique val backend -> backend m (Maybe (Entity val))
deleteBy :: PersistEntity val => Unique val backend -> backend m ()
insertUnique :: (backend ~ PersistEntityBackend val, PersistEntity val) => val -> backend m (Maybe (Key backend val))
insertUnique datum = do
isUnique <- checkUnique datum
if isUnique then Just `liftM` insert datum else return Nothing
insertBy :: (PersistEntity v, PersistStore backend m, PersistUnique backend m, backend ~ PersistEntityBackend v)
=> v -> backend m (Either (Entity v) (Key backend v))
insertBy val =
go $ persistUniqueKeys val
where
go [] = Right `liftM` insert val
go (x:xs) = do
y <- getBy x
case y of
Nothing -> go xs
Just z -> return $ Left z
getByValue :: (PersistEntity v, PersistUnique backend m, PersistEntityBackend v ~ backend)
=> v -> backend m (Maybe (Entity v))
getByValue val =
go $ persistUniqueKeys val
where
go [] = return Nothing
go (x:xs) = do
y <- getBy x
case y of
Nothing -> go xs
Just z -> return $ Just z
belongsTo ::
(PersistStore backend m
, PersistEntity ent1
, PersistEntity ent2) => (ent1 -> Maybe (Key backend ent2)) -> ent1 -> backend m (Maybe ent2)
belongsTo foreignKeyField model = case foreignKeyField model of
Nothing -> return Nothing
Just f -> get f
belongsToJust ::
(PersistStore backend m
, PersistEntity ent1
, PersistEntity ent2) => (ent1 -> Key backend ent2) -> ent1 -> backend m ent2
belongsToJust getForeignKey model = getJust $ getForeignKey model
getJust :: (PersistStore backend m, PersistEntity val, Show (Key backend val)) => Key backend val -> backend m val
getJust key = get key >>= maybe
(liftBase $ E.throwIO $ PersistForeignConstraintUnmet $ show key)
return
checkUnique :: (PersistEntityBackend val ~ backend, PersistEntity val, PersistUnique backend m) => val -> backend m Bool
checkUnique val =
go $ persistUniqueKeys val
where
go [] = return True
go (x:xs) = do
y <- getBy x
case y of
Nothing -> go xs
Just _ -> return False
data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn
| BackendSpecificFilter T.Text
deriving (Read, Show)
class PersistEntity a => DeleteCascade a backend m where
deleteCascade :: Key backend a -> backend m ()
instance PersistField PersistValue where
toPersistValue = id
fromPersistValue = Right
sqlType _ = SqlInt64
class PersistConfig c where
type PersistConfigBackend c :: (* -> *) -> * -> *
type PersistConfigPool c
loadConfig :: Value -> Parser c
applyEnv :: c -> IO c
applyEnv = return
createPoolConfig :: c -> IO (PersistConfigPool c)
runPool :: (MonadBaseControl IO m, MonadIO m)
=> c
-> PersistConfigBackend c m a
-> PersistConfigPool c
-> m a
infixr 5 ++
(++) :: T.Text -> T.Text -> T.Text
(++) = mappend
show :: Show a => a -> T.Text
show = T.pack . Prelude.show
listToJSON :: [PersistValue] -> T.Text
listToJSON = toStrict . toLazyText . fromValue . toJSON
mapToJSON :: [(T.Text, PersistValue)] -> T.Text
mapToJSON = toStrict . toLazyText . fromValue . toJSON