{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, UndecidableInstances, FlexibleInstances, IncoherentInstances, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, GeneralizedNewtypeDeriving #-}

module IHP.ModelSupport
( module IHP.ModelSupport
, module IHP.Postgres.Point
, module IHP.Postgres.Inet
) where

import IHP.HaskellSupport
import IHP.NameSupport
import qualified Prelude
import ClassyPrelude hiding (UTCTime, find, ModifiedJulianDay)
import qualified ClassyPrelude
import Database.PostgreSQL.Simple (Connection)
import qualified Text.Inflections
import Database.PostgreSQL.Simple.Types (Query (Query))
import Database.PostgreSQL.Simple.FromField hiding (Field, name)
import Database.PostgreSQL.Simple.ToField
import Data.Default
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.String.Conversions (cs ,ConvertibleStrings)
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.Calendar
import Data.Time.Format
import Unsafe.Coerce
import Data.UUID
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.Types as PG
import GHC.Records
import GHC.OverloadedLabels
import GHC.TypeLits
import GHC.Types
import Data.Proxy
import Data.Data
import qualified Control.Newtype.Generics as Newtype
import Control.Applicative (Const)
import qualified GHC.Types as Type
import qualified Data.Text as Text
import Data.Aeson (ToJSON (..))
import qualified Data.Aeson as Aeson
import qualified Data.Set as Set
import qualified Text.Read as Read
import qualified Data.Pool as Pool
import qualified GHC.Conc
import IHP.Postgres.Point
import IHP.Postgres.Inet
import qualified Data.ByteString.Char8 as ByteString
import IHP.Log.Types
import qualified IHP.Log as Log
import Data.Dynamic

-- | Provides the db connection and some IHP-specific db configuration
data ModelContext = ModelContext
    { ModelContext -> Pool Connection
connectionPool :: Pool.Pool Connection -- ^ Used to get database connections when no 'transactionConnection' is set
    , ModelContext -> Maybe Connection
transactionConnection :: Maybe Connection -- ^ Set to a specific database connection when executing a database transaction
    -- | Logs all queries to this logger at log level info
    , ModelContext -> Logger
logger :: Logger
    -- | A callback that is called whenever a specific table is accessed using a SELECT query
    , ModelContext -> Maybe (ByteString -> IO ())
trackTableReadCallback :: Maybe (ByteString -> IO ())
    }

-- | Provides a mock ModelContext to be used when a database connection is not available
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext Logger
logger = ModelContext :: Pool Connection
-> Maybe Connection
-> Logger
-> Maybe (ByteString -> IO ())
-> ModelContext
ModelContext
    { $sel:connectionPool:ModelContext :: Pool Connection
connectionPool = [Char] -> Pool Connection
forall a. HasCallStack => [Char] -> a
error [Char]
"Not connected"
    , $sel:transactionConnection:ModelContext :: Maybe Connection
transactionConnection = Maybe Connection
forall a. Maybe a
Nothing
    , $sel:logger:ModelContext :: Logger
logger = Logger
logger
    , $sel:trackTableReadCallback:ModelContext :: Maybe (ByteString -> IO ())
trackTableReadCallback = Maybe (ByteString -> IO ())
forall a. Maybe a
Nothing
    }

createModelContext :: NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
createModelContext :: NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
createModelContext NominalDiffTime
idleTime Int
maxConnections ByteString
databaseUrl Logger
logger = do
    Int
numStripes <- IO Int
GHC.Conc.getNumCapabilities
    let create :: IO Connection
create = ByteString -> IO Connection
PG.connectPostgreSQL ByteString
databaseUrl
    let destroy :: Connection -> IO ()
destroy = Connection -> IO ()
PG.close
    Pool Connection
connectionPool <- IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool Connection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
Pool.createPool IO Connection
create Connection -> IO ()
destroy Int
numStripes NominalDiffTime
idleTime Int
maxConnections

    let queryDebuggingEnabled :: Bool
queryDebuggingEnabled = Bool
False -- The app server will override this in dev mode and set it to True
    let trackTableReadCallback :: Maybe a
trackTableReadCallback = Maybe a
forall a. Maybe a
Nothing
    let transactionConnection :: Maybe a
transactionConnection = Maybe a
forall a. Maybe a
Nothing
    ModelContext -> IO ModelContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext :: Pool Connection
-> Maybe Connection
-> Logger
-> Maybe (ByteString -> IO ())
-> ModelContext
ModelContext { Maybe Connection
Maybe (ByteString -> IO ())
Logger
Pool Connection
forall a. Maybe a
transactionConnection :: forall a. Maybe a
trackTableReadCallback :: forall a. Maybe a
connectionPool :: Pool Connection
logger :: Logger
$sel:trackTableReadCallback:ModelContext :: Maybe (ByteString -> IO ())
$sel:logger:ModelContext :: Logger
$sel:transactionConnection:ModelContext :: Maybe Connection
$sel:connectionPool:ModelContext :: Pool Connection
.. }

instance LoggingProvider ModelContext where
    getLogger :: ModelContext -> Logger
getLogger ModelContext { Maybe Connection
Maybe (ByteString -> IO ())
Logger
Pool Connection
trackTableReadCallback :: Maybe (ByteString -> IO ())
logger :: Logger
transactionConnection :: Maybe Connection
connectionPool :: Pool Connection
$sel:trackTableReadCallback:ModelContext :: ModelContext -> Maybe (ByteString -> IO ())
$sel:logger:ModelContext :: ModelContext -> Logger
$sel:transactionConnection:ModelContext :: ModelContext -> Maybe Connection
$sel:connectionPool:ModelContext :: ModelContext -> Pool Connection
.. } = Logger
logger

type family GetModelById id :: Type where
    GetModelById (Maybe (Id' tableName)) = Maybe (GetModelByTableName tableName)
    GetModelById (Id' tableName) = GetModelByTableName tableName
type family GetTableName model :: Symbol
type family GetModelByTableName (tableName :: Symbol) :: Type

class CanCreate a where
    create :: (?modelContext :: ModelContext) => a -> IO a
    createMany :: (?modelContext :: ModelContext) => [a] -> IO [a]

class CanUpdate a where
    updateRecord :: (?modelContext :: ModelContext) => a -> IO a

{-# INLINE createRecord #-}
createRecord :: (?modelContext :: ModelContext, CanCreate model) => model -> IO model
createRecord :: model -> IO model
createRecord = model -> IO model
forall a. (CanCreate a, ?modelContext::ModelContext) => a -> IO a
create

class InputValue a where
    inputValue :: a -> Text

instance InputValue Text where
    inputValue :: Text -> Text
inputValue Text
text = Text
text

instance InputValue Int where
    inputValue :: Int -> Text
inputValue = Int -> Text
forall a. Show a => a -> Text
tshow

instance InputValue Integer where
    inputValue :: Integer -> Text
inputValue = Integer -> Text
forall a. Show a => a -> Text
tshow

instance InputValue Double where
    inputValue :: Double -> Text
inputValue = Double -> Text
forall a. Show a => a -> Text
tshow

instance InputValue Float where
    inputValue :: Float -> Text
inputValue = Float -> Text
forall a. Show a => a -> Text
tshow

instance InputValue Bool where
    inputValue :: Bool -> Text
inputValue Bool
True = Text
"on"
    inputValue Bool
False = Text
"off"

instance InputValue Data.UUID.UUID where
    inputValue :: UUID -> Text
inputValue = UUID -> Text
Data.UUID.toText

instance InputValue () where
    inputValue :: () -> Text
inputValue () = Text
"error: inputValue(()) not supported"

instance InputValue UTCTime where
    inputValue :: UTCTime -> Text
inputValue UTCTime
time = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (UTCTime -> [Char]
forall t. ISO8601 t => t -> [Char]
iso8601Show UTCTime
time)

instance InputValue LocalTime where
    inputValue :: LocalTime -> Text
inputValue LocalTime
time = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (LocalTime -> [Char]
forall t. ISO8601 t => t -> [Char]
iso8601Show LocalTime
time)

instance InputValue Day where
    inputValue :: Day -> Text
inputValue Day
date = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Day -> [Char]
forall t. ISO8601 t => t -> [Char]
iso8601Show Day
date)

instance InputValue fieldType => InputValue (Maybe fieldType) where
    inputValue :: Maybe fieldType -> Text
inputValue (Just fieldType
value) = fieldType -> Text
forall a. InputValue a => a -> Text
inputValue fieldType
value
    inputValue Maybe fieldType
Nothing = Text
""

instance InputValue value => InputValue [value] where
    inputValue :: [value] -> Text
inputValue [value]
list = [value]
list [value] -> ([value] -> [Text]) -> [Text]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> (value -> Text) -> [value] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map value -> Text
forall a. InputValue a => a -> Text
inputValue [Text] -> ([Text] -> Text) -> Text
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
","

instance InputValue Aeson.Value where
    inputValue :: Value -> Text
inputValue Value
json = Value
json Value -> (Value -> ByteString) -> ByteString
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode ByteString -> (ByteString -> Text) -> Text
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs

instance Default Text where
    {-# INLINE def #-}
    def :: Text
def = Text
""

instance Default Bool where
    {-# INLINE def #-}
    def :: Bool
def = Bool
False

instance Default Point where
    def :: Point
def = Double -> Double -> Point
Point Double
forall a. Default a => a
def Double
forall a. Default a => a
def

type FieldName = ByteString

-- | Returns @True@ when the record has not been saved to the database yet. Returns @False@ otherwise.
--
-- __Example:__ Returns @False@ when a record has not been inserted yet.
--
-- >>> let project = newRecord @Project
-- >>> isNew project
-- False
--
-- __Example:__ Returns @True@ after inserting a record.
--
-- >>> project <- createRecord project
-- >>> isNew project
-- True
--
-- __Example:__ Returns @True@ for records which have been fetched from the database.
--
-- >>> book <- query @Book |> fetchOne
-- >>> isNew book
-- False
isNew :: forall model id. (HasField "id" model id, Default id, Eq id) => model -> Bool
isNew :: model -> Bool
isNew model
model = id
forall a. Default a => a
def id -> id -> Bool
forall a. Eq a => a -> a -> Bool
== (model -> id
forall k (x :: k) r a. HasField x r a => r -> a
getField @"id" model
model)
{-# INLINE isNew #-}

type family GetModelName model :: Symbol

-- | Provides the primary key type for a given table. The instances are usually declared
-- by the generated haskell code in Generated.Types
--
-- __Example:__ Defining the primary key for a users table
--
-- > type instance PrimaryKey "users" = UUID
--
--
-- __Example:__ Defining the primary key for a table with a SERIAL pk
--
-- > type instance PrimaryKey "projects" = Int
--
type family PrimaryKey (tableName :: Symbol)

-- | Returns the model name of a given model as Text
--
-- __Example:__
--
-- >>> modelName @User
-- "User"
--
-- >>> modelName @Project
-- "Project"
getModelName :: forall model. KnownSymbol (GetModelName model) => Text
getModelName :: Text
getModelName = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$! Proxy (GetModelName model) -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy (GetModelName model)
forall k (t :: k). Proxy t
Proxy :: Proxy (GetModelName model))
{-# INLINE getModelName #-}

newtype Id' table = Id (PrimaryKey table)

deriving instance (Eq (PrimaryKey table)) => Eq (Id' table)
deriving instance (Ord (PrimaryKey table)) => Ord (Id' table)
deriving instance (Hashable (PrimaryKey table)) => Hashable (Id' table)
deriving instance (KnownSymbol table, Data (PrimaryKey table)) => Data (Id' table)
deriving instance (KnownSymbol table, NFData (PrimaryKey table)) => NFData (Id' table)

-- | We need to map the model to it's table name to prevent infinite recursion in the model data definition
-- E.g. `type Project = Project' { id :: Id Project }` will not work
-- But `type Project = Project' { id :: Id "projects" }` will
type Id model = Id' (GetTableName model)

instance InputValue (PrimaryKey model') => InputValue (Id' model') where
    {-# INLINE inputValue #-}
    inputValue :: Id' model' -> Text
inputValue = PrimaryKey model' -> Text
forall a. InputValue a => a -> Text
inputValue (PrimaryKey model' -> Text)
-> (Id' model' -> PrimaryKey model') -> Id' model' -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Id' model' -> PrimaryKey model'
forall n. Newtype n => n -> O n
Newtype.unpack

instance IsEmpty (PrimaryKey table) => IsEmpty (Id' table) where
    isEmpty :: Id' table -> Bool
isEmpty (Id PrimaryKey table
primaryKey) = PrimaryKey table -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty PrimaryKey table
primaryKey

recordToInputValue :: (HasField "id" entity (Id entity), Show (PrimaryKey (GetTableName entity))) => entity -> Text
recordToInputValue :: entity -> Text
recordToInputValue entity
entity =
    entity -> Id' (GetTableName entity)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"id" entity
entity
    Id' (GetTableName entity)
-> (Id' (GetTableName entity) -> PrimaryKey (GetTableName entity))
-> PrimaryKey (GetTableName entity)
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Id' (GetTableName entity) -> PrimaryKey (GetTableName entity)
forall n. Newtype n => n -> O n
Newtype.unpack
    PrimaryKey (GetTableName entity)
-> (PrimaryKey (GetTableName entity) -> Text) -> Text
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> PrimaryKey (GetTableName entity) -> Text
forall a. Show a => a -> Text
tshow
{-# INLINE recordToInputValue #-}

instance FromField (PrimaryKey model) => FromField (Id' model) where
    {-# INLINE fromField #-}
    fromField :: FieldParser (Id' model)
fromField Field
value Maybe ByteString
metaData = do
        PrimaryKey model
fieldValue <- FieldParser (PrimaryKey model)
forall a. FromField a => FieldParser a
fromField Field
value Maybe ByteString
metaData
        Id' model -> Conversion (Id' model)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimaryKey model -> Id' model
forall (table :: Symbol). PrimaryKey table -> Id' table
Id PrimaryKey model
fieldValue)

instance ToField (PrimaryKey model) => ToField (Id' model) where
    {-# INLINE toField #-}
    toField :: Id' model -> Action
toField = PrimaryKey model -> Action
forall a. ToField a => a -> Action
toField (PrimaryKey model -> Action)
-> (Id' model -> PrimaryKey model) -> Id' model -> Action
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Id' model -> PrimaryKey model
forall n. Newtype n => n -> O n
Newtype.unpack

instance Show (PrimaryKey model) => Show (Id' model) where
    {-# INLINE show #-}
    show :: Id' model -> [Char]
show = PrimaryKey model -> [Char]
forall a. Show a => a -> [Char]
show (PrimaryKey model -> [Char])
-> (Id' model -> PrimaryKey model) -> Id' model -> [Char]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Id' model -> PrimaryKey model
forall n. Newtype n => n -> O n
Newtype.unpack

instance Newtype.Newtype (Id' model) where
    type O (Id' model) = PrimaryKey model
    pack :: O (Id' model) -> Id' model
pack = O (Id' model) -> Id' model
forall (table :: Symbol). PrimaryKey table -> Id' table
Id
    unpack :: Id' model -> O (Id' model)
unpack (Id PrimaryKey model
uuid) = O (Id' model)
PrimaryKey model
uuid

-- | Sometimes you have a hardcoded UUID value which represents some record id. This instance allows you
-- to write the Id like a string:
--
-- > let projectId = "ca63aace-af4b-4e6c-bcfa-76ca061dbdc6" :: Id Project
instance (Read (PrimaryKey model), ParsePrimaryKey (PrimaryKey model)) => IsString (Id' model) where
    fromString :: [Char] -> Id' model
fromString [Char]
uuid = [Char] -> Id' model
forall (model :: Symbol) text.
(ParsePrimaryKey (PrimaryKey model),
 ConvertibleStrings text Text) =>
text -> Id' model
textToId [Char]
uuid

class ParsePrimaryKey primaryKey where
    parsePrimaryKey :: Text -> Maybe primaryKey

instance ParsePrimaryKey UUID where
    parsePrimaryKey :: Text -> Maybe UUID
parsePrimaryKey = [Char] -> Maybe UUID
forall a. Read a => [Char] -> Maybe a
Read.readMaybe ([Char] -> Maybe UUID) -> (Text -> [Char]) -> Text -> Maybe UUID
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs

instance ParsePrimaryKey Text where
    parsePrimaryKey :: Text -> Maybe Text
parsePrimaryKey Text
text = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
text

-- | Transforms a text, bytestring or string into an Id. Throws an exception if the input is invalid.
--
-- __Example:__
--
-- > let projectIdText = "7cbc76e2-1c4f-49b6-a7d9-5015e7575a9b" :: Text
-- > let projectId = (textToId projectIdText) :: Id Project
--
-- In case your UUID value is hardcoded, there is also an 'IsString' instance, so you
-- can just write it like:
--
-- > let projectId = "ca63aace-af4b-4e6c-bcfa-76ca061dbdc6" :: Id Project
textToId :: (ParsePrimaryKey (PrimaryKey model), ConvertibleStrings text Text) => text -> Id' model
textToId :: text -> Id' model
textToId text
text = case Text -> Maybe (PrimaryKey model)
forall primaryKey.
ParsePrimaryKey primaryKey =>
Text -> Maybe primaryKey
parsePrimaryKey (text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs text
text) of
        Just PrimaryKey model
id -> PrimaryKey model -> Id' model
forall (table :: Symbol). PrimaryKey table -> Id' table
Id PrimaryKey model
id
        Maybe (PrimaryKey model)
Nothing -> [Char] -> Id' model
forall a. HasCallStack => [Char] -> a
error (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text
"Unable to convert " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs text
text :: Text) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to Id value. Is it a valid uuid?")
{-# INLINE textToId #-}

instance Default (PrimaryKey model) => Default (Id' model) where
    {-# INLINE def #-}
    def :: Id' model
def = O (Id' model) -> Id' model
forall n. Newtype n => O n -> n
Newtype.pack O (Id' model)
forall a. Default a => a
def


-- | Measure and log the query time for a given query action if the log level is Debug.
-- If the log level is greater than debug, just perform the query action without measuring time.
measureTimeIfLogging :: (?modelContext :: ModelContext, Show q) => IO a -> Query -> q -> IO a
measureTimeIfLogging :: IO a -> Query -> q -> IO a
measureTimeIfLogging IO a
queryAction Query
theQuery q
theParameters = do
    let currentLogLevel :: LogLevel
currentLogLevel = Proxy "logger" -> ModelContext -> Logger
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "logger" (Proxy "logger")
Proxy "logger"
#logger ?modelContext::ModelContext
ModelContext
?modelContext Logger -> (Logger -> LogLevel) -> LogLevel
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "level" -> Logger -> LogLevel
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "level" (Proxy "level")
Proxy "level"
#level
    if LogLevel
currentLogLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
Debug
        then do
            UTCTime
start <- IO UTCTime
getCurrentTime
            a
result <- IO a
queryAction
            UTCTime
end <- IO UTCTime
getCurrentTime
            let theTime :: NominalDiffTime
theTime = UTCTime
end UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
start
            Query -> q -> NominalDiffTime -> IO ()
forall query parameters.
(?modelContext::ModelContext, Show query, Show parameters) =>
query -> parameters -> NominalDiffTime -> IO ()
logQuery Query
theQuery q
theParameters NominalDiffTime
theTime
            a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
        else IO a
queryAction

-- | Runs a raw sql query
--
-- __Example:__
--
-- > users <- sqlQuery "SELECT id, firstname, lastname FROM users" ()
--
-- Take a look at "IHP.QueryBuilder" for a typesafe approach on building simple queries.
sqlQuery :: (?modelContext :: ModelContext, PG.ToRow q, PG.FromRow r, Show q) => Query -> q -> IO [r]
sqlQuery :: Query -> q -> IO [r]
sqlQuery Query
theQuery q
theParameters = do
    IO [r] -> Query -> q -> IO [r]
forall q a.
(?modelContext::ModelContext, Show q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
        ((Connection -> IO [r]) -> IO [r]
forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> Connection -> Query -> q -> IO [r]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
connection Query
theQuery q
theParameters)
        Query
theQuery
        q
theParameters
{-# INLINABLE sqlQuery #-}

-- | Runs a sql statement (like a CREATE statement)
--
-- __Example:__
--
-- > sqlExec "CREATE TABLE users ()" ()
sqlExec :: (?modelContext :: ModelContext, PG.ToRow q, Show q) => Query -> q -> IO Int64
sqlExec :: Query -> q -> IO Int64
sqlExec Query
theQuery q
theParameters = do
    IO Int64 -> Query -> q -> IO Int64
forall q a.
(?modelContext::ModelContext, Show q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
        ((Connection -> IO Int64) -> IO Int64
forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> Connection -> Query -> q -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
PG.execute Connection
connection Query
theQuery q
theParameters)
        Query
theQuery
        q
theParameters
{-# INLINABLE sqlExec #-}

withDatabaseConnection :: (?modelContext :: ModelContext) => (Connection -> IO a) -> IO a
withDatabaseConnection :: (Connection -> IO a) -> IO a
withDatabaseConnection Connection -> IO a
block =
    let
        ModelContext { Pool Connection
connectionPool :: Pool Connection
$sel:connectionPool:ModelContext :: ModelContext -> Pool Connection
connectionPool, Maybe Connection
transactionConnection :: Maybe Connection
$sel:transactionConnection:ModelContext :: ModelContext -> Maybe Connection
transactionConnection } = ?modelContext::ModelContext
ModelContext
?modelContext
    in case Maybe Connection
transactionConnection of
        Just Connection
transactionConnection -> Connection -> IO a
block Connection
transactionConnection
        Maybe Connection
Nothing -> Pool Connection -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource Pool Connection
connectionPool Connection -> IO a
block
{-# INLINABLE withDatabaseConnection #-}

-- | Runs a raw sql query which results in a single scalar value such as an integer or string
--
-- __Example:__
--
-- > usersCount <- sqlQuery "SELECT COUNT(*) FROM users"
--
-- Take a look at "IHP.QueryBuilder" for a typesafe approach on building simple queries.
sqlQueryScalar :: (?modelContext :: ModelContext) => (PG.ToRow q, Show q, FromField value) => Query -> q -> IO value
sqlQueryScalar :: Query -> q -> IO value
sqlQueryScalar Query
theQuery q
theParameters = do
    [Only value]
result <- IO [Only value] -> Query -> q -> IO [Only value]
forall q a.
(?modelContext::ModelContext, Show q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
        ((Connection -> IO [Only value]) -> IO [Only value]
forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> Connection -> Query -> q -> IO [Only value]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
connection Query
theQuery q
theParameters)
        Query
theQuery
        q
theParameters
    value -> IO value
forall (f :: * -> *) a. Applicative f => a -> f a
pure case [Only value]
result of
        [PG.Only value
result] -> value
result
        [Only value]
_ -> [Char] -> value
forall a. HasCallStack => [Char] -> a
error [Char]
"sqlQueryScalar: Expected a scalar result value"
{-# INLINABLE sqlQueryScalar #-}

-- | Executes the given block with a database transaction
--
-- __Example:__
--
-- > withTransaction do
-- >    company <- newRecord @Company |> createRecord
-- >
-- >    -- When creating the user fails, there will be no company left over
-- >    user <- newRecord @User
-- >        |> set #companyId (get #id company)
-- >        |> createRecord
-- >
-- >    company <- company
-- >        |> set #ownerId (get #id user)
-- >        |> updateRecord
withTransaction :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext) => IO a) -> IO a
withTransaction :: ((?modelContext::ModelContext) => IO a) -> IO a
withTransaction (?modelContext::ModelContext) => IO a
block = ((?modelContext::ModelContext) => IO a) -> IO a
forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withTransactionConnection do
    let connection :: Connection
connection = ?modelContext::ModelContext
ModelContext
?modelContext
            ModelContext
-> (ModelContext -> Maybe Connection) -> Maybe Connection
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "transactionConnection" -> ModelContext -> Maybe Connection
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "transactionConnection" (Proxy "transactionConnection")
Proxy "transactionConnection"
#transactionConnection
            Maybe Connection -> (Maybe Connection -> Connection) -> Connection
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
                Just Connection
connection -> Connection
connection
                Maybe Connection
Nothing -> [Char] -> Connection
forall a. HasCallStack => [Char] -> a
error [Char]
"withTransaction: transactionConnection not set as expected"
    Connection -> IO a -> IO a
forall a. Connection -> IO a -> IO a
PG.withTransaction Connection
connection IO a
(?modelContext::ModelContext) => IO a
block
{-# INLINABLE withTransaction #-}

-- | Returns the postgres connection when called within a 'withTransaction' block
--
-- Throws an error if called from outside a 'withTransaction'
transactionConnectionOrError :: (?modelContext :: ModelContext) => Connection
transactionConnectionOrError :: Connection
transactionConnectionOrError = ?modelContext::ModelContext
ModelContext
?modelContext
            ModelContext
-> (ModelContext -> Maybe Connection) -> Maybe Connection
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "transactionConnection" -> ModelContext -> Maybe Connection
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "transactionConnection" (Proxy "transactionConnection")
Proxy "transactionConnection"
#transactionConnection
            Maybe Connection -> (Maybe Connection -> Connection) -> Connection
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
                Just Connection
connection -> Connection
connection
                Maybe Connection
Nothing -> [Char] -> Connection
forall a. HasCallStack => [Char] -> a
error [Char]
"getTransactionConnectionOrError: Not in a transaction state"

commitTransaction :: (?modelContext :: ModelContext) => IO ()
commitTransaction :: IO ()
commitTransaction = Connection -> IO ()
PG.commit Connection
(?modelContext::ModelContext) => Connection
transactionConnectionOrError
{-# INLINABLE commitTransaction #-}

rollbackTransaction :: (?modelContext :: ModelContext) => IO ()
rollbackTransaction :: IO ()
rollbackTransaction = Connection -> IO ()
PG.rollback Connection
(?modelContext::ModelContext) => Connection
transactionConnectionOrError
{-# INLINABLE rollbackTransaction #-}

withTransactionConnection :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext) => IO a) -> IO a
withTransactionConnection :: ((?modelContext::ModelContext) => IO a) -> IO a
withTransactionConnection (?modelContext::ModelContext) => IO a
block = do
    (Connection -> IO a) -> IO a
forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> do
        let modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext { $sel:transactionConnection:ModelContext :: Maybe Connection
transactionConnection = Connection -> Maybe Connection
forall a. a -> Maybe a
Just Connection
connection }
        let ?modelContext = modelContext in IO a
(?modelContext::ModelContext) => IO a
block
{-# INLINABLE withTransactionConnection #-}

-- | Returns the table name of a given model.
--
-- __Example:__
--
-- >>> tableName @User
-- "users"
--
tableName :: forall model. (KnownSymbol (GetTableName model)) => Text
tableName :: Text
tableName = KnownSymbol (GetTableName model) => Text
forall (symbol :: Symbol). KnownSymbol symbol => Text
symbolToText @(GetTableName model)
{-# INLINE tableName #-}

-- | Returns the table name of a given model as a bytestring.
--
-- __Example:__
--
-- >>> tableNameByteString @User
-- "users"
--
tableNameByteString :: forall model. (KnownSymbol (GetTableName model)) => ByteString
tableNameByteString :: ByteString
tableNameByteString = KnownSymbol (GetTableName model) => ByteString
forall (symbol :: Symbol). KnownSymbol symbol => ByteString
symbolToByteString @(GetTableName model)
{-# INLINE tableNameByteString #-}

logQuery :: (?modelContext :: ModelContext, Show query, Show parameters) => query -> parameters -> NominalDiffTime -> IO ()
logQuery :: query -> parameters -> NominalDiffTime -> IO ()
logQuery query
query parameters
parameters NominalDiffTime
time = do
        let ?context = ?modelContext
        -- NominalTimeDiff is represented as seconds, and doesn't provide a FormatTime option for printing in ms.
        -- To get around that we convert to and from a rational so we can format as desired.
        let queryTimeInMs :: Double
queryTimeInMs = (NominalDiffTime
time NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000) NominalDiffTime -> (NominalDiffTime -> Rational) -> Rational
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational Rational -> (Rational -> Double) -> Double
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Fractional Double => Rational -> Double
forall a. Fractional a => Rational -> a
fromRational @Double
        Text -> IO ()
forall context.
(?context::context, LoggingProvider context) =>
Text -> IO ()
Log.debug (Text
"Query (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Double -> Text
forall a. Show a => a -> Text
tshow Double
queryTimeInMs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ms): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> query -> Text
forall a. Show a => a -> Text
tshow query
query Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> parameters -> Text
forall a. Show a => a -> Text
tshow parameters
parameters)
{-# INLINABLE logQuery #-}

-- | Runs a @DELETE@ query for a record.
--
-- >>> let project :: Project = ...
-- >>> deleteRecord project
-- DELETE FROM projects WHERE id = '..'
--
-- Use 'deleteRecords' if you want to delete multiple records.
deleteRecord :: forall model id. (?modelContext :: ModelContext, Show id, KnownSymbol (GetTableName model), HasField "id" model id, ToField id) => model -> IO ()
deleteRecord :: model -> IO ()
deleteRecord model
model = Proxy "id" -> model -> id
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "id" (Proxy "id")
Proxy "id"
#id model
model id -> (id -> IO ()) -> IO ()
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> (?modelContext::ModelContext, Show id,
 KnownSymbol (GetTableName model), HasField "id" model id,
 ToField id) =>
id -> IO ()
forall model id.
(?modelContext::ModelContext, Show id,
 KnownSymbol (GetTableName model), HasField "id" model id,
 ToField id) =>
id -> IO ()
deleteRecordById @model @id
{-# INLINABLE deleteRecord #-}

-- | Like 'deleteRecord' but using an Id
--
-- >>> let project :: Id Project = ...
-- >>> delete projectId
-- DELETE FROM projects WHERE id = '..'
--
deleteRecordById :: forall model id. (?modelContext :: ModelContext, Show id, KnownSymbol (GetTableName model), HasField "id" model id, ToField id) => id -> IO ()
deleteRecordById :: id -> IO ()
deleteRecordById id
id = do
    let theQuery :: Text
theQuery = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KnownSymbol (GetTableName model) => Text
forall model. KnownSymbol (GetTableName model) => Text
tableName @model Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = ?"
    let theParameters :: Only id
theParameters = (id -> Only id
forall a. a -> Only a
PG.Only id
id)
    Query -> Only id -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q, Show q) =>
Query -> q -> IO Int64
sqlExec (ByteString -> Query
PG.Query (ByteString -> Query) -> (Text -> ByteString) -> Text -> Query
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$! Text
theQuery) Only id
theParameters
    () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE deleteRecordById #-}

-- | Runs a @DELETE@ query for a list of records.
--
-- >>> let projects :: [Project] = ...
-- >>> deleteRecords projects
-- DELETE FROM projects WHERE id IN (..)
deleteRecords :: forall record id. (?modelContext :: ModelContext, Show id, KnownSymbol (GetTableName record), HasField "id" record id, record ~ GetModelById id, ToField id) => [record] -> IO ()
deleteRecords :: [record] -> IO ()
deleteRecords [record]
records = do
    let theQuery :: Text
theQuery = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KnownSymbol (GetTableName record) => Text
forall model. KnownSymbol (GetTableName model) => Text
tableName @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id IN ?"
    let theParameters :: Only (In [id])
theParameters = In [id] -> Only (In [id])
forall a. a -> Only a
PG.Only ([id] -> In [id]
forall a. a -> In a
PG.In ([record] -> [id]
forall record id. HasField "id" record id => [record] -> [id]
ids [record]
records))
    Query -> Only (In [id]) -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q, Show q) =>
Query -> q -> IO Int64
sqlExec (ByteString -> Query
PG.Query (ByteString -> Query) -> (Text -> ByteString) -> Text -> Query
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$! Text
theQuery) Only (In [id])
theParameters
    () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE deleteRecords #-}

-- | Runs a @DELETE@ query to delete all rows in a table.
--
-- >>> deleteAll @Project
-- DELETE FROM projects
deleteAll :: forall record. (?modelContext :: ModelContext, KnownSymbol (GetTableName record)) => IO ()
deleteAll :: IO ()
deleteAll = do
    let theQuery :: Text
theQuery = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KnownSymbol (GetTableName record) => Text
forall model. KnownSymbol (GetTableName model) => Text
tableName @record
    Query -> () -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q, Show q) =>
Query -> q -> IO Int64
sqlExec (ByteString -> Query
PG.Query (ByteString -> Query) -> (Text -> ByteString) -> Text -> Query
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$! Text
theQuery) ()
    () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE deleteAll #-}

type family Include (name :: GHC.Types.Symbol) model

type family Include' (name :: [GHC.Types.Symbol]) model where
    Include' '[] model = model
    Include' (x:xs) model = Include' xs (Include x model)

instance Default LocalTime where
    def :: LocalTime
def = Day -> TimeOfDay -> LocalTime
LocalTime Day
forall a. Default a => a
def (Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
0 Int
0 Pico
0)

instance Default Day where
    def :: Day
def = Integer -> Day
ModifiedJulianDay Integer
0

instance Default UTCTime where
    def :: UTCTime
def = Day -> DiffTime -> UTCTime
UTCTime Day
forall a. Default a => a
def DiffTime
0

instance Default (PG.Binary ByteString) where
    def :: Binary ByteString
def = ByteString -> Binary ByteString
forall a. a -> Binary a
PG.Binary ByteString
""

instance Newtype.Newtype (PG.Binary payload) where
    type O (PG.Binary payload) = payload
    pack :: O (Binary payload) -> Binary payload
pack = O (Binary payload) -> Binary payload
forall a. a -> Binary a
PG.Binary
    unpack :: Binary payload -> O (Binary payload)
unpack (PG.Binary payload
payload) = payload
O (Binary payload)
payload

class Record model where
    newRecord :: model

-- | Helper type to deal with models where relations are included or that are only partially fetched
-- Examples:
--
-- >>> NormalizeModel (Include "author_id" Post)
-- Post
--
-- >>> NormalizeModel Post
-- Post
type NormalizeModel model = GetModelByTableName (GetTableName model)

-- | Returns the ids for a list of models
--
-- Shorthand for @map (get #id) records@.
--
-- >>> users <- query @User |> fetch
-- >>> ids users
-- [227fbba3-0578-4eb8-807d-b9b692c3644f, 9d7874f2-5343-429b-bcc4-8ee62a5a6895, ...] :: [Id User]
ids :: (HasField "id" record id) => [record] -> [id]
ids :: [record] -> [id]
ids [record]
records = (record -> id) -> [record] -> [id]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "id" r a => r -> a
getField @"id") [record]
records
{-# INLINE ids #-}

-- | Every IHP database record has a magic @meta@ field which keeps a @MetaBag@ inside. This data structure is used e.g. to keep track of the validation errors that happend.
data MetaBag = MetaBag
    { MetaBag -> [(Text, Text)]
annotations            :: ![(Text, Text)] -- ^ Stores validation failures, as a list of (field name, error) pairs. E.g. @annotations = [ ("name", "cannot be empty") ]@
    , MetaBag -> [Text]
touchedFields          :: ![Text] -- ^ Whenever a 'set' is callled on a field, it will be marked as touched. Only touched fields are saved to the database when you call 'updateRecord'
    , MetaBag -> Maybe Dynamic
originalDatabaseRecord :: Maybe Dynamic -- ^ When the record has been fetched from the database, we save the initial database record here. This is used by 'didChange' to check if a field value is different from the initial database value.
    } deriving (Int -> MetaBag -> ShowS
[MetaBag] -> ShowS
MetaBag -> [Char]
(Int -> MetaBag -> ShowS)
-> (MetaBag -> [Char]) -> ([MetaBag] -> ShowS) -> Show MetaBag
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MetaBag] -> ShowS
$cshowList :: [MetaBag] -> ShowS
show :: MetaBag -> [Char]
$cshow :: MetaBag -> [Char]
showsPrec :: Int -> MetaBag -> ShowS
$cshowsPrec :: Int -> MetaBag -> ShowS
Show)

instance Eq MetaBag where
    MetaBag { [(Text, Text)]
annotations :: [(Text, Text)]
$sel:annotations:MetaBag :: MetaBag -> [(Text, Text)]
annotations, [Text]
touchedFields :: [Text]
$sel:touchedFields:MetaBag :: MetaBag -> [Text]
touchedFields } == :: MetaBag -> MetaBag -> Bool
== MetaBag { $sel:annotations:MetaBag :: MetaBag -> [(Text, Text)]
annotations = [(Text, Text)]
annotations', $sel:touchedFields:MetaBag :: MetaBag -> [Text]
touchedFields = [Text]
touchedFields' } = [(Text, Text)]
annotations [(Text, Text)] -> [(Text, Text)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Text, Text)]
annotations' Bool -> Bool -> Bool
&& [Text]
touchedFields [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
touchedFields'

instance Default MetaBag where
    def :: MetaBag
def = MetaBag :: [(Text, Text)] -> [Text] -> Maybe Dynamic -> MetaBag
MetaBag { $sel:annotations:MetaBag :: [(Text, Text)]
annotations = [], $sel:touchedFields:MetaBag :: [Text]
touchedFields = [], $sel:originalDatabaseRecord:MetaBag :: Maybe Dynamic
originalDatabaseRecord = Maybe Dynamic
forall a. Maybe a
Nothing }
    {-# INLINE def #-}

instance SetField "annotations" MetaBag [(Text, Text)] where
    setField :: [(Text, Text)] -> MetaBag -> MetaBag
setField [(Text, Text)]
value MetaBag
meta = MetaBag
meta { $sel:annotations:MetaBag :: [(Text, Text)]
annotations = [(Text, Text)]
value }
    {-# INLINE setField #-}

instance SetField "touchedFields" MetaBag [Text] where
    setField :: [Text] -> MetaBag -> MetaBag
setField [Text]
value MetaBag
meta = MetaBag
meta { $sel:touchedFields:MetaBag :: [Text]
touchedFields = [Text]
value }
    {-# INLINE setField #-}

-- | Returns 'True' if any fields of the record have unsaved changes
--
-- __Example:__ Returns 'False' for freshly fetched records
--
-- >>> let projectId = "227fbba3-0578-4eb8-807d-b9b692c3644f" :: Id Project
-- >>> project <- fetch projectId
-- >>> didChangeRecord project
-- False
--
-- __Example:__ Returns 'True' after setting a field
--
-- >>> let projectId = "227fbba3-0578-4eb8-807d-b9b692c3644f" :: Id Project
-- >>> project <- fetch projectId
-- >>> project |> set #name "New Name" |> didChangeRecord
-- True
didChangeRecord :: (HasField "meta" record MetaBag) => record -> Bool
didChangeRecord :: record -> Bool
didChangeRecord record
record =
    record
record
    record -> (record -> MetaBag) -> MetaBag
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "meta" -> record -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta
    MetaBag -> (MetaBag -> [Text]) -> [Text]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "touchedFields" -> MetaBag -> [Text]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "touchedFields" (Proxy "touchedFields")
Proxy "touchedFields"
#touchedFields
    [Text] -> ([Text] -> Bool) -> Bool
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> [Text] -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty

-- | Returns 'True' if the specific field of the record has unsaved changes
--
-- __Example:__ Returns 'False' for freshly fetched records
--
-- >>> let projectId = "227fbba3-0578-4eb8-807d-b9b692c3644f" :: Id Project
-- >>> project <- fetch projectId
-- >>> didChange #name project
-- False
--
-- __Example:__ Returns 'True' after setting a field
--
-- >>> let projectId = "227fbba3-0578-4eb8-807d-b9b692c3644f" :: Id Project
-- >>> project <- fetch projectId
-- >>> project |> set #name "New Name" |> didChange #name
-- True
--
-- __Example:__ Setting a flash message after updating the profile picture
--
-- > when (user |> didChange #profilePictureUrl) (setSuccessMessage "Your Profile Picture has been updated. It might take a few minutes until it shows up everywhere")
didChange :: forall fieldName fieldValue record. (KnownSymbol fieldName, HasField fieldName record fieldValue, HasField "meta" record MetaBag, Eq fieldValue, Typeable record) => Proxy fieldName -> record -> Bool
didChange :: Proxy fieldName -> record -> Bool
didChange Proxy fieldName
field record
record = Bool
didTouchField Bool -> Bool -> Bool
&& Bool
didChangeField
    where
        didTouchField :: Bool
        didTouchField :: Bool
didTouchField =
            record
record
            record -> (record -> MetaBag) -> MetaBag
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "meta" -> record -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta
            MetaBag -> (MetaBag -> [Text]) -> [Text]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "touchedFields" -> MetaBag -> [Text]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "touchedFields" (Proxy "touchedFields")
Proxy "touchedFields"
#touchedFields
            [Text] -> ([Text] -> Bool) -> Bool
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Element [Text] -> [Text] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes ([Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$! Proxy fieldName -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy fieldName
field)
        
        didChangeField :: Bool
        didChangeField :: Bool
didChangeField = fieldValue
originalFieldValue fieldValue -> fieldValue -> Bool
forall a. Eq a => a -> a -> Bool
/= fieldValue
fieldValue

        fieldValue :: fieldValue
        fieldValue :: fieldValue
fieldValue = record
record record -> (record -> fieldValue) -> fieldValue
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField fieldName r a => r -> a
getField @fieldName
        
        originalFieldValue :: fieldValue
        originalFieldValue :: fieldValue
originalFieldValue =
            record
record
            record -> (record -> MetaBag) -> MetaBag
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "meta" -> record -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta
            MetaBag -> (MetaBag -> Maybe Dynamic) -> Maybe Dynamic
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "originalDatabaseRecord" -> MetaBag -> Maybe Dynamic
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "originalDatabaseRecord" (Proxy "originalDatabaseRecord")
Proxy "originalDatabaseRecord"
#originalDatabaseRecord
            Maybe Dynamic -> (Maybe Dynamic -> Dynamic) -> Dynamic
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Dynamic -> Maybe Dynamic -> Dynamic
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Dynamic
forall a. HasCallStack => [Char] -> a
error [Char]
"didChange called on a record without originalDatabaseRecord")
            Dynamic -> (Dynamic -> Maybe record) -> Maybe record
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Typeable record => Dynamic -> Maybe record
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @record
            Maybe record -> (Maybe record -> record) -> record
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> record -> Maybe record -> record
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> record
forall a. HasCallStack => [Char] -> a
error [Char]
"didChange failed to retrieve originalDatabaseRecord")
            record -> (record -> fieldValue) -> fieldValue
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField fieldName r a => r -> a
getField @fieldName

-- | Represents fields that have a default value in an SQL schema
--
--   The 'Default' constructor represents the default value from the schema,
--   while the 'NonDefault' constructor holds some other value for the field
data FieldWithDefault valueType = Default | NonDefault valueType deriving (FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
(FieldWithDefault valueType -> FieldWithDefault valueType -> Bool)
-> (FieldWithDefault valueType
    -> FieldWithDefault valueType -> Bool)
-> Eq (FieldWithDefault valueType)
forall valueType.
Eq valueType =>
FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
$c/= :: forall valueType.
Eq valueType =>
FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
== :: FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
$c== :: forall valueType.
Eq valueType =>
FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
Eq, Int -> FieldWithDefault valueType -> ShowS
[FieldWithDefault valueType] -> ShowS
FieldWithDefault valueType -> [Char]
(Int -> FieldWithDefault valueType -> ShowS)
-> (FieldWithDefault valueType -> [Char])
-> ([FieldWithDefault valueType] -> ShowS)
-> Show (FieldWithDefault valueType)
forall valueType.
Show valueType =>
Int -> FieldWithDefault valueType -> ShowS
forall valueType.
Show valueType =>
[FieldWithDefault valueType] -> ShowS
forall valueType.
Show valueType =>
FieldWithDefault valueType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FieldWithDefault valueType] -> ShowS
$cshowList :: forall valueType.
Show valueType =>
[FieldWithDefault valueType] -> ShowS
show :: FieldWithDefault valueType -> [Char]
$cshow :: forall valueType.
Show valueType =>
FieldWithDefault valueType -> [Char]
showsPrec :: Int -> FieldWithDefault valueType -> ShowS
$cshowsPrec :: forall valueType.
Show valueType =>
Int -> FieldWithDefault valueType -> ShowS
Show)

instance ToField valueType => ToField (FieldWithDefault valueType) where
  toField :: FieldWithDefault valueType -> Action
toField FieldWithDefault valueType
Default = Builder -> Action
Plain Builder
"DEFAULT"
  toField (NonDefault valueType
a) = valueType -> Action
forall a. ToField a => a -> Action
toField valueType
a

-- | Construct a 'FieldWithDefault'
--
--   Use the default SQL value when the field hasn't been touched since the
--   record was created. This information is stored in the 'touchedFields'
--   attribute of the 'meta' field.
fieldWithDefault
  :: ( KnownSymbol name
     , HasField name model value
     , HasField "meta" model MetaBag
     )
  => Proxy name
  -> model
  -> FieldWithDefault value
fieldWithDefault :: Proxy name -> model -> FieldWithDefault value
fieldWithDefault Proxy name
name model
model
  | [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy name
name) Element [Text] -> [Text] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
`elem` Proxy "touchedFields" -> MetaBag -> [Text]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "touchedFields" (Proxy "touchedFields")
Proxy "touchedFields"
#touchedFields (Proxy "meta" -> model -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta model
model) =
    value -> FieldWithDefault value
forall valueType. valueType -> FieldWithDefault valueType
NonDefault (Proxy name -> model -> value
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy name
name model
model)
  | Bool
otherwise = FieldWithDefault value
forall valueType. FieldWithDefault valueType
Default

-- | Represents fields that may have been updated
--
--   The 'NoUpdate' constructor represents the existing value in the database,
--   while the 'Update' constructor holds some new value for the field
data FieldWithUpdate name value
  = NoUpdate (Proxy name)
  | Update value
  deriving (FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
(FieldWithUpdate name value -> FieldWithUpdate name value -> Bool)
-> (FieldWithUpdate name value
    -> FieldWithUpdate name value -> Bool)
-> Eq (FieldWithUpdate name value)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (name :: k) value.
Eq value =>
FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
/= :: FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
$c/= :: forall k (name :: k) value.
Eq value =>
FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
== :: FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
$c== :: forall k (name :: k) value.
Eq value =>
FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
Eq, Int -> FieldWithUpdate name value -> ShowS
[FieldWithUpdate name value] -> ShowS
FieldWithUpdate name value -> [Char]
(Int -> FieldWithUpdate name value -> ShowS)
-> (FieldWithUpdate name value -> [Char])
-> ([FieldWithUpdate name value] -> ShowS)
-> Show (FieldWithUpdate name value)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall k (name :: k) value.
Show value =>
Int -> FieldWithUpdate name value -> ShowS
forall k (name :: k) value.
Show value =>
[FieldWithUpdate name value] -> ShowS
forall k (name :: k) value.
Show value =>
FieldWithUpdate name value -> [Char]
showList :: [FieldWithUpdate name value] -> ShowS
$cshowList :: forall k (name :: k) value.
Show value =>
[FieldWithUpdate name value] -> ShowS
show :: FieldWithUpdate name value -> [Char]
$cshow :: forall k (name :: k) value.
Show value =>
FieldWithUpdate name value -> [Char]
showsPrec :: Int -> FieldWithUpdate name value -> ShowS
$cshowsPrec :: forall k (name :: k) value.
Show value =>
Int -> FieldWithUpdate name value -> ShowS
Show)

instance (KnownSymbol name, ToField value) => ToField (FieldWithUpdate name value) where
  toField :: FieldWithUpdate name value -> Action
toField (NoUpdate Proxy name
name) =
    Builder -> Action
Plain ([Char] -> Builder
forall a. IsString a => [Char] -> a
ClassyPrelude.fromString ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text -> Text
fieldNameToColumnName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy name
name)
  toField (Update value
a) = value -> Action
forall a. ToField a => a -> Action
toField value
a

-- | Construct a 'FieldWithUpdate'
--
--   Use the current database value when the field hasn't been touched since the
--   record was accessed. This information is stored in the 'touchedFields'
--   attribute of the 'meta' field.
fieldWithUpdate
  :: ( KnownSymbol name
    , HasField name model value
    , HasField "meta" model MetaBag
    )
  => Proxy name
  -> model
  -> FieldWithUpdate name value
fieldWithUpdate :: Proxy name -> model -> FieldWithUpdate name value
fieldWithUpdate Proxy name
name model
model
  | [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy name
name) Element [Text] -> [Text] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
`elem` Proxy "touchedFields" -> MetaBag -> [Text]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "touchedFields" (Proxy "touchedFields")
Proxy "touchedFields"
#touchedFields (Proxy "meta" -> model -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta model
model) =
    value -> FieldWithUpdate name value
forall k (name :: k) value. value -> FieldWithUpdate name value
Update (Proxy name -> model -> value
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy name
name model
model)
  | Bool
otherwise = Proxy name -> FieldWithUpdate name value
forall k (name :: k) value.
Proxy name -> FieldWithUpdate name value
NoUpdate Proxy name
name

instance (ToJSON (PrimaryKey a)) => ToJSON (Id' a) where
  toJSON :: Id' a -> Value
toJSON (Id PrimaryKey a
a) = PrimaryKey a -> Value
forall a. ToJSON a => a -> Value
toJSON PrimaryKey a
a


-- | Thrown by 'fetchOne' when the query result is empty
data RecordNotFoundException
    = RecordNotFoundException { RecordNotFoundException -> (ByteString, [Action])
queryAndParams :: (ByteString, [Action]) }
    deriving (Int -> RecordNotFoundException -> ShowS
[RecordNotFoundException] -> ShowS
RecordNotFoundException -> [Char]
(Int -> RecordNotFoundException -> ShowS)
-> (RecordNotFoundException -> [Char])
-> ([RecordNotFoundException] -> ShowS)
-> Show RecordNotFoundException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RecordNotFoundException] -> ShowS
$cshowList :: [RecordNotFoundException] -> ShowS
show :: RecordNotFoundException -> [Char]
$cshow :: RecordNotFoundException -> [Char]
showsPrec :: Int -> RecordNotFoundException -> ShowS
$cshowsPrec :: Int -> RecordNotFoundException -> ShowS
Show)

instance Exception RecordNotFoundException

instance Default Aeson.Value where
    def :: Value
def = Value
Aeson.Null


-- | This instancs allows us to avoid wrapping lists with PGArray when
-- using sql types such as @INT[]@
instance ToField value => ToField [value] where
    toField :: [value] -> Action
toField [value]
list = PGArray value -> Action
forall a. ToField a => a -> Action
toField ([value] -> PGArray value
forall a. [a] -> PGArray a
PG.PGArray [value]
list)

-- | This instancs allows us to avoid wrapping lists with PGArray when
-- using sql types such as @INT[]@
instance (FromField value, Typeable value) => FromField [value] where
    fromField :: FieldParser [value]
fromField Field
field Maybe ByteString
value = PGArray value -> [value]
forall a. PGArray a -> [a]
PG.fromPGArray (PGArray value -> [value])
-> Conversion (PGArray value) -> Conversion [value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldParser (PGArray value)
forall a. FromField a => FieldParser a
fromField Field
field Maybe ByteString
value)

trackTableRead :: (?modelContext :: ModelContext) => ByteString -> IO ()
trackTableRead :: ByteString -> IO ()
trackTableRead ByteString
tableName = case Proxy "trackTableReadCallback"
-> ModelContext -> Maybe (ByteString -> IO ())
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "trackTableReadCallback" (Proxy "trackTableReadCallback")
Proxy "trackTableReadCallback"
#trackTableReadCallback ?modelContext::ModelContext
ModelContext
?modelContext of
    Just ByteString -> IO ()
callback -> ByteString -> IO ()
callback ByteString
tableName
    Maybe (ByteString -> IO ())
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE trackTableRead #-}

-- | Track all tables in SELECT queries executed within the given IO action.
--
-- You can read the touched tables by this function by accessing the variable @?touchedTables@ inside your given IO action.
--
-- __Example:__
--
-- > withTableReadTracker do
-- >     project <- query @Project |> fetchOne
-- >     user <- query @User |> fetchOne
-- >
-- >     tables <- readIORef ?touchedTables
-- >     -- tables = Set.fromList ["projects", "users"]
-- >
withTableReadTracker :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext, ?touchedTables :: IORef (Set ByteString)) => IO ()) -> IO ()
withTableReadTracker :: ((?modelContext::ModelContext,
  ?touchedTables::IORef (Set ByteString)) =>
 IO ())
-> IO ()
withTableReadTracker (?modelContext::ModelContext,
 ?touchedTables::IORef (Set ByteString)) =>
IO ()
trackedSection = do
    IORef (Set ByteString)
touchedTablesVar <- Set ByteString -> IO (IORef (Set ByteString))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Set ByteString
forall a. Set a
Set.empty
    let trackTableReadCallback :: Maybe (ByteString -> IO ())
trackTableReadCallback = (ByteString -> IO ()) -> Maybe (ByteString -> IO ())
forall a. a -> Maybe a
Just \ByteString
tableName -> IORef (Set ByteString)
-> (Set ByteString -> Set ByteString) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef (Set ByteString)
touchedTablesVar (ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => a -> Set a -> Set a
Set.insert ByteString
tableName)
    let oldModelContext :: ModelContext
oldModelContext = ?modelContext::ModelContext
ModelContext
?modelContext
    let ?modelContext = oldModelContext { trackTableReadCallback }
    let ?touchedTables = touchedTablesVar
    IO ()
(?modelContext::ModelContext,
 ?touchedTables::IORef (Set ByteString)) =>
IO ()
trackedSection