{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
module Database.Persist.Class.PersistEntity
( PersistEntity (..)
, Update (..)
, BackendSpecificUpdate
, SelectOpt (..)
, Filter (..)
, FilterValue (..)
, BackendSpecificFilter
, Entity (..)
, recordName
, entityValues
, keyValueEntityToJSON, keyValueEntityFromJSON
, entityIdToJSON, entityIdFromJSON
, toPersistValueJSON, fromPersistValueJSON
, toPersistValueEnum, fromPersistValueEnum
, SymbolToField (..)
) where
import Data.Aeson
( FromJSON(..)
, ToJSON(..)
, Value(Object)
, fromJSON
, object
, withObject
, (.:)
, (.=)
)
import qualified Data.Aeson.Parser as AP
import Data.Aeson.Text (encodeToTextBuilder)
import Data.Aeson.Types (Parser, Result(Error, Success))
import Data.Attoparsec.ByteString (parseOnly)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as AM
#else
import qualified Data.HashMap.Strict as AM
#endif
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (isJust)
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 GHC.Generics
import GHC.OverloadedLabels
import GHC.TypeLits
import Data.Kind (Type)
import Database.Persist.Class.PersistField
import Database.Persist.Names
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 :: proxy record -> EntityDef
data EntityField record :: Type -> Type
persistFieldDef :: EntityField record typ -> FieldDef
toPersistFields :: record -> [SomePersistField]
fromPersistValues :: [PersistValue] -> Either Text record
data Unique record
persistUniqueKeys :: record -> [Unique record]
persistUniqueToFieldNames :: Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
persistUniqueToValues :: Unique record -> [PersistValue]
fieldLens :: EntityField record field
-> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record))
keyFromRecordM :: Maybe (record -> Key record)
keyFromRecordM = Maybe (record -> Key record)
forall a. Maybe a
Nothing
type family BackendSpecificUpdate backend record
recordName
:: (PersistEntity record)
=> record -> Text
recordName :: record -> Text
recordName = EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text)
-> (record -> EntityNameHS) -> record -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
entityHaskell (EntityDef -> EntityNameHS)
-> (record -> EntityDef) -> record -> EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy 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 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 Key record
k 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 (proxy :: * -> *).
PersistEntity record =>
proxy 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 record
key record
value) = [Pair] -> Value
object
[ Key
"key" Key -> Key record -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Key record
key
, Key
"value" Key -> record -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= record
value
]
keyValueEntityFromJSON :: (PersistEntity record, FromJSON record)
=> Value -> Parser (Entity record)
keyValueEntityFromJSON :: Value -> Parser (Entity record)
keyValueEntityFromJSON (Object 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 -> Key -> Parser (Key record)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"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 -> Key -> Parser record
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"
keyValueEntityFromJSON Value
_ = String -> Parser (Entity record)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"keyValueEntityFromJSON: not an object"
entityIdToJSON :: (PersistEntity record, ToJSON record) => Entity record -> Value
entityIdToJSON :: Entity record -> Value
entityIdToJSON (Entity Key record
key record
value) = case record -> Value
forall a. ToJSON a => a -> Value
toJSON record
value of
Object Object
o -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
AM.insert Key
"id" (Key record -> Value
forall a. ToJSON a => a -> Value
toJSON Key record
key) Object
o
Value
x -> Value
x
entityIdFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record)
entityIdFromJSON :: Value -> Parser (Entity record)
entityIdFromJSON = String
-> (Object -> Parser (Entity record))
-> Value
-> Parser (Entity record)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"entityIdFromJSON" ((Object -> Parser (Entity record))
-> Value -> Parser (Entity record))
-> (Object -> Parser (Entity record))
-> Value
-> Parser (Entity record)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
record
val <- Value -> Parser record
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
Key record
k <- case Maybe (record -> Key record)
forall record. PersistEntity record => Maybe (record -> Key record)
keyFromRecordM of
Maybe (record -> Key record)
Nothing ->
Object
o Object -> Key -> Parser (Key record)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
Just record -> Key record
func ->
Key record -> Parser (Key record)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key record -> Parser (Key record))
-> Key record -> Parser (Key record)
forall a b. (a -> b) -> a -> b
$ record -> Key record
func record
val
Entity record -> Parser (Entity record)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Entity record -> Parser (Entity record))
-> Entity record -> Parser (Entity record)
forall a b. (a -> b) -> a -> b
$ Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity Key record
k record
val
instance (PersistEntity record, PersistField record, PersistField (Key record))
=> PersistField (Entity record) where
toPersistValue :: Entity record -> PersistValue
toPersistValue (Entity Key record
key record
value) = case record -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue record
value of
(PersistMap [(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)
PersistValue
_ -> 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 Text
"expected PersistMap"
fromPersistValue :: PersistValue -> Either Text (Entity record)
fromPersistValue (PersistMap [(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
$ Text
"did not find " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
idField Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
" field"
(Text
"_id", PersistValue
kv):[(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 ->
[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
>>= \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, PersistValue)]
_ -> 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
$ Text
"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
([(Text, PersistValue)]
before, [(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 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 Text
"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 Text
"PersistField entity fromPersistValue: "
idField :: Text
idField :: Text
idField = Text
"_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 PersistValue
z = case PersistValue
z of
PersistByteString 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 Text
"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 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 Text
"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)
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 Text
"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 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 String
err -> String -> Either String b
forall a b. a -> Either a b
Left String
err
Right Value
v -> case Value -> Result b
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
Error String
err -> String -> Either String b
forall a b. a -> Either a b
Left String
err
Success 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 t -> a
_ (Right b
a) = b -> Either a b
forall a b. b -> Either a b
Right b
a
mapLeft t -> a
f (Left 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 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 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 (Text
"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` Text
" was out of the "
Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"allowed bounds for an enum type")
class SymbolToField (sym :: Symbol) rec typ | sym rec -> typ where
symbolToField :: EntityField rec typ
instance SymbolToField sym rec typ => IsLabel sym (EntityField rec typ) where
fromLabel :: EntityField rec typ
fromLabel = forall rec typ. SymbolToField sym rec typ => EntityField rec typ
forall (sym :: Symbol) rec typ.
SymbolToField sym rec typ =>
EntityField rec typ
symbolToField @sym