{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Database.Persist.Class.PersistEntity
    ( PersistEntity (..)
    , tabulateEntity
    , Update (..)
    , BackendSpecificUpdate
    , SelectOpt (..)
    , Filter (..)
    , FilterValue (..)
    , BackendSpecificFilter
    , Entity (.., Entity, entityKey, entityVal)
    , ViaPersistEntity (..)
    , recordName
    , entityValues
    , keyValueEntityToJSON
    , keyValueEntityFromJSON
    , entityIdToJSON
    , entityIdFromJSON

      -- * PersistField based on other typeclasses
    , toPersistValueJSON
    , fromPersistValueJSON
    , toPersistValueEnum
    , fromPersistValueEnum

      -- * Support for @OverloadedLabels@ with 'EntityField'
    , SymbolToField (..)

      -- * Safety check for inserts
    , SafeToInsert
    , SafeToInsertErrorMessage
    ) where

import Data.Functor.Apply (Apply)
import Data.Functor.Constant

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)
import Data.Functor.Identity
import Web.PathPieces (PathMultiPiece (..), PathPiece (..))

#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.Kind (Type)
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.Records
import GHC.TypeLits

import Database.Persist.Class.PersistField
import Database.Persist.Names
import Database.Persist.Types.Base

-- | Persistent serialized Haskell records to the database.
-- A Database 'Entity' (A row in SQL, a document in MongoDB, etc)
-- corresponds to a 'Key' plus a Haskell record.
--
-- For every Haskell record type stored in the database there is a
-- corresponding 'PersistEntity' instance. An instance of PersistEntity
-- contains meta-data for the record.  PersistEntity also helps abstract
-- over different record types. That way the same query interface can return
-- a 'PersistEntity', with each query returning different types of Haskell
-- records.
--
-- Some advanced type system capabilities are used to make this process
-- type-safe. Persistent users usually don't need to understand the class
-- associated data and functions.
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
    -- | Persistent allows multiple different backends (databases).
    type PersistEntityBackend record

    -- | By default, a backend will automatically generate the key
    -- Instead you can specify a Primary key made up of unique values.
    data Key record

    -- | A lower-level key operation.
    keyToValues :: Key record -> [PersistValue]

    -- | A lower-level key operation.
    keyFromValues :: [PersistValue] -> Either Text (Key record)

    -- | A meta-operation to retrieve the 'Key' 'EntityField'.
    persistIdField :: EntityField record (Key record)

    -- | Retrieve the 'EntityDef' meta-data for the record.
    entityDef :: proxy record -> EntityDef

    -- | An 'EntityField' is parameterised by the Haskell record it belongs to
    -- and the additional type of that field.
    --
    -- As of @persistent-2.11.0.0@, it's possible to use the @OverloadedLabels@
    -- language extension to refer to 'EntityField' values polymorphically. See
    -- the documentation on 'SymbolToField' for more information.
    data EntityField record :: Type -> Type

    -- | Return meta-data for a given 'EntityField'.
    persistFieldDef :: EntityField record typ -> FieldDef

    -- | A meta-operation to get the database fields of a record.
    toPersistFields :: record -> [PersistValue]

    -- | A lower-level operation to convert from database values to a Haskell record.
    fromPersistValues :: [PersistValue] -> Either Text record

    -- | This function allows you to build an @'Entity' a@ by specifying an
    -- action that returns a value for the field in the callback function.
    -- Let's look at an example.
    --
    -- @
    -- parseFromEnvironmentVariables :: IO (Entity User)
    -- parseFromEnvironmentVariables =
    --     tabulateEntityA $ \\userField ->
    --         case userField of
    --             UserName ->
    --                 getEnv "USER_NAME"
    --             UserAge -> do
    --                 ageVar <- getEnv "USER_AGE"
    --                 case readMaybe ageVar of
    --                     Just age ->
    --                         pure age
    --                     Nothing ->
    --                         error $ "Failed to parse Age from: " <> ageVar
    --             UserAddressId -> do
    --                 addressVar <- getEnv "USER_ADDRESS_ID"
    --                 pure $ AddressKey addressVar
    -- @
    --
    -- @since 2.14.0.0
    tabulateEntityA
        :: (Applicative f)
        => (forall a. EntityField record a -> f a)
        -- ^ A function that builds a fragment of a record in an
        -- 'Applicative' context.
        -> f (Entity record)

    -- | Like 'tabulateEntityA', but works with any 'Apply' f. This works
    -- because all entities have at least one field, and so we can tabulate
    -- things into semigroup-like shapes instead.
    --
    -- @since 2.17.0.0
    tabulateEntityApply
        :: (Apply f)
        => (forall a. EntityField record a -> f a)
        -> f (Entity record)

    -- | Unique keys besides the 'Key'.
    data Unique record

    -- | A meta operation to retrieve all the 'Unique' keys.
    persistUniqueKeys :: record -> [Unique record]

    -- | A lower level operation.
    persistUniqueToFieldNames
        :: Unique record -> NonEmpty (FieldNameHS, FieldNameDB)

    -- | A lower level operation.
    persistUniqueToValues :: Unique record -> [PersistValue]

    -- | Use a 'PersistField' as a lens.
    fieldLens
        :: EntityField record field
        -> ( forall f
              . (Functor f) => (field -> f field) -> Entity record -> f (Entity record)
           )

    -- | Extract a @'Key' record@ from a @record@ value. Currently, this is
    -- only defined for entities using the @Primary@ syntax for
    -- natural/composite keys. In a future version of @persistent@ which
    -- incorporates the ID directly into the entity, this will always be Just.
    --
    -- @since 2.11.0.0
    keyFromRecordM :: Maybe (record -> Key record)
    keyFromRecordM = Maybe (record -> Key record)
forall a. Maybe a
Nothing

-- | Newtype wrapper for optionally deriving typeclass instances on
-- 'PersistEntity' keys.
--
-- @since 2.14.6.0
newtype ViaPersistEntity record = ViaPersistEntity (Key record)

instance (PersistEntity record) => PathMultiPiece (ViaPersistEntity record) where
    fromPathMultiPiece :: [Text] -> Maybe (ViaPersistEntity record)
fromPathMultiPiece [Text]
pieces = do
        Right Key record
key <- [PersistValue] -> Either Text (Key record)
forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues ([PersistValue] -> Either Text (Key record))
-> Maybe [PersistValue] -> Maybe (Either Text (Key record))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Maybe PersistValue) -> [Text] -> Maybe [PersistValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Maybe PersistValue
forall s. PathPiece s => Text -> Maybe s
fromPathPiece [Text]
pieces
        ViaPersistEntity record -> Maybe (ViaPersistEntity record)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ViaPersistEntity record -> Maybe (ViaPersistEntity record))
-> ViaPersistEntity record -> Maybe (ViaPersistEntity record)
forall a b. (a -> b) -> a -> b
$ Key record -> ViaPersistEntity record
forall record. Key record -> ViaPersistEntity record
ViaPersistEntity Key record
key
    toPathMultiPiece :: ViaPersistEntity record -> [Text]
toPathMultiPiece (ViaPersistEntity Key record
key) = (PersistValue -> Text) -> [PersistValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> Text
forall s. PathPiece s => s -> Text
toPathPiece ([PersistValue] -> [Text]) -> [PersistValue] -> [Text]
forall a b. (a -> b) -> a -> b
$ Key record -> [PersistValue]
forall record. PersistEntity record => Key record -> [PersistValue]
keyToValues Key record
key

-- | Construct an @'Entity' record@ by providing a value for each of the
-- record's fields.
--
-- These constructions are equivalent:
--
-- @
-- entityMattConstructor, entityMattTabulate :: Entity User
-- entityMattConstructor =
--     Entity
--         { entityKey = toSqlKey 123
--         , entityVal =
--             User
--                 { userName = "Matt"
--                 , userAge = 33
--                 }
--         }
--
-- entityMattTabulate =
--     tabulateEntity $ \\case
--         UserId ->
--             toSqlKey 123
--         UserName ->
--             "Matt"
--         UserAge ->
--             33
-- @
--
-- This is a specialization of 'tabulateEntityA', which allows you to
-- construct an 'Entity' by providing an 'Applicative' action for each
-- field instead of a regular function.
--
-- @since 2.14.0.0
tabulateEntity
    :: (PersistEntity record)
    => (forall a. EntityField record a -> a)
    -> Entity record
tabulateEntity :: forall record.
PersistEntity record =>
(forall a. EntityField record a -> a) -> Entity record
tabulateEntity forall a. EntityField record a -> a
fromField =
    Identity (Entity record) -> Entity record
forall a. Identity a -> a
runIdentity ((forall a. EntityField record a -> Identity a)
-> Identity (Entity record)
forall record (f :: * -> *).
(PersistEntity record, Applicative f) =>
(forall a. EntityField record a -> f a) -> f (Entity record)
forall (f :: * -> *).
Applicative f =>
(forall a. EntityField record a -> f a) -> f (Entity record)
tabulateEntityA (a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a)
-> (EntityField record a -> a)
-> EntityField record a
-> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityField record a -> a
forall a. EntityField record a -> a
fromField))

type family BackendSpecificUpdate backend record

-- Moved over from Database.Persist.Class.PersistUnique

-- | Textual representation of the record
recordName
    :: (PersistEntity record)
    => record -> Text
recordName :: forall record. PersistEntity record => 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
forall (proxy :: * -> *). 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

-- | Updating a database entity.
--
-- Persistent users use combinators to create these.
data Update record
    = forall typ. (PersistField typ) => Update
        { ()
updateField :: EntityField record typ
        , ()
updateValue :: typ
        , -- FIXME Replace with expr down the road
          forall record. Update record -> PersistUpdate
updateUpdate :: PersistUpdate
        }
    | BackendUpdate
        (BackendSpecificUpdate (PersistEntityBackend record) record)

-- | Query options.
--
-- Persistent users use these directly.
data SelectOpt record
    = forall typ. Asc (EntityField record typ)
    | forall typ. Desc (EntityField record typ)
    | OffsetBy Int
    | LimitTo Int

type family BackendSpecificFilter backend record

-- | Filters which are available for 'select', 'updateWhere' and
-- 'deleteWhere'. Each filter constructor specifies the field being
-- filtered on, the type of comparison applied (equals, not equals, etc)
-- and the argument for the comparison.
--
-- Persistent users use combinators to create these.
--
-- Note that it's important to be careful about the 'PersistFilter' that
-- you are using, if you use this directly. For example, using the 'In'
-- 'PersistFilter' requires that you have an array- or list-shaped
-- 'EntityField'. It is possible to construct values using this that will
-- create malformed runtime values.
data Filter record
    = forall typ. (PersistField typ) => Filter
        { ()
filterField :: EntityField record typ
        , ()
filterValue :: FilterValue typ
        , forall record. Filter record -> PersistFilter
filterFilter :: PersistFilter -- FIXME
        }
    | -- | convenient for internal use, not needed for the API
      FilterAnd [Filter record]
    | FilterOr [Filter record]
    | BackendFilter
        (BackendSpecificFilter (PersistEntityBackend record) record)

-- | Value to filter with. Highly dependant on the type of filter used.
--
-- @since 2.10.0
data FilterValue typ where
    FilterValue :: typ -> FilterValue typ
    FilterValues :: [typ] -> FilterValue typ
    UnsafeValue :: forall a typ. (PersistField a) => a -> FilterValue typ

-- | Datatype that represents an entity, with both its 'Key' and
-- its Haskell record representation.
--
-- When using a SQL-based backend (such as SQLite or
-- PostgreSQL), an 'Entity' may take any number of columns
-- depending on how many fields it has. In order to reconstruct
-- your entity on the Haskell side, @persistent@ needs all of
-- your entity columns and in the right order.  Note that you
-- don't need to worry about this when using @persistent@\'s API
-- since everything is handled correctly behind the scenes.
--
-- However, if you want to issue a raw SQL command that returns
-- an 'Entity', then you have to be careful with the column
-- order.  While you could use @SELECT Entity.* WHERE ...@ and
-- that would work most of the time, there are times when the
-- order of the columns on your database is different from the
-- order that @persistent@ expects (for example, if you add a new
-- field in the middle of you entity definition and then use the
-- migration code -- @persistent@ will expect the column to be in
-- the middle, but your DBMS will put it as the last column).
-- So, instead of using a query like the one above, you may use
-- 'Database.Persist.Sql.rawSql' (from the
-- "Database.Persist.Sql" module) with its /entity
-- selection placeholder/ (a double question mark @??@).  Using
-- @rawSql@ the query above must be written as @SELECT ??  WHERE
-- ..@.  Then @rawSql@ will replace @??@ with the list of all
-- columns that we need from your entity in the right order.  If
-- your query returns two entities (i.e. @(Entity backend a,
-- Entity backend b)@), then you must you use @SELECT ??, ??
-- WHERE ...@, and so on.
data Entity record
    = Entity
    { forall record. Entity record -> Key record
entityKey :: Key record
    , forall 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)

-- | Get list of values corresponding to given entity.
entityValues :: (PersistEntity record) => Entity record -> [PersistValue]
entityValues :: forall record.
PersistEntity record =>
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
            -- TODO: check against the key
            (PersistValue -> PersistValue) -> [PersistValue] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (record -> [PersistValue]
forall record. PersistEntity record => record -> [PersistValue]
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]
++ (PersistValue -> PersistValue) -> [PersistValue] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (record -> [PersistValue]
forall record. PersistEntity record => record -> [PersistValue]
toPersistFields record
record)
  where
    ent :: EntityDef
ent = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
forall (proxy :: * -> *). 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

-- | Predefined @toJSON@. The resulting JSON looks like
-- @{"key": 1, "value": {"name": ...}}@.
--
-- The typical usage is:
--
-- @
-- instance ToJSON (Entity User) where
--     toJSON = keyValueEntityToJSON
-- @
keyValueEntityToJSON
    :: (PersistEntity record, ToJSON record)
    => Entity record -> Value
keyValueEntityToJSON :: forall record.
(PersistEntity record, ToJSON record) =>
Entity record -> Value
keyValueEntityToJSON (Entity Key record
key record
value) =
    [Pair] -> Value
object
        [ Key
"key" Key -> Key record -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Key record
key
        , Key
"value" Key -> record -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= record
value
        ]

-- | Predefined @parseJSON@. The input JSON looks like
-- @{"key": 1, "value": {"name": ...}}@.
--
-- The typical usage is:
--
-- @
-- instance FromJSON (Entity User) where
--     parseJSON = keyValueEntityFromJSON
-- @
keyValueEntityFromJSON
    :: (PersistEntity record, FromJSON record)
    => Value -> Parser (Entity record)
keyValueEntityFromJSON :: forall record.
(PersistEntity record, FromJSON record) =>
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"keyValueEntityFromJSON: not an object"

-- | Predefined @toJSON@. The resulting JSON looks like
-- @{"id": 1, "name": ...}@.
--
-- The typical usage is:
--
-- @
-- instance ToJSON (Entity User) where
--     toJSON = entityIdToJSON
-- @
entityIdToJSON
    :: (PersistEntity record, ToJSON record) => Entity record -> Value
entityIdToJSON :: forall record.
(PersistEntity record, ToJSON record) =>
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

-- | Predefined @parseJSON@. The input JSON looks like
-- @{"id": 1, "name": ...}@.
--
-- The typical usage is:
--
-- @
-- instance FromJSON (Entity User) where
--     parseJSON = entityIdFromJSON
-- @
entityIdFromJSON
    :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record)
entityIdFromJSON :: forall record.
(PersistEntity record, FromJSON record) =>
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 a. a -> Parser a
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 a. a -> Parser a
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 a b. Either Text a -> (a -> Either Text b) -> Either Text b
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 a b. Either Text a -> (a -> Either Text b) -> Either Text b
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: "

-- | Realistically this is only going to be used for MongoDB,
-- so lets use MongoDB conventions
idField :: Text
idField :: Text
idField = Text
"_id"

-- | Convenience function for getting a free 'PersistField' instance
-- from a type with JSON instances.
--
--
-- Example usage in combination with 'fromPersistValueJSON':
--
-- @
-- instance PersistField MyData where
--   fromPersistValue = fromPersistValueJSON
--   toPersistValue = toPersistValueJSON
-- @
toPersistValueJSON :: (ToJSON a) => a -> PersistValue
toPersistValueJSON :: forall a. ToJSON a => a -> PersistValue
toPersistValueJSON = Text -> PersistValue
PersistText (Text -> PersistValue) -> (a -> Text) -> a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyText -> Text
LT.toStrict (LazyText -> Text) -> (a -> LazyText) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
TB.toLazyText (Builder -> LazyText) -> (a -> Builder) -> a -> LazyText
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

-- | Convenience function for getting a free 'PersistField' instance
-- from a type with JSON instances. The JSON parser used will accept JSON
-- values other that object and arrays. So, if your instance serializes the
-- data to a JSON string, this will still work.
--
--
-- Example usage in combination with 'toPersistValueJSON':
--
-- @
-- instance PersistField MyData where
--   fromPersistValue = fromPersistValueJSON
--   toPersistValue = toPersistValueJSON
-- @
fromPersistValueJSON :: (FromJSON a) => PersistValue -> Either Text a
fromPersistValueJSON :: forall a. FromJSON a => 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)

-- | Convenience function for getting a free 'PersistField' instance
-- from a type with an 'Enum' instance. The function 'derivePersistField'
-- from the persistent-template package should generally be preferred.
-- However, if you want to ensure that an @ORDER BY@ clause that uses
-- your field will order rows by the data constructor order, this is
-- a better choice.
--
-- Example usage in combination with 'fromPersistValueEnum':
--
-- @
-- data SeverityLevel = Low | Medium | Critical | High
--   deriving (Enum, Bounded)
-- instance PersistField SeverityLevel where
--   fromPersistValue = fromPersistValueEnum
--   toPersistValue = toPersistValueEnum
-- @
toPersistValueEnum :: (Enum a) => a -> PersistValue
toPersistValueEnum :: forall a. Enum a => 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

-- | Convenience function for getting a free 'PersistField' instance
-- from a type with an 'Enum' instance. This function also requires
-- a `Bounded` instance to improve the reporting of errors.
--
-- Example usage in combination with 'toPersistValueEnum':
--
-- @
-- data SeverityLevel = Low | Medium | Critical | High
--   deriving (Enum, Bounded)
-- instance PersistField SeverityLevel where
--   fromPersistValue = fromPersistValueEnum
--   toPersistValue = toPersistValueEnum
-- @
fromPersistValueEnum :: (Enum a, Bounded a) => PersistValue -> Either Text a
fromPersistValueEnum :: forall a. (Enum a, Bounded a) => 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 a b. Either Text a -> (a -> Either Text b) -> Either Text b
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"
                        )

-- | This type class is used with the @OverloadedLabels@ extension to
-- provide a more convenient means of using the 'EntityField' type.
-- 'EntityField' definitions are prefixed with the type name to avoid
-- ambiguity, but this ambiguity can result in verbose code.
--
-- If you have a table @User@ with a @name Text@ field, then the
-- corresponding 'EntityField' is @UserName@. With this, we can write
-- @#name :: 'EntityField' User Text@.
--
-- What's more fun is that the type is more general: it's actually
-- @
-- #name
--     :: ('SymbolToField' "name" rec typ)
--     => EntityField rec typ
-- @
--
-- Which means it is *polymorphic* over the actual record. This allows you
-- to write code that can be generic over the tables, provided they have
-- the right fields.
--
-- @since 2.11.0.0
class SymbolToField (sym :: Symbol) rec typ | sym rec -> typ where
    symbolToField :: EntityField rec typ

-- | This instance delegates to 'SymbolToField' to provide
-- @OverloadedLabels@ support to the 'EntityField' type.
--
-- @since 2.11.0.0
instance (SymbolToField sym rec typ) => IsLabel sym (EntityField rec typ) where
    fromLabel :: EntityField rec typ
fromLabel = forall (sym :: Symbol) rec typ.
SymbolToField sym rec typ =>
EntityField rec typ
symbolToField @sym

-- | A type class which is used to witness that a type is safe to insert into
-- the database without providing a primary key.
--
-- The @TemplateHaskell@ function 'mkPersist' will generate instances of this
-- class for any entity that it works on. If the entity has a default primary
-- key, then it provides a regular instance. If the entity has a @Primary@
-- natural key, then this works fine. But if the entity has an @Id@ column with
-- no @default=@, then this does a 'TypeError' and forces the user to use
-- 'insertKey'.
--
-- @since 2.14.0.0
class SafeToInsert a

type SafeToInsertErrorMessage a =
    'Text "The PersistEntity "
        ':<>: ShowType a
        ':<>: 'Text " does not have a default primary key."
        ':$$: 'Text "This means that 'insert' will fail with a database error."
        ':$$: 'Text "Please  provide a default= clause inthe entity definition,"
        ':$$: 'Text "or use 'insertKey' instead to provide one."

instance (TypeError (FunctionErrorMessage a b)) => SafeToInsert (a -> b)

type FunctionErrorMessage a b =
    'Text
        "Uh oh! It looks like you are trying to insert a function into the database."
        ':$$: 'Text "Argument: " ':<>: 'ShowType a
        ':$$: 'Text "Result:   " ':<>: 'ShowType b
        ':$$: 'Text "You probably need to add more arguments to an Entity construction."

type EntityErrorMessage a =
    'Text "It looks like you're trying to `insert` an `Entity "
        ':<>: 'ShowType a
        ':<>: 'Text "` directly."
        ':$$: 'Text "You want `insertKey` instead. As an example:"
        ':$$: 'Text "    insertKey (entityKey ent) (entityVal ent)"

instance (TypeError (EntityErrorMessage a)) => SafeToInsert (Entity a)