{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Persist.Class.PersistEntity
( PersistEntity (..)
, Update (..)
, BackendSpecificUpdate
, SelectOpt (..)
, Filter (..)
, FilterValue (..)
, BackendSpecificFilter
, Entity (..)
, recordName
, entityValues
, keyValueEntityToJSON, keyValueEntityFromJSON
, entityIdToJSON, entityIdFromJSON
, toPersistValueJSON, fromPersistValueJSON
, toPersistValueEnum, fromPersistValueEnum
) where
import Data.Aeson (ToJSON (..), FromJSON (..), fromJSON, object, (.:), (.=), Value (Object))
import qualified Data.Aeson.Parser as AP
import Data.Aeson.Types (Parser,Result(Error,Success))
import Data.Aeson.Text (encodeToTextBuilder)
import Data.Attoparsec.ByteString (parseOnly)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (isJust)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as TB
import Data.Typeable (Typeable)
import GHC.Generics
import Database.Persist.Class.PersistField
import Database.Persist.Types.Base
class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record)
, Show (Key record), Read (Key record), Eq (Key record), Ord (Key record))
=> PersistEntity record where
type PersistEntityBackend record
data Key record
keyToValues :: Key record -> [PersistValue]
keyFromValues :: [PersistValue] -> Either Text (Key record)
persistIdField :: EntityField record (Key record)
entityDef :: Monad m => m record -> EntityDef
data EntityField record :: * -> *
persistFieldDef :: EntityField record typ -> FieldDef
toPersistFields :: record -> [SomePersistField]
fromPersistValues :: [PersistValue] -> Either Text record
data Unique record
persistUniqueKeys :: record -> [Unique record]
persistUniqueToFieldNames :: Unique record -> [(HaskellName, DBName)]
persistUniqueToValues :: Unique record -> [PersistValue]
fieldLens :: EntityField record field
-> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record))
type family BackendSpecificUpdate backend record
recordName
:: (PersistEntity record)
=> record -> Text
recordName :: record -> Text
recordName = HaskellName -> Text
unHaskellName (HaskellName -> Text) -> (record -> HaskellName) -> record -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> HaskellName
entityHaskell (EntityDef -> HaskellName)
-> (record -> EntityDef) -> record -> HaskellName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe record -> EntityDef
forall record (m :: * -> *).
(PersistEntity record, Monad m) =>
m record -> EntityDef
entityDef (Maybe record -> EntityDef)
-> (record -> Maybe record) -> record -> EntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. record -> Maybe record
forall a. a -> Maybe a
Just
data Update record = forall typ. PersistField typ => Update
{ ()
updateField :: EntityField record typ
, ()
updateValue :: typ
, Update record -> PersistUpdate
updateUpdate :: PersistUpdate
}
| BackendUpdate
(BackendSpecificUpdate (PersistEntityBackend record) record)
data SelectOpt record = forall typ. Asc (EntityField record typ)
| forall typ. Desc (EntityField record typ)
| OffsetBy Int
| LimitTo Int
type family BackendSpecificFilter backend record
data Filter record = forall typ. PersistField typ => Filter
{ ()
filterField :: EntityField record typ
, ()
filterValue :: FilterValue typ
, Filter record -> PersistFilter
filterFilter :: PersistFilter
}
| FilterAnd [Filter record]
| FilterOr [Filter record]
| BackendFilter
(BackendSpecificFilter (PersistEntityBackend record) record)
data FilterValue typ where
FilterValue :: typ -> FilterValue typ
FilterValues :: [typ] -> FilterValue typ
UnsafeValue :: forall a typ. PersistField a => a -> FilterValue typ
data Entity record =
Entity { Entity record -> Key record
entityKey :: Key record
, Entity record -> record
entityVal :: record }
deriving Typeable
deriving instance (Generic (Key record), Generic record) => Generic (Entity record)
deriving instance (Eq (Key record), Eq record) => Eq (Entity record)
deriving instance (Ord (Key record), Ord record) => Ord (Entity record)
deriving instance (Show (Key record), Show record) => Show (Entity record)
deriving instance (Read (Key record), Read record) => Read (Entity record)
entityValues :: PersistEntity record => Entity record -> [PersistValue]
entityValues :: Entity record -> [PersistValue]
entityValues (Entity k :: Key record
k record :: record
record) =
if Maybe CompositeDef -> Bool
forall a. Maybe a -> Bool
isJust (EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
ent)
then
(SomePersistField -> PersistValue)
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map SomePersistField -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (record -> [SomePersistField]
forall record. PersistEntity record => record -> [SomePersistField]
toPersistFields record
record)
else
Key record -> [PersistValue]
forall record. PersistEntity record => Key record -> [PersistValue]
keyToValues Key record
k [PersistValue] -> [PersistValue] -> [PersistValue]
forall a. [a] -> [a] -> [a]
++ (SomePersistField -> PersistValue)
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map SomePersistField -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (record -> [SomePersistField]
forall record. PersistEntity record => record -> [SomePersistField]
toPersistFields record
record)
where
ent :: EntityDef
ent = Maybe record -> EntityDef
forall record (m :: * -> *).
(PersistEntity record, Monad m) =>
m record -> EntityDef
entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just record
record
keyValueEntityToJSON :: (PersistEntity record, ToJSON record)
=> Entity record -> Value
keyValueEntityToJSON :: Entity record -> Value
keyValueEntityToJSON (Entity key :: Key record
key value :: record
value) = [Pair] -> Value
object
[ "key" Text -> Key record -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Key record
key
, "value" Text -> record -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= record
value
]
keyValueEntityFromJSON :: (PersistEntity record, FromJSON record)
=> Value -> Parser (Entity record)
keyValueEntityFromJSON :: Value -> Parser (Entity record)
keyValueEntityFromJSON (Object o :: Object
o) = Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity
(Key record -> record -> Entity record)
-> Parser (Key record) -> Parser (record -> Entity record)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Key record)
forall a. FromJSON a => Object -> Text -> Parser a
.: "key"
Parser (record -> Entity record)
-> Parser record -> Parser (Entity record)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser record
forall a. FromJSON a => Object -> Text -> Parser a
.: "value"
keyValueEntityFromJSON _ = String -> Parser (Entity record)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "keyValueEntityFromJSON: not an object"
entityIdToJSON :: (PersistEntity record, ToJSON record) => Entity record -> Value
entityIdToJSON :: Entity record -> Value
entityIdToJSON (Entity key :: Key record
key value :: record
value) = case record -> Value
forall a. ToJSON a => a -> Value
toJSON record
value of
Object o :: Object
o -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert "id" (Key record -> Value
forall a. ToJSON a => a -> Value
toJSON Key record
key) Object
o
x :: Value
x -> Value
x
entityIdFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record)
entityIdFromJSON :: Value -> Parser (Entity record)
entityIdFromJSON value :: Value
value@(Object o :: Object
o) = Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity (Key record -> record -> Entity record)
-> Parser (Key record) -> Parser (record -> Entity record)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Key record)
forall a. FromJSON a => Object -> Text -> Parser a
.: "id" Parser (record -> Entity record)
-> Parser record -> Parser (Entity record)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser record
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value
entityIdFromJSON _ = String -> Parser (Entity record)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "entityIdFromJSON: not an object"
instance (PersistEntity record, PersistField record, PersistField (Key record))
=> PersistField (Entity record) where
toPersistValue :: Entity record -> PersistValue
toPersistValue (Entity key :: Key record
key value :: record
value) = case record -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue record
value of
(PersistMap alist :: [(Text, PersistValue)]
alist) -> [(Text, PersistValue)] -> PersistValue
PersistMap ((Text
idField, Key record -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue Key record
key) (Text, PersistValue)
-> [(Text, PersistValue)] -> [(Text, PersistValue)]
forall a. a -> [a] -> [a]
: [(Text, PersistValue)]
alist)
_ -> String -> PersistValue
forall a. HasCallStack => String -> a
error (String -> PersistValue) -> String -> PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
errMsg "expected PersistMap"
fromPersistValue :: PersistValue -> Either Text (Entity record)
fromPersistValue (PersistMap alist :: [(Text, PersistValue)]
alist) = case [(Text, PersistValue)]
after of
[] -> Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left (Text -> Either Text (Entity record))
-> Text -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ Text -> Text
errMsg (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ "did not find " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`Data.Monoid.mappend` Text
idField Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` " field"
("_id", kv :: PersistValue
kv):afterRest :: [(Text, PersistValue)]
afterRest ->
PersistValue -> Either Text record
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue ([(Text, PersistValue)] -> PersistValue
PersistMap ([(Text, PersistValue)]
before [(Text, PersistValue)]
-> [(Text, PersistValue)] -> [(Text, PersistValue)]
forall a. [a] -> [a] -> [a]
++ [(Text, PersistValue)]
afterRest)) Either Text record
-> (record -> Either Text (Entity record))
-> Either Text (Entity record)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \record :: record
record ->
[PersistValue] -> Either Text (Key record)
forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues [PersistValue
kv] Either Text (Key record)
-> (Key record -> Either Text (Entity record))
-> Either Text (Entity record)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \k :: Key record
k ->
Entity record -> Either Text (Entity record)
forall a b. b -> Either a b
Right (Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity Key record
k record
record)
_ -> Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left (Text -> Either Text (Entity record))
-> Text -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ Text -> Text
errMsg (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ "impossible id field: " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` String -> Text
T.pack ([(Text, PersistValue)] -> String
forall a. Show a => a -> String
show [(Text, PersistValue)]
alist)
where
(before :: [(Text, PersistValue)]
before, after :: [(Text, PersistValue)]
after) = ((Text, PersistValue) -> Bool)
-> [(Text, PersistValue)]
-> ([(Text, PersistValue)], [(Text, PersistValue)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
idField) (Text -> Bool)
-> ((Text, PersistValue) -> Text) -> (Text, PersistValue) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, PersistValue) -> Text
forall a b. (a, b) -> a
fst) [(Text, PersistValue)]
alist
fromPersistValue x :: PersistValue
x = Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left (Text -> Either Text (Entity record))
-> Text -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$
Text -> Text
errMsg "Expected PersistMap, received: " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` String -> Text
T.pack (PersistValue -> String
forall a. Show a => a -> String
show PersistValue
x)
errMsg :: Text -> Text
errMsg :: Text -> Text
errMsg = Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend "PersistField entity fromPersistValue: "
idField :: Text
idField :: Text
idField = "_id"
toPersistValueJSON :: ToJSON a => a -> PersistValue
toPersistValueJSON :: a -> PersistValue
toPersistValueJSON = Text -> PersistValue
PersistText (Text -> PersistValue) -> (a -> Text) -> a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TB.toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Builder
forall a. ToJSON a => a -> Builder
encodeToTextBuilder (Value -> Builder) -> (a -> Value) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON
fromPersistValueJSON :: FromJSON a => PersistValue -> Either Text a
fromPersistValueJSON :: PersistValue -> Either Text a
fromPersistValueJSON z :: PersistValue
z = case PersistValue
z of
PersistByteString bs :: ByteString
bs -> (Text -> Text) -> Either Text a -> Either Text a
forall t a b. (t -> a) -> Either t b -> Either a b
mapLeft (Text -> Text -> Text
T.append "Could not parse the JSON (was a PersistByteString): ")
(Either Text a -> Either Text a) -> Either Text a -> Either Text a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text a
forall b. FromJSON b => ByteString -> Either Text b
parseGo ByteString
bs
PersistText t :: Text
t -> (Text -> Text) -> Either Text a -> Either Text a
forall t a b. (t -> a) -> Either t b -> Either a b
mapLeft (Text -> Text -> Text
T.append "Could not parse the JSON (was PersistText): ")
(Either Text a -> Either Text a) -> Either Text a -> Either Text a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text a
forall b. FromJSON b => ByteString -> Either Text b
parseGo (Text -> ByteString
TE.encodeUtf8 Text
t)
a :: PersistValue
a -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append "Expected PersistByteString, received: " (String -> Text
T.pack (PersistValue -> String
forall a. Show a => a -> String
show PersistValue
a))
where parseGo :: ByteString -> Either Text b
parseGo bs :: ByteString
bs = (String -> Text) -> Either String b -> Either Text b
forall t a b. (t -> a) -> Either t b -> Either a b
mapLeft String -> Text
T.pack (Either String b -> Either Text b)
-> Either String b -> Either Text b
forall a b. (a -> b) -> a -> b
$ case Parser Value -> ByteString -> Either String Value
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser Value
AP.value ByteString
bs of
Left err :: String
err -> String -> Either String b
forall a b. a -> Either a b
Left String
err
Right v :: Value
v -> case Value -> Result b
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
Error err :: String
err -> String -> Either String b
forall a b. a -> Either a b
Left String
err
Success a :: b
a -> b -> Either String b
forall a b. b -> Either a b
Right b
a
mapLeft :: (t -> a) -> Either t b -> Either a b
mapLeft _ (Right a :: b
a) = b -> Either a b
forall a b. b -> Either a b
Right b
a
mapLeft f :: t -> a
f (Left b :: t
b) = a -> Either a b
forall a b. a -> Either a b
Left (t -> a
f t
b)
toPersistValueEnum :: Enum a => a -> PersistValue
toPersistValueEnum :: a -> PersistValue
toPersistValueEnum = Int -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (Int -> PersistValue) -> (a -> Int) -> a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum
fromPersistValueEnum :: (Enum a, Bounded a) => PersistValue -> Either Text a
fromPersistValueEnum :: PersistValue -> Either Text a
fromPersistValueEnum v :: PersistValue
v = PersistValue -> Either Text Int
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v Either Text Int -> (Int -> Either Text a) -> Either Text a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Either Text a
forall b. (Enum b, Bounded b) => Int -> Either Text b
go
where go :: Int -> Either Text b
go i :: Int
i = let res :: b
res = Int -> b
forall a. Enum a => Int -> a
toEnum Int
i in
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= b -> Int
forall a. Enum a => a -> Int
fromEnum (b -> b -> b
forall a. a -> a -> a
asTypeOf b
forall a. Bounded a => a
minBound b
res) Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= b -> Int
forall a. Enum a => a -> Int
fromEnum (b -> b -> b
forall a. a -> a -> a
asTypeOf b
forall a. Bounded a => a
maxBound b
res)
then b -> Either Text b
forall a b. b -> Either a b
Right b
res
else Text -> Either Text b
forall a b. a -> Either a b
Left ("The number " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i) Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` " was out of the "
Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` "allowed bounds for an enum type")