{-# 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.Polygon
, module IHP.Postgres.Inet
, module IHP.Postgres.TSVector
) where

import IHP.HaskellSupport
import IHP.NameSupport
import ClassyPrelude hiding (UTCTime, find, ModifiedJulianDay)
import Database.PostgreSQL.Simple (Connection)
import Database.PostgreSQL.Simple.Types (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.UUID
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.Types as PG
import qualified Database.PostgreSQL.Simple.FromRow as PGFR
import qualified Database.PostgreSQL.Simple.ToField as PG
import qualified Database.PostgreSQL.Simple.ToRow as PG
import GHC.Records
import GHC.TypeLits
import GHC.Types
import Data.Proxy
import Data.Data
import Data.Aeson (ToJSON (..), FromJSON (..))
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.Polygon
import IHP.Postgres.Inet ()
import IHP.Postgres.TSVector
import IHP.Log.Types
import qualified IHP.Log as Log
import Data.Dynamic
import Data.Scientific
import GHC.Stack
import qualified Numeric
import qualified Data.Text.Encoding as Text
import qualified Data.ByteString.Builder as Builder

-- | 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 ())
    -- | Is set to a value if row level security was enabled at runtime
    , ModelContext -> Maybe RowLevelSecurityContext
rowLevelSecurity :: Maybe RowLevelSecurityContext
    }

-- | When row level security is enabled at runtime, this keeps track of the current
-- logged in user and the postgresql role to switch to.
data RowLevelSecurityContext = RowLevelSecurityContext
    { RowLevelSecurityContext -> Text
rlsAuthenticatedRole :: Text -- ^ Default is @ihp_authenticated@. This value comes from the @IHP_RLS_AUTHENTICATED_ROLE@  env var.
    , RowLevelSecurityContext -> Action
rlsUserId :: PG.Action -- ^ The user id of the current logged in user
    }

-- | Provides a mock ModelContext to be used when a database connection is not available
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext Logger
logger = ModelContext
    { $sel:connectionPool:ModelContext :: Pool Connection
connectionPool = forall a. HasCallStack => [Char] -> a
error [Char]
"Not connected"
    , $sel:transactionConnection:ModelContext :: Maybe Connection
transactionConnection = forall a. Maybe a
Nothing
    , $sel:logger:ModelContext :: Logger
logger = Logger
logger
    , $sel:trackTableReadCallback:ModelContext :: Maybe (ByteString -> IO ())
trackTableReadCallback = forall a. Maybe a
Nothing
    , $sel:rowLevelSecurity:ModelContext :: Maybe RowLevelSecurityContext
rowLevelSecurity = 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 <- 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 trackTableReadCallback :: Maybe a
trackTableReadCallback = forall a. Maybe a
Nothing
    let transactionConnection :: Maybe a
transactionConnection = forall a. Maybe a
Nothing
    let rowLevelSecurity :: Maybe a
rowLevelSecurity = forall a. Maybe a
Nothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext { Logger
Pool Connection
forall a. Maybe a
rowLevelSecurity :: forall a. Maybe a
transactionConnection :: forall a. Maybe a
trackTableReadCallback :: forall a. Maybe a
connectionPool :: Pool Connection
logger :: Logger
$sel:rowLevelSecurity:ModelContext :: Maybe RowLevelSecurityContext
$sel:trackTableReadCallback:ModelContext :: Maybe (ByteString -> IO ())
$sel:logger:ModelContext :: Logger
$sel:transactionConnection:ModelContext :: Maybe Connection
$sel:connectionPool:ModelContext :: Pool Connection
.. }

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 :: forall model.
(?modelContext::ModelContext, CanCreate model) =>
model -> IO model
createRecord = 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 = forall a. Show a => a -> Text
tshow

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

instance InputValue Double where
    inputValue :: Double -> Text
inputValue Double
double = forall a b. ConvertibleStrings a b => a -> b
cs (forall a. RealFloat a => Maybe Int -> a -> ShowS
Numeric.showFFloat forall a. Maybe a
Nothing Double
double [Char]
"")

instance InputValue Float where
    inputValue :: Float -> Text
inputValue Float
float = forall a b. ConvertibleStrings a b => a -> b
cs (forall a. RealFloat a => Maybe Int -> a -> ShowS
Numeric.showFFloat forall a. Maybe a
Nothing Float
float [Char]
"")

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 = forall a b. ConvertibleStrings a b => a -> b
cs (forall t. ISO8601 t => t -> [Char]
iso8601Show UTCTime
time)

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

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

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

instance InputValue fieldType => InputValue (Maybe fieldType) where
    inputValue :: Maybe fieldType -> Text
inputValue (Just fieldType
value) = 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 forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a. InputValue a => a -> Text
inputValue forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Text
","

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

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

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 forall a. Default a => a
def forall a. Default a => a
def

instance Default Polygon where
    def :: Polygon
def = [Point] -> Polygon
Polygon [forall a. Default a => a
def]

instance Default TSVector where
    def :: TSVector
def = [Lexeme] -> TSVector
TSVector forall a. Default a => a
def

instance Default Scientific where
    def :: Scientific
def = Scientific
0

type FieldName = ByteString

-- | Returns @True@ when the record has not been saved to the database yet. Returns @False@ otherwise.
--
-- __Example:__ Returns @True@ when a record has not been inserted yet.
--
-- >>> let project = newRecord @Project
-- >>> isNew project
-- True
--
-- __Example:__ Returns @False@ after inserting a record.
--
-- >>> project <- createRecord project
-- >>> isNew project
-- False
--
-- __Example:__ Returns @False@ for records which have been fetched from the database.
--
-- >>> book <- query @Book |> fetchOne
-- >>> isNew book
-- False
isNew :: forall model. (HasField "meta" model MetaBag) => model -> Bool
isNew :: forall model. HasField "meta" model MetaBag => model -> Bool
isNew model
model = forall a. Maybe a -> Bool
isNothing model
model.meta.originalDatabaseRecord
{-# INLINABLE 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 :: forall model. KnownSymbol (GetModelName model) => Text
getModelName = forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$! forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (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 its 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 = forall a. InputValue a => a -> Text
inputValue forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (model :: Symbol). Id' model -> PrimaryKey model
unpackId

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

recordToInputValue :: (HasField "id" entity (Id entity), Show (PrimaryKey (GetTableName entity))) => entity -> Text
recordToInputValue :: forall entity.
(HasField "id" entity (Id entity),
 Show (PrimaryKey (GetTableName entity))) =>
entity -> Text
recordToInputValue entity
entity =
    forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"id" entity
entity
    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (model :: Symbol). Id' model -> PrimaryKey model
unpackId
    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> 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 <- forall a. FromField a => FieldParser a
fromField Field
value Maybe ByteString
metaData
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = forall a. ToField a => a -> Action
toField forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (model :: Symbol). Id' model -> PrimaryKey model
unpackId

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

-- | Turns an @UUID@ into a @Id@ type
--
-- > let uuid :: UUID = "5240e79c-97ff-4a5f-8567-84112541aaba"
-- > let userId :: Id User = packId uuid
--
packId :: PrimaryKey model -> Id' model
packId :: forall (table :: Symbol). PrimaryKey table -> Id' table
packId PrimaryKey model
uuid = forall (table :: Symbol). PrimaryKey table -> Id' table
Id PrimaryKey model
uuid

-- | Unwraps a @Id@ value into an @UUID@
--
-- >>> unpackId ("296e5a50-b237-4ee9-83b0-17fb1e6f208f" :: Id User)
-- "296e5a50-b237-4ee9-83b0-17fb1e6f208f" :: UUID
--
unpackId :: Id' model -> PrimaryKey model
unpackId :: forall (model :: Symbol). Id' model -> PrimaryKey model
unpackId (Id PrimaryKey model
uuid) = PrimaryKey model
uuid

-- | Record type for objects of model types labeled with values from different database tables. (e.g. comments labeled with the IDs of the posts they belong to).
data LabeledData a b = LabeledData { forall a b. LabeledData a b -> a
labelValue :: a, forall a b. LabeledData a b -> b
contentValue :: b }
    deriving (Int -> LabeledData a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> LabeledData a b -> ShowS
forall a b. (Show a, Show b) => [LabeledData a b] -> ShowS
forall a b. (Show a, Show b) => LabeledData a b -> [Char]
showList :: [LabeledData a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [LabeledData a b] -> ShowS
show :: LabeledData a b -> [Char]
$cshow :: forall a b. (Show a, Show b) => LabeledData a b -> [Char]
showsPrec :: Int -> LabeledData a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> LabeledData a b -> ShowS
Show)

instance (FromField label, PG.FromRow a) => PGFR.FromRow (LabeledData label a) where
    fromRow :: RowParser (LabeledData label a)
fromRow = forall a b. a -> b -> LabeledData a b
LabeledData forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromField a => RowParser a
PGFR.field forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. FromRow a => RowParser a
PGFR.fromRow

-- | 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 = forall (model :: Symbol) text.
(HasCallStack, ParsePrimaryKey (PrimaryKey model),
 ConvertibleStrings text Text) =>
text -> Id' model
textToId [Char]
uuid
    {-# INLINE fromString #-}

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

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

instance ParsePrimaryKey Text where
    parsePrimaryKey :: Text -> Maybe Text
parsePrimaryKey Text
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 :: (HasCallStack, ParsePrimaryKey (PrimaryKey model), ConvertibleStrings text Text) => text -> Id' model
textToId :: forall (model :: Symbol) text.
(HasCallStack, ParsePrimaryKey (PrimaryKey model),
 ConvertibleStrings text Text) =>
text -> Id' model
textToId text
text = case forall primaryKey.
ParsePrimaryKey primaryKey =>
Text -> Maybe primaryKey
parsePrimaryKey (forall a b. ConvertibleStrings a b => a -> b
cs text
text) of
        Just PrimaryKey model
id -> forall (table :: Symbol). PrimaryKey table -> Id' table
Id PrimaryKey model
id
        Maybe (PrimaryKey model)
Nothing -> forall a. HasCallStack => [Char] -> a
error (forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ Text
"Unable to convert " forall a. Semigroup a => a -> a -> a
<> (forall a b. ConvertibleStrings a b => a -> b
cs text
text :: Text) forall a. Semigroup a => a -> a -> a
<> Text
" to Id value. Is it a valid uuid?")
{-# INLINE textToId #-}

-- | 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, PG.ToRow q) => IO a -> Query -> q -> IO a
measureTimeIfLogging :: forall q a.
(?modelContext::ModelContext, ToRow q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging IO a
queryAction Query
theQuery q
theParameters = do
    let currentLogLevel :: LogLevel
currentLogLevel = ?modelContext::ModelContext
?modelContext.logger.level
    if LogLevel
currentLogLevel forall a. Eq a => a -> a -> Bool
== LogLevel
Debug
        then do
            UTCTime
start <- IO UTCTime
getCurrentTime
            IO a
queryAction forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` do
                UTCTime
end <- IO UTCTime
getCurrentTime
                let theTime :: NominalDiffTime
theTime = UTCTime
end UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
start
                forall parameters.
(?modelContext::ModelContext, ToRow parameters) =>
Query -> parameters -> NominalDiffTime -> IO ()
logQuery Query
theQuery q
theParameters NominalDiffTime
theTime
        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.
--
-- *AutoRefresh:* When using 'sqlQuery' with AutoRefresh, you need to use 'trackTableRead' to let AutoRefresh know that you have accessed a certain table. Otherwise AutoRefresh will not watch table of your custom sql query.
--
sqlQuery :: (?modelContext :: ModelContext, PG.ToRow q, PG.FromRow r) => Query -> q -> IO [r]
sqlQuery :: forall q r.
(?modelContext::ModelContext, ToRow q, FromRow r) =>
Query -> q -> IO [r]
sqlQuery Query
theQuery q
theParameters = do
    forall q a.
(?modelContext::ModelContext, ToRow q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
        (forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> forall parameters a.
ToRow parameters =>
Query -> parameters -> IO a -> IO a
enhanceSqlError Query
theQuery q
theParameters do
            forall params result.
(?modelContext::ModelContext, ToRow params) =>
(Query -> [Action] -> result) -> Query -> params -> result
withRLSParams (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) => Query -> q -> IO Int64
sqlExec :: forall q.
(?modelContext::ModelContext, ToRow q) =>
Query -> q -> IO Int64
sqlExec Query
theQuery q
theParameters = do
    forall q a.
(?modelContext::ModelContext, ToRow q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
        (forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> forall parameters a.
ToRow parameters =>
Query -> parameters -> IO a -> IO a
enhanceSqlError Query
theQuery q
theParameters do
            forall params result.
(?modelContext::ModelContext, ToRow params) =>
(Query -> [Action] -> result) -> Query -> params -> result
withRLSParams (forall q. ToRow q => Connection -> Query -> q -> IO Int64
PG.execute Connection
connection) Query
theQuery q
theParameters
        )
        Query
theQuery
        q
theParameters
{-# INLINABLE sqlExec #-}

-- | Wraps the query with Row level security boilerplate, if a row level security context was provided
--
-- __Example:__
--
-- If a row level security context is given, this will turn a query like the following
--
-- > withRLSParams runQuery "SELECT * FROM projects WHERE id = ?" (Only "..")
--
-- Into the following equivalent:
--
-- > runQuery "SET LOCAL ROLE ?; SET LOCAL rls.ihp_user_id = ?; SELECT * FROM projects WHERE id = ?" ["ihp_authenticated", "<user id>", .."]
--
withRLSParams :: (?modelContext :: ModelContext, PG.ToRow params) => (PG.Query -> [PG.Action] -> result) -> PG.Query -> params -> result
withRLSParams :: forall params result.
(?modelContext::ModelContext, ToRow params) =>
(Query -> [Action] -> result) -> Query -> params -> result
withRLSParams Query -> [Action] -> result
runQuery Query
query params
params = do
    case ?modelContext::ModelContext
?modelContext.rowLevelSecurity of
        Just RowLevelSecurityContext { Text
rlsAuthenticatedRole :: Text
$sel:rlsAuthenticatedRole:RowLevelSecurityContext :: RowLevelSecurityContext -> Text
rlsAuthenticatedRole, Action
rlsUserId :: Action
$sel:rlsUserId:RowLevelSecurityContext :: RowLevelSecurityContext -> Action
rlsUserId } -> do
            let query' :: Query
query' = Query
"SET LOCAL ROLE ?; SET LOCAL rls.ihp_user_id = ?; " forall a. Semigroup a => a -> a -> a
<> Query
query
            let params' :: [Action]
params' = [forall a. ToField a => a -> Action
PG.toField (Text -> Identifier
PG.Identifier Text
rlsAuthenticatedRole), forall a. ToField a => a -> Action
PG.toField Action
rlsUserId] forall a. Semigroup a => a -> a -> a
<> forall a. ToRow a => a -> [Action]
PG.toRow params
params
            Query -> [Action] -> result
runQuery Query
query' [Action]
params'
        Maybe RowLevelSecurityContext
Nothing -> Query -> [Action] -> result
runQuery Query
query (forall a. ToRow a => a -> [Action]
PG.toRow params
params)

withDatabaseConnection :: (?modelContext :: ModelContext) => (Connection -> IO a) -> IO a
withDatabaseConnection :: forall a.
(?modelContext::ModelContext) =>
(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, Maybe RowLevelSecurityContext
rowLevelSecurity :: Maybe RowLevelSecurityContext
$sel:rowLevelSecurity:ModelContext :: ModelContext -> Maybe RowLevelSecurityContext
rowLevelSecurity } = ?modelContext::ModelContext
?modelContext
    in case Maybe Connection
transactionConnection of
        Just Connection
transactionConnection -> Connection -> IO a
block Connection
transactionConnection
        Maybe Connection
Nothing -> 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 <- sqlQueryScalar "SELECT COUNT(*) FROM users"
--
-- Take a look at "IHP.QueryBuilder" for a typesafe approach on building simple queries.
sqlQueryScalar :: (?modelContext :: ModelContext) => (PG.ToRow q, FromField value) => Query -> q -> IO value
sqlQueryScalar :: forall q value.
(?modelContext::ModelContext, ToRow q, FromField value) =>
Query -> q -> IO value
sqlQueryScalar Query
theQuery q
theParameters = do
    [Only value]
result <- forall q a.
(?modelContext::ModelContext, ToRow q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
        (forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> forall parameters a.
ToRow parameters =>
Query -> parameters -> IO a -> IO a
enhanceSqlError Query
theQuery q
theParameters do
            forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
connection Query
theQuery q
theParameters
        )
        Query
theQuery
        q
theParameters
    forall (f :: * -> *) a. Applicative f => a -> f a
pure case [Only value]
result of
        [PG.Only value
result] -> value
result
        [Only value]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"sqlQueryScalar: Expected a scalar result value"
{-# INLINABLE sqlQueryScalar #-}

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

-- | 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 company.id
-- >        |> createRecord
-- >
-- >    company <- company
-- >        |> set #ownerId user.id
-- >        |> updateRecord
withTransaction :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext) => IO a) -> IO a
withTransaction :: forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withTransaction (?modelContext::ModelContext) => IO a
block = forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withTransactionConnection do
    let connection :: Connection
connection = ?modelContext::ModelContext
?modelContext.transactionConnection
            forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
                Just Connection
connection -> Connection
connection
                Maybe Connection
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"withTransaction: transactionConnection not set as expected"
    forall a. Connection -> IO a -> IO a
PG.withTransaction Connection
connection (?modelContext::ModelContext) => IO a
block
{-# INLINABLE withTransaction #-}

-- | Executes the given block with the main database role and temporarly sidesteps the row level security policies.
--
-- This is used e.g. by IHP AutoRefresh to be able to set up it's database triggers. When trying to set up a database
-- trigger from the ihp_authenticated role, it typically fails because it's missing permissions. Using 'withRowLevelSecurityDisabled'
-- we switch to the main role which is allowed to set up database triggers.
--
-- SQL queries run from within the passed block are executed in their own transaction.
--
-- __Example:__
--
-- > -- SQL code executed here might be run from the ihp_authenticated role
-- > withRowLevelSecurityDisabled do
-- >    -- SQL code executed here is run as the main IHP db role
-- >    sqlExec "CREATE OR REPLACE FUNCTION .." ()
--
withRowLevelSecurityDisabled :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext) => IO a) -> IO a
withRowLevelSecurityDisabled :: forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withRowLevelSecurityDisabled (?modelContext::ModelContext) => IO a
block = do
    let currentModelContext :: ModelContext
currentModelContext = ?modelContext::ModelContext
?modelContext
    let ?modelContext = ModelContext
currentModelContext { $sel:rowLevelSecurity:ModelContext :: Maybe RowLevelSecurityContext
rowLevelSecurity = forall a. Maybe a
Nothing } in (?modelContext::ModelContext) => IO a
block
{-# INLINABLE withRowLevelSecurityDisabled #-}

-- | Returns the postgres connection when called within a 'withTransaction' block
--
-- Throws an error if called from outside a 'withTransaction'
transactionConnectionOrError :: (?modelContext :: ModelContext) => Connection
transactionConnectionOrError :: (?modelContext::ModelContext) => Connection
transactionConnectionOrError = ?modelContext::ModelContext
?modelContext.transactionConnection
            forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
                Just Connection
connection -> Connection
connection
                Maybe Connection
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"getTransactionConnectionOrError: Not in a transaction state"

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

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

withTransactionConnection :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext) => IO a) -> IO a
withTransactionConnection :: forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withTransactionConnection (?modelContext::ModelContext) => IO a
block = do
    let ModelContext { Pool Connection
connectionPool :: Pool Connection
$sel:connectionPool:ModelContext :: ModelContext -> Pool Connection
connectionPool } = ?modelContext::ModelContext
?modelContext
    forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource Pool Connection
connectionPool \Connection
connection -> do
        let modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
?modelContext { $sel:transactionConnection:ModelContext :: Maybe Connection
transactionConnection = forall a. a -> Maybe a
Just Connection
connection }
        let ?modelContext = ModelContext
modelContext in (?modelContext::ModelContext) => IO a
block
{-# INLINABLE withTransactionConnection #-}

-- | Access meta data for a database table
class
    ( KnownSymbol (GetTableName record)
    ) => Table record where
    -- | Returns the table name of a given model.
    --
    -- __Example:__
    --
    -- >>> tableName @User
    -- "users"
    --

    tableName :: Text
    tableName = forall (symbol :: Symbol). KnownSymbol symbol => Text
symbolToText @(GetTableName record)
    {-# INLINE tableName #-}

    -- | Returns the table name of a given model as a bytestring.
    --
    -- __Example:__
    --
    -- >>> tableNameByteString @User
    -- "users"
    --
    tableNameByteString :: ByteString
    tableNameByteString = Text -> ByteString
Text.encodeUtf8 (forall record. Table record => Text
tableName @record)
    {-# INLINE tableNameByteString #-}

    -- | Returns the list of column names for a given model
    --
    -- __Example:__
    --
    -- >>> columnNames @User
    -- ["id", "email", "created_at"]
    --
    columnNames :: [ByteString]

    -- | Returns WHERE conditions to match an entity by it's primary key
    --
    -- For tables with a simple primary key this returns a tuple with the id:
    --
    -- >>> primaryKeyCondition project
    -- [("id", "d619f3cf-f355-4614-8a4c-e9ea4f301e39")]
    --
    -- If the table has a composite primary key, this returns multiple elements:
    --
    -- >>> primaryKeyCondition postTag
    -- [("post_id", "0ace9270-568f-4188-b237-3789aa520588"), ("tag_id", "0b58fdf5-4bbb-4e57-a5b7-aa1c57148e1c")]
    --
    primaryKeyCondition :: record -> [(Text, PG.Action)]
    default primaryKeyCondition :: forall id. (HasField "id" record id, ToField id) => record -> [(Text, PG.Action)]
    primaryKeyCondition record
record = [(Text
"id", forall a. ToField a => a -> Action
toField record
record.id)]

logQuery :: (?modelContext :: ModelContext, PG.ToRow parameters) => Query -> parameters -> NominalDiffTime -> IO ()
logQuery :: forall parameters.
(?modelContext::ModelContext, ToRow parameters) =>
Query -> parameters -> NominalDiffTime -> IO ()
logQuery Query
query parameters
parameters NominalDiffTime
time = do
        let ?context = ?modelContext::ModelContext
?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 forall a. Num a => a -> a -> a
* NominalDiffTime
1000) forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Real a => a -> Rational
toRational forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Fractional a => Rational -> a
fromRational @Double
        let formatRLSInfo :: a -> a
formatRLSInfo a
userId = a
" { ihp_user_id = " forall a. Semigroup a => a -> a -> a
<> a
userId forall a. Semigroup a => a -> a -> a
<> a
" }"
        let rlsInfo :: Text
rlsInfo = case ?context::ModelContext
?context.rowLevelSecurity of
                Just RowLevelSecurityContext { $sel:rlsUserId:RowLevelSecurityContext :: RowLevelSecurityContext -> Action
rlsUserId = PG.Plain Builder
rlsUserId } -> forall {a}. (Semigroup a, IsString a) => a -> a
formatRLSInfo (forall a b. ConvertibleStrings a b => a -> b
cs (Builder -> ByteString
Builder.toLazyByteString Builder
rlsUserId))
                Just RowLevelSecurityContext { $sel:rlsUserId:RowLevelSecurityContext :: RowLevelSecurityContext -> Action
rlsUserId = Action
rlsUserId } -> forall {a}. (Semigroup a, IsString a) => a -> a
formatRLSInfo (forall a. Show a => a -> Text
tshow Action
rlsUserId)
                Maybe RowLevelSecurityContext
Nothing -> Text
""
        let
            -- We don't use the normal 'show' here as it adds lots of noise like 'Escape' or 'Plain' to the output
            showAction :: Action -> b
showAction (PG.Plain Builder
builder) = forall a b. ConvertibleStrings a b => a -> b
cs (Builder -> ByteString
Builder.toLazyByteString Builder
builder)
            showAction (PG.Escape ByteString
byteString) = forall a b. ConvertibleStrings a b => a -> b
cs ByteString
byteString
            showAction (PG.EscapeByteA ByteString
byteString) = forall a b. ConvertibleStrings a b => a -> b
cs ByteString
byteString
            showAction (PG.EscapeIdentifier ByteString
byteString) = forall a b. ConvertibleStrings a b => a -> b
cs ByteString
byteString
            showAction (PG.Many [Action]
actions) = forall mono m.
(MonoFoldable mono, Monoid m) =>
(Element mono -> m) -> mono -> m
concatMap Action -> b
showAction [Action]
actions
        forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.debug (Text
"Query (" forall a. Semigroup a => a -> a -> a
<>  forall a. Show a => a -> Text
tshow Double
queryTimeInMs forall a. Semigroup a => a -> a -> a
<> Text
"ms): " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Query
query forall a. Semigroup a => a -> a -> a
<> Text
" [" forall a. Semigroup a => a -> a -> a
<> (forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall {b}.
(ConvertibleStrings ByteString b, ConvertibleStrings ByteString b,
 Monoid b) =>
Action -> b
showAction forall a b. (a -> b) -> a -> b
$ forall a. ToRow a => a -> [Action]
PG.toRow parameters
parameters) forall a. Semigroup a => a -> a -> a
<> Text
"]" forall a. Semigroup a => a -> a -> a
<> Text
rlsInfo)
{-# 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 record table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, HasField "id" record (Id' table), ToField (PrimaryKey table), GetModelByTableName table ~ record, Show (PrimaryKey table), ToField (PrimaryKey table)) => record -> IO ()
deleteRecord :: forall record (table :: Symbol).
(?modelContext::ModelContext, Show (PrimaryKey table),
 Table record, HasField "id" record (Id' table),
 ToField (PrimaryKey table), GetModelByTableName table ~ record,
 Show (PrimaryKey table), ToField (PrimaryKey table)) =>
record -> IO ()
deleteRecord record
record =
    forall record (table :: Symbol).
(?modelContext::ModelContext, Table record,
 ToField (PrimaryKey table), Show (PrimaryKey table),
 record ~ GetModelByTableName table) =>
Id' table -> IO ()
deleteRecordById @record record
record.id
{-# INLINABLE deleteRecord #-}

-- | Like 'deleteRecord' but using an Id
--
-- >>> let project :: Id Project = ...
-- >>> delete projectId
-- DELETE FROM projects WHERE id = '..'
--
deleteRecordById :: forall record table. (?modelContext :: ModelContext, Table record, ToField (PrimaryKey table), Show (PrimaryKey table), record ~ GetModelByTableName table) => Id' table -> IO ()
deleteRecordById :: forall record (table :: Symbol).
(?modelContext::ModelContext, Table record,
 ToField (PrimaryKey table), Show (PrimaryKey table),
 record ~ GetModelByTableName table) =>
Id' table -> IO ()
deleteRecordById Id' table
id = do
    let theQuery :: Text
theQuery = Text
"DELETE FROM " forall a. Semigroup a => a -> a -> a
<> forall record. Table record => Text
tableName @record forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = ?"
    let theParameters :: Only (Id' table)
theParameters = forall a. a -> Only a
PG.Only Id' table
id
    forall q.
(?modelContext::ModelContext, ToRow q) =>
Query -> q -> IO Int64
sqlExec (ByteString -> Query
PG.Query forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$! Text
theQuery) Only (Id' table)
theParameters
    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 table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, HasField "id" record (Id' table), ToField (PrimaryKey table), record ~ GetModelByTableName table) => [record] -> IO ()
deleteRecords :: forall record (table :: Symbol).
(?modelContext::ModelContext, Show (PrimaryKey table),
 Table record, HasField "id" record (Id' table),
 ToField (PrimaryKey table), record ~ GetModelByTableName table) =>
[record] -> IO ()
deleteRecords [record]
records =
    forall record (table :: Symbol).
(?modelContext::ModelContext, Show (PrimaryKey table),
 Table record, ToField (PrimaryKey table),
 record ~ GetModelByTableName table) =>
[Id' table] -> IO ()
deleteRecordByIds @record (forall record id. HasField "id" record id => [record] -> [id]
ids [record]
records)
{-# INLINABLE deleteRecords #-}

-- | Like 'deleteRecordById' but for a list of Ids.
--
-- >>> let projectIds :: [ Id Project ] = ...
-- >>> delete projectIds
-- DELETE FROM projects WHERE id IN ('..')
--
deleteRecordByIds :: forall record table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, ToField (PrimaryKey table), record ~ GetModelByTableName table) => [Id' table] -> IO ()
deleteRecordByIds :: forall record (table :: Symbol).
(?modelContext::ModelContext, Show (PrimaryKey table),
 Table record, ToField (PrimaryKey table),
 record ~ GetModelByTableName table) =>
[Id' table] -> IO ()
deleteRecordByIds [Id' table]
ids = do
    let theQuery :: Text
theQuery = Text
"DELETE FROM " forall a. Semigroup a => a -> a -> a
<> forall record. Table record => Text
tableName @record forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id IN ?"
    let theParameters :: Only (In [Id' table])
theParameters = (forall a. a -> Only a
PG.Only (forall a. a -> In a
PG.In [Id' table]
ids))
    forall q.
(?modelContext::ModelContext, ToRow q) =>
Query -> q -> IO Int64
sqlExec (ByteString -> Query
PG.Query forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$! Text
theQuery) Only (In [Id' table])
theParameters
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE deleteRecordByIds #-}

-- | Runs a @DELETE@ query to delete all rows in a table.
--
-- >>> deleteAll @Project
-- DELETE FROM projects
deleteAll :: forall record. (?modelContext :: ModelContext, Table record) => IO ()
deleteAll :: forall record. (?modelContext::ModelContext, Table record) => IO ()
deleteAll = do
    let theQuery :: Text
theQuery = Text
"DELETE FROM " forall a. Semigroup a => a -> a -> a
<> forall record. Table record => Text
tableName @record
    forall q.
(?modelContext::ModelContext, ToRow q) =>
Query -> q -> IO Int64
sqlExec (ByteString -> Query
PG.Query forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$! Text
theQuery) ()
    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 TimeOfDay where
    def :: TimeOfDay
def = Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
0 Int
0 Pico
0

instance Default LocalTime where
    def :: LocalTime
def = Day -> TimeOfDay -> LocalTime
LocalTime forall a. Default a => a
def forall a. Default a => a
def

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

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

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

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 (.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 :: forall record id. HasField "id" record id => [record] -> [id]
ids [record]
records = 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
getField @"id") [record]
records
{-# INLINE ids #-}

-- | The error message of a validator can be either a plain text value or a HTML formatted value
data Violation
    = TextViolation { Violation -> Text
message :: !Text } -- ^ Plain text validation error, like "cannot be empty"
    | HtmlViolation { message :: !Text } -- ^ HTML formatted, already pre-escaped validation error, like "Invalid, please <a href="http://example.com">check the documentation</a>"
    deriving (Violation -> Violation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Violation -> Violation -> Bool
$c/= :: Violation -> Violation -> Bool
== :: Violation -> Violation -> Bool
$c== :: Violation -> Violation -> Bool
Eq, Int -> Violation -> ShowS
[Violation] -> ShowS
Violation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Violation] -> ShowS
$cshowList :: [Violation] -> ShowS
show :: Violation -> [Char]
$cshow :: Violation -> [Char]
showsPrec :: Int -> Violation -> ShowS
$cshowsPrec :: Int -> Violation -> ShowS
Show)

-- | 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, Violation)]
annotations            :: ![(Text, Violation)] -- ^ Stores validation failures, as a list of (field name, error) pairs. E.g. @annotations = [ ("name", TextViolation "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]
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, Violation)]
annotations :: [(Text, Violation)]
$sel:annotations:MetaBag :: MetaBag -> [(Text, Violation)]
annotations, [Text]
touchedFields :: [Text]
$sel:touchedFields:MetaBag :: MetaBag -> [Text]
touchedFields } == :: MetaBag -> MetaBag -> Bool
== MetaBag { $sel:annotations:MetaBag :: MetaBag -> [(Text, Violation)]
annotations = [(Text, Violation)]
annotations', $sel:touchedFields:MetaBag :: MetaBag -> [Text]
touchedFields = [Text]
touchedFields' } = [(Text, Violation)]
annotations forall a. Eq a => a -> a -> Bool
== [(Text, Violation)]
annotations' Bool -> Bool -> Bool
&& [Text]
touchedFields forall a. Eq a => a -> a -> Bool
== [Text]
touchedFields'

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

instance SetField "annotations" MetaBag [(Text, Violation)] where
    setField :: [(Text, Violation)] -> MetaBag -> MetaBag
setField [(Text, Violation)]
value MetaBag
meta = MetaBag
meta { $sel:annotations:MetaBag :: [(Text, Violation)]
annotations = [(Text, Violation)]
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 :: forall model. HasField "meta" model MetaBag => model -> Bool
didChangeRecord record
record = forall value. IsEmpty value => value -> Bool
isEmpty record
record.meta.touchedFields

-- | 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 :: forall (fieldName :: Symbol) fieldValue record.
(KnownSymbol fieldName, HasField fieldName record fieldValue,
 HasField "meta" record MetaBag, Eq fieldValue, Typeable record) =>
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.meta.touchedFields
            forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes (forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$! forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy fieldName
field)

        didChangeField :: Bool
        didChangeField :: Bool
didChangeField = fieldValue
originalFieldValue forall a. Eq a => a -> a -> Bool
/= fieldValue
fieldValue

        fieldValue :: fieldValue
        fieldValue :: fieldValue
fieldValue = record
record forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall {k} (x :: k) r a. HasField x r a => r -> a
getField @fieldName

        originalFieldValue :: fieldValue
        originalFieldValue :: fieldValue
originalFieldValue =
            record
record.meta.originalDatabaseRecord
            forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"didChange called on a record without originalDatabaseRecord")
            forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @record
            forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"didChange failed to retrieve originalDatabaseRecord")
            forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall {k} (x :: k) r a. HasField x 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
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
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) = 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 :: forall (name :: Symbol) model value.
(KnownSymbol name, HasField name model value,
 HasField "meta" model MetaBag) =>
Proxy name -> model -> FieldWithDefault value
fieldWithDefault Proxy name
name model
model
  | forall a b. ConvertibleStrings a b => a -> b
cs (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy name
name) forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
`elem` model
model.meta.touchedFields =
    forall valueType. valueType -> FieldWithDefault valueType
NonDefault (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy name
name model
model)
  | Bool
otherwise = 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
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
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 (forall a. IsString a => [Char] -> a
ClassyPrelude.fromString forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ Text -> Text
fieldNameToColumnName forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy name
name)
  toField (Update value
a) = 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 :: forall (name :: Symbol) model value.
(KnownSymbol name, HasField name model value,
 HasField "meta" model MetaBag) =>
Proxy name -> model -> FieldWithUpdate name value
fieldWithUpdate Proxy name
name model
model
  | forall a b. ConvertibleStrings a b => a -> b
cs (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy name
name) forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
`elem` model
model.meta.touchedFields =
    forall {k} (name :: k) value. value -> FieldWithUpdate name value
Update (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy name
name model
model)
  | Bool
otherwise = 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) = forall a. ToJSON a => a -> Value
toJSON PrimaryKey a
a

instance (FromJSON (PrimaryKey a)) => FromJSON (Id' a) where
    parseJSON :: Value -> Parser (Id' a)
parseJSON Value
value = forall (table :: Symbol). PrimaryKey table -> Id' table
Id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
value

-- | 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]
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

-- | Whenever calls to 'Database.PostgreSQL.Simple.query' or 'Database.PostgreSQL.Simple.execute'
-- raise an 'Database.PostgreSQL.Simple.SqlError' exception, we wrap that exception in this data structure.
-- This allows us to show the actual database query that has triggered the error.
data EnhancedSqlError
    = EnhancedSqlError
    { EnhancedSqlError -> Query
sqlErrorQuery :: Query
    , EnhancedSqlError -> [Action]
sqlErrorQueryParams :: [Action]
    , EnhancedSqlError -> SqlError
sqlError :: PG.SqlError
    } deriving (Int -> EnhancedSqlError -> ShowS
[EnhancedSqlError] -> ShowS
EnhancedSqlError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EnhancedSqlError] -> ShowS
$cshowList :: [EnhancedSqlError] -> ShowS
show :: EnhancedSqlError -> [Char]
$cshow :: EnhancedSqlError -> [Char]
showsPrec :: Int -> EnhancedSqlError -> ShowS
$cshowsPrec :: Int -> EnhancedSqlError -> ShowS
Show)

-- | Catches 'SqlError' and wraps them in 'EnhancedSqlError'
enhanceSqlError :: PG.ToRow parameters => Query -> parameters -> IO a -> IO a
enhanceSqlError :: forall parameters a.
ToRow parameters =>
Query -> parameters -> IO a -> IO a
enhanceSqlError Query
sqlErrorQuery parameters
sqlErrorQueryParams IO a
block = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch IO a
block (\SqlError
sqlError -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO EnhancedSqlError { Query
sqlErrorQuery :: Query
$sel:sqlErrorQuery:EnhancedSqlError :: Query
sqlErrorQuery, $sel:sqlErrorQueryParams:EnhancedSqlError :: [Action]
sqlErrorQueryParams = forall a. ToRow a => a -> [Action]
PG.toRow parameters
sqlErrorQueryParams, SqlError
sqlError :: SqlError
$sel:sqlError:EnhancedSqlError :: SqlError
sqlError })
{-# INLINE enhanceSqlError #-}

instance Exception EnhancedSqlError

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 = forall a. ToField a => a -> Action
toField (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 = forall a. PGArray a -> [a]
PG.fromPGArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. FromField a => FieldParser a
fromField Field
field Maybe ByteString
value)

-- | Useful to manually mark a table read when doing a custom sql query inside AutoRefresh or 'withTableReadTracker'.
--
-- When using 'fetch' on a query builder, this function is automatically called. That's why you only need to call
-- it yourself when using 'sqlQuery' to run a custom query.
--
-- __Example:__
--
-- > action MyAction = autoRefresh do
-- >     users <- sqlQuery "SELECT * FROM users WHERE .."
-- >     trackTableRead "users"
-- >
-- >     render MyView { .. }
--
--
trackTableRead :: (?modelContext :: ModelContext) => ByteString -> IO ()
trackTableRead :: (?modelContext::ModelContext) => ByteString -> IO ()
trackTableRead ByteString
tableName = case ?modelContext::ModelContext
?modelContext.trackTableReadCallback of
    Just ByteString -> IO ()
callback -> ByteString -> IO ()
callback ByteString
tableName
    Maybe (ByteString -> IO ())
Nothing -> 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) =>
((?modelContext::ModelContext,
  ?touchedTables::IORef (Set ByteString)) =>
 IO ())
-> IO ()
withTableReadTracker (?modelContext::ModelContext,
 ?touchedTables::IORef (Set ByteString)) =>
IO ()
trackedSection = do
    IORef (Set ByteString)
touchedTablesVar <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Set a
Set.empty
    let trackTableReadCallback :: Maybe (ByteString -> IO ())
trackTableReadCallback = forall a. a -> Maybe a
Just \ByteString
tableName -> forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef (Set ByteString)
touchedTablesVar (forall a. Ord a => a -> Set a -> Set a
Set.insert ByteString
tableName)
    let oldModelContext :: ModelContext
oldModelContext = ?modelContext::ModelContext
?modelContext
    let ?modelContext = ModelContext
oldModelContext { Maybe (ByteString -> IO ())
trackTableReadCallback :: Maybe (ByteString -> IO ())
$sel:trackTableReadCallback:ModelContext :: Maybe (ByteString -> IO ())
trackTableReadCallback }
    let ?touchedTables = IORef (Set ByteString)
touchedTablesVar
    (?modelContext::ModelContext,
 ?touchedTables::IORef (Set ByteString)) =>
IO ()
trackedSection