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

module IHP.ModelSupport
( module IHP.ModelSupport
, module IHP.ModelSupport.Types
, module PostgresqlTypes.Point
, module PostgresqlTypes.Polygon
, module PostgresqlTypes.Inet
, module PostgresqlTypes.Tsvector
, module PostgresqlTypes.Interval
, module IHP.InputValue
) where

import IHP.ModelSupport.Types

import IHP.HaskellSupport
import IHP.NameSupport
import IHP.InputValue
import Prelude
import Data.ByteString (ByteString)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Int (Int64)
import Data.IORef (IORef, newIORef, modifyIORef')
import Control.Exception (bracket, finally, throwIO, Exception, SomeException, try, mask)
import Data.Maybe (fromMaybe, isNothing, isJust)
import Data.String (IsString(..))
import Database.PostgreSQL.Simple.Types (Query(..))
import Data.Default
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 GHC.Records
import GHC.TypeLits
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 Hasql.Pool as HasqlPool
import qualified Hasql.Pool.Config as HasqlPoolConfig
import qualified Hasql.Connection.Settings as HasqlSettings
import qualified Hasql.Session as Hasql
import qualified Hasql.Statement as Hasql
import qualified Hasql.Errors as HasqlErrors
import qualified Hasql.DynamicStatements.Snippet as Snippet
import qualified Hasql.Decoders as Decoders
import qualified Hasql.Encoders as Encoders
import qualified Hasql.Implicits.Encoders
import PostgresqlTypes.Point
import PostgresqlTypes.Polygon
import PostgresqlTypes.Inet
import PostgresqlTypes.Interval
import PostgresqlTypes.Tsvector
import IHP.Log.Types
import qualified IHP.Log as Log
import Data.Dynamic
import IHP.EnvVar
import Data.Scientific
import GHC.Stack
import qualified Hasql.Transaction as Tx
import qualified Hasql.Transaction.Sessions as Tx
import Data.Functor.Contravariant (contramap)
import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Error.Class (catchError)
import IHP.Hasql.FromRow (FromRowHasql(..), HasqlDecodeColumn(..))
import IHP.Hasql.Encoders (ToSnippetParams(..), sqlToSnippet)
import IHP.PGSimpleCompat ()

-- | Provides a mock ModelContext to be used when a database connection is not available
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext Logger
logger = ModelContext
    { hasqlPool :: Pool
hasqlPool = [Char] -> Pool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not connected"
    , transactionRunner :: Maybe TransactionRunner
transactionRunner = Maybe TransactionRunner
forall a. Maybe a
Nothing
    , logger :: Logger
logger = Logger
logger
    , trackTableReadCallback :: Maybe (Text -> IO ())
trackTableReadCallback = Maybe (Text -> IO ())
forall a. Maybe a
Nothing
    , rowLevelSecurity :: Maybe RowLevelSecurityContext
rowLevelSecurity = Maybe RowLevelSecurityContext
forall a. Maybe a
Nothing
    }

createModelContext :: ByteString -> Logger -> IO ModelContext
createModelContext :: ByteString -> Logger -> IO ModelContext
createModelContext ByteString
databaseUrl Logger
logger = do
    -- Create hasql pool for prepared statement-based queries
    -- HASQL_POOL_SIZE: pool size (default: 20). Set to 1 for consistent prepared statement caching.
    -- HASQL_IDLE_TIME: seconds before idle connection is closed (default: 600 = 10 min)
    hasqlPoolSize :: Maybe Int <- ByteString -> IO (Maybe Int)
forall (monad :: * -> *) result.
(MonadIO monad, EnvVarReader result) =>
ByteString -> monad (Maybe result)
envOrNothing ByteString
"HASQL_POOL_SIZE"
    hasqlIdleTime :: Maybe Int <- envOrNothing "HASQL_IDLE_TIME"
    let hasqlPoolSettings =
            [ Settings -> Setting
HasqlPoolConfig.staticConnectionSettings (Text -> Settings
HasqlSettings.connectionString (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
databaseUrl))
            ]
            [Setting] -> [Setting] -> [Setting]
forall a. Semigroup a => a -> a -> a
<> [Setting] -> (Int -> [Setting]) -> Maybe Int -> [Setting]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Int -> Setting
HasqlPoolConfig.size Int
20] (\Int
size -> [Int -> Setting
HasqlPoolConfig.size Int
size]) Maybe Int
hasqlPoolSize
            [Setting] -> [Setting] -> [Setting]
forall a. Semigroup a => a -> a -> a
<> [Setting] -> (Int -> [Setting]) -> Maybe Int -> [Setting]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Int
idle -> [DiffTime -> Setting
HasqlPoolConfig.idlenessTimeout (Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idle)]) Maybe Int
hasqlIdleTime
    let hasqlPoolConfig = [Setting] -> Config
HasqlPoolConfig.settings [Setting]
hasqlPoolSettings
    hasqlPool <- HasqlPool.acquire hasqlPoolConfig

    let trackTableReadCallback = Maybe a
forall a. Maybe a
Nothing
    let transactionRunner = Maybe a
forall a. Maybe a
Nothing
    let rowLevelSecurity = Maybe a
forall a. Maybe a
Nothing
    pure ModelContext { .. }

releaseModelContext :: ModelContext -> IO ()
releaseModelContext :: ModelContext -> IO ()
releaseModelContext ModelContext
modelContext = do
    Pool -> IO ()
HasqlPool.release ModelContext
modelContext.hasqlPool

-- | Bracket-style wrapper around 'createModelContext' that ensures the database
-- pool is released when the callback completes (or throws an exception).
withModelContext :: ByteString -> Logger -> (ModelContext -> IO a) -> IO a
withModelContext :: forall a. ByteString -> Logger -> (ModelContext -> IO a) -> IO a
withModelContext ByteString
databaseUrl Logger
logger =
    IO ModelContext
-> (ModelContext -> IO ()) -> (ModelContext -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (ByteString -> Logger -> IO ModelContext
createModelContext ByteString
databaseUrl Logger
logger) ModelContext -> IO ()
releaseModelContext

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

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

#if !MIN_VERSION_data_default(0,8,0)
instance Default Bool where
    {-# INLINE def #-}
    def = False
#endif

instance Default Point where
    def :: Point
def = Double -> Double -> Point
fromCoordinates Double
0 Double
0

instance Default Polygon where
    def :: Polygon
def = Polygon -> Maybe Polygon -> Polygon
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Polygon
forall a. HasCallStack => [Char] -> a
error [Char]
"Default Polygon: impossible") ([(Double, Double)] -> Maybe Polygon
refineFromPointList [(Double
0,Double
0), (Double
0,Double
0), (Double
0,Double
0)])

instance Default Tsvector where
    def :: Tsvector
def = [(Text, [(Word16, Weight)])] -> Tsvector
normalizeFromLexemeList []

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

-- | 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 = Maybe Dynamic -> Bool
forall a. Maybe a -> Bool
isNothing model
model.meta.originalDatabaseRecord
{-# INLINABLE isNew #-}

-- | 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 = [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 #-}

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 b c a. (b -> c) -> (a -> b) -> a -> c
. Id' model' -> PrimaryKey model'
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) = 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 :: forall entity.
(HasField "id" entity (Id entity),
 Show (PrimaryKey (GetTableName entity))) =>
entity -> Text
recordToInputValue entity
entity =
    entity
entity.id
    Id entity
-> (Id entity -> PrimaryKey (GetTableName entity))
-> PrimaryKey (GetTableName entity)
forall a b. a -> (a -> b) -> b
|> Id entity -> PrimaryKey (GetTableName entity)
forall (model :: Symbol). Id' model -> PrimaryKey model
unpackId
    PrimaryKey (GetTableName entity)
-> (PrimaryKey (GetTableName entity) -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> [Char] -> Text
Text.pack ([Char] -> Text)
-> (PrimaryKey (GetTableName entity) -> [Char])
-> PrimaryKey (GetTableName entity)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimaryKey (GetTableName entity) -> [Char]
forall a. Show a => a -> [Char]
show
{-# INLINE recordToInputValue #-}

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 b c a. (b -> c) -> (a -> b) -> a -> c
. Id' model -> PrimaryKey model
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 (model :: Symbol). PrimaryKey model -> Id' model
packId PrimaryKey model
uuid = PrimaryKey model -> Id' model
forall (model :: Symbol). PrimaryKey model -> Id' model
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

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

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 b c a. (b -> c) -> (a -> b) -> 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 :: (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 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 (model :: Symbol). PrimaryKey model -> Id' model
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 #-}


-- | 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.
--
-- Use 'sqlQuerySingleRow' if you expect only a single row to be returned.
--
sqlQuery :: (?modelContext :: ModelContext, ToSnippetParams q, FromRowHasql r) => Query -> q -> IO [r]
sqlQuery :: forall q r.
(?modelContext::ModelContext, ToSnippetParams q, FromRowHasql r) =>
Query -> q -> IO [r]
sqlQuery Query
theQuery q
theParameters = do
    let pool :: Pool
pool = ?modelContext::ModelContext
ModelContext
?modelContext.hasqlPool
    let snippet :: Snippet
snippet = ByteString -> [Snippet] -> Snippet
sqlToSnippet (Query -> ByteString
fromQuery Query
theQuery) (q -> [Snippet]
forall a. ToSnippetParams a => a -> [Snippet]
toSnippetParams q
theParameters)
    Pool -> Snippet -> Result [r] -> IO [r]
forall a.
(?modelContext::ModelContext) =>
Pool -> Snippet -> Result a -> IO a
sqlQueryHasql Pool
pool Snippet
snippet (Row r -> Result [r]
forall a. Row a -> Result [a]
Decoders.rowList Row r
forall a. FromRowHasql a => Row a
hasqlRowDecoder)
{-# INLINABLE sqlQuery #-}


-- | Runs a raw sql query, that is expected to return a single result row
--
-- Like 'sqlQuery', but useful when you expect only a single row as the result
--
-- __Example:__
--
-- > user <- sqlQuerySingleRow "SELECT id, firstname, lastname FROM users WHERE id = ?" (Only user.id)
--
-- Take a look at "IHP.QueryBuilder" for a typesafe approach on building simple queries.
--
-- *AutoRefresh:* When using 'sqlQuerySingleRow' 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.
--
sqlQuerySingleRow :: (?modelContext :: ModelContext, ToSnippetParams query, FromRowHasql record) => Query -> query -> IO record
sqlQuerySingleRow :: forall query record.
(?modelContext::ModelContext, ToSnippetParams query,
 FromRowHasql record) =>
Query -> query -> IO record
sqlQuerySingleRow Query
theQuery query
theParameters = do
    result <- Query -> query -> IO [record]
forall q r.
(?modelContext::ModelContext, ToSnippetParams q, FromRowHasql r) =>
Query -> q -> IO [r]
sqlQuery Query
theQuery query
theParameters
    case result of
        [] -> [Char] -> IO record
forall a. HasCallStack => [Char] -> a
error ([Char]
"sqlQuerySingleRow: Expected a single row to be returned. Query: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Query -> [Char]
forall a. Show a => a -> [Char]
show Query
theQuery)
        [record
record] -> record -> IO record
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure record
record
        [record]
otherwise -> [Char] -> IO record
forall a. HasCallStack => [Char] -> a
error ([Char]
"sqlQuerySingleRow: Expected a single row to be returned. But got " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([record] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [record]
otherwise) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" rows")
{-# INLINABLE sqlQuerySingleRow #-}

-- | Runs a sql statement (like a CREATE statement)
--
-- __Example:__
--
-- > sqlExec "CREATE TABLE users ()" ()
sqlExec :: (?modelContext :: ModelContext, ToSnippetParams q) => Query -> q -> IO Int64
sqlExec :: forall q.
(?modelContext::ModelContext, ToSnippetParams q) =>
Query -> q -> IO Int64
sqlExec Query
theQuery q
theParameters = do
    let pool :: Pool
pool = ?modelContext::ModelContext
ModelContext
?modelContext.hasqlPool
    let snippet :: Snippet
snippet = ByteString -> [Snippet] -> Snippet
sqlToSnippet (Query -> ByteString
fromQuery Query
theQuery) (q -> [Snippet]
forall a. ToSnippetParams a => a -> [Snippet]
toSnippetParams q
theParameters)
    (?modelContext::ModelContext) => Pool -> Snippet -> IO Int64
Pool -> Snippet -> IO Int64
sqlExecHasqlCount Pool
pool Snippet
snippet
{-# INLINABLE sqlExec #-}

-- | Runs a sql statement (like a CREATE statement), but doesn't return any result
--
-- __Example:__
--
-- > sqlExecDiscardResult "CREATE TABLE users ()" ()
sqlExecDiscardResult :: (?modelContext :: ModelContext, ToSnippetParams q) => Query -> q -> IO ()
sqlExecDiscardResult :: forall q.
(?modelContext::ModelContext, ToSnippetParams q) =>
Query -> q -> IO ()
sqlExecDiscardResult Query
theQuery q
theParameters = do
    _ <- Query -> q -> IO Int64
forall q.
(?modelContext::ModelContext, ToSnippetParams q) =>
Query -> q -> IO Int64
sqlExec Query
theQuery q
theParameters
    pure ()
{-# INLINABLE sqlExecDiscardResult #-}


-- | Prepared statement that sets the RLS role and user id using set_config().
--
-- Uses @set_config(setting, value, is_local)@ which is a regular SQL function
-- that supports parameterized values in the extended query protocol, unlike
-- @SET LOCAL@ which is a utility command that cannot be parameterized.
--
-- The third argument @true@ makes the setting local to the current transaction,
-- equivalent to @SET LOCAL@.
setRLSConfigStatement :: Hasql.Statement (Text, Text) ()
setRLSConfigStatement :: Statement (Text, Text) ()
setRLSConfigStatement = Text
-> Params (Text, Text) -> Result () -> Statement (Text, Text) ()
forall params result.
Text -> Params params -> Result result -> Statement params result
Hasql.preparable
    Text
"SELECT set_config('role', $1, true), set_config('rls.ihp_user_id', $2, true)"
    (((Text, Text) -> Text) -> Params Text -> Params (Text, Text)
forall a' a. (a' -> a) -> Params a -> Params a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text, Text) -> Text
forall a b. (a, b) -> a
fst (NullableOrNot Value Text -> Params Text
forall a. NullableOrNot Value a -> Params a
Encoders.param (Value Text -> NullableOrNot Value Text
forall (encoder :: * -> *) a. encoder a -> NullableOrNot encoder a
Encoders.nonNullable Value Text
Encoders.text))
     Params (Text, Text) -> Params (Text, Text) -> Params (Text, Text)
forall a. Semigroup a => a -> a -> a
<> ((Text, Text) -> Text) -> Params Text -> Params (Text, Text)
forall a' a. (a' -> a) -> Params a -> Params a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (Text, Text) -> Text
forall a b. (a, b) -> b
snd (NullableOrNot Value Text -> Params Text
forall a. NullableOrNot Value a -> Params a
Encoders.param (Value Text -> NullableOrNot Value Text
forall (encoder :: * -> *) a. encoder a -> NullableOrNot encoder a
Encoders.nonNullable Value Text
Encoders.text)))
    (Row () -> Result ()
forall a. Row a -> Result a
Decoders.singleRow (NullableOrNot Value (Maybe Text) -> Row (Maybe Text)
forall a. NullableOrNot Value a -> Row a
Decoders.column (Value Text -> NullableOrNot Value (Maybe Text)
forall (decoder :: * -> *) a.
decoder a -> NullableOrNot decoder (Maybe a)
Decoders.nullable Value Text
Decoders.text) Row (Maybe Text) -> Row (Maybe Text) -> Row (Maybe Text)
forall a b. Row a -> Row b -> Row b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> NullableOrNot Value (Maybe Text) -> Row (Maybe Text)
forall a. NullableOrNot Value a -> Row a
Decoders.column (Value Text -> NullableOrNot Value (Maybe Text)
forall (decoder :: * -> *) a.
decoder a -> NullableOrNot decoder (Maybe a)
Decoders.nullable Value Text
Decoders.text) Row (Maybe Text) -> Row () -> Row ()
forall a b. Row a -> Row b -> Row b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Row ()
forall a. a -> Row a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

-- | Runs a query using the hasql pool with prepared statements
--
-- This function executes a query using hasql's prepared statement mechanism,
-- which provides better performance than postgresql-simple for repeated queries.
--
-- When RLS is enabled, the query is wrapped in a transaction that first sets the
-- role and user id via 'setRLSConfigStatement'.
--
-- __Example:__
--
-- > users <- sqlQueryHasql pool snippet (Decoders.rowList userDecoder)
--
sqlQueryHasql :: (?modelContext :: ModelContext) => HasqlPool.Pool -> Snippet.Snippet -> Decoders.Result a -> IO a
sqlQueryHasql :: forall a.
(?modelContext::ModelContext) =>
Pool -> Snippet -> Result a -> IO a
sqlQueryHasql Pool
pool Snippet
snippet Result a
decoder = do
    let ?context = ?context::ModelContext
?modelContext::ModelContext
ModelContext
?modelContext
    let currentLogLevel :: LogLevel
currentLogLevel = ?modelContext::ModelContext
ModelContext
?modelContext.logger.level
    let statement :: Statement () a
statement = Snippet -> Result a -> Statement () a
forall result. Snippet -> Result result -> Statement () result
Snippet.toStatement Snippet
snippet Result a
decoder
    let session :: Session a
session = case (?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner, ?modelContext::ModelContext
ModelContext
?modelContext.rowLevelSecurity) of
            (Just TransactionRunner
_, Maybe RowLevelSecurityContext
_) ->
                -- In transaction: RLS already configured at BEGIN time
                () -> Statement () a -> Session a
forall params result.
params -> Statement params result -> Session result
Hasql.statement () Statement () a
statement
            (Maybe TransactionRunner
_, Just RowLevelSecurityContext { Text
rlsAuthenticatedRole :: Text
rlsAuthenticatedRole :: RowLevelSecurityContext -> Text
rlsAuthenticatedRole, Text
rlsUserId :: Text
rlsUserId :: RowLevelSecurityContext -> Text
rlsUserId }) ->
                IsolationLevel -> Mode -> Transaction a -> Session a
forall a. IsolationLevel -> Mode -> Transaction a -> Session a
Tx.transaction IsolationLevel
Tx.ReadCommitted Mode
Tx.Read (Transaction a -> Session a) -> Transaction a -> Session a
forall a b. (a -> b) -> a -> b
$ do
                    (Text, Text) -> Statement (Text, Text) () -> Transaction ()
forall a b. a -> Statement a b -> Transaction b
Tx.statement (Text
rlsAuthenticatedRole, Text
rlsUserId) Statement (Text, Text) ()
setRLSConfigStatement
                    () -> Statement () a -> Transaction a
forall a b. a -> Statement a b -> Transaction b
Tx.statement () Statement () a
statement
            (Maybe TransactionRunner, Maybe RowLevelSecurityContext)
_ ->
                () -> Statement () a -> Session a
forall params result.
params -> Statement params result -> Session result
Hasql.statement () Statement () a
statement
    let runQuery :: IO a
runQuery = case ?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner of
            Just (TransactionRunner forall a. Session a -> IO a
runner) -> Session a -> IO a
forall a. Session a -> IO a
runner Session a
session
            Maybe TransactionRunner
Nothing -> do
                result <- Pool -> Session a -> IO (Either UsageError a)
forall a. Pool -> Session a -> IO (Either UsageError a)
HasqlPool.use Pool
pool Session a
session
                case result of
                    Left UsageError
err
                        | UsageError -> Bool
isCachedPlanError UsageError
err -> do
                            Text -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.info (Text
"Resetting hasql connection pool due to stale prepared statements (e.g. after 'make db')" :: Text)
                            Pool -> IO ()
HasqlPool.release Pool
pool
                            retryResult <- Pool -> Session a -> IO (Either UsageError a)
forall a. Pool -> Session a -> IO (Either UsageError a)
HasqlPool.use Pool
pool Session a
session
                            case retryResult of
                                Left UsageError
retryErr -> HasqlError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UsageError -> HasqlError
HasqlError UsageError
retryErr)
                                Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
                        | Bool
otherwise -> HasqlError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UsageError -> HasqlError
HasqlError UsageError
err)
                    Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    if LogLevel
currentLogLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
Debug
        then do
            start <- IO UTCTime
getCurrentTime
            runQuery `finally` do
                end <- getCurrentTime
                let queryTimeInMs = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime
end UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
start) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000 :: Double)
                let sqlText = Statement () a -> Text
forall params result. Statement params result -> Text
Hasql.toSql Statement () a
statement
                Log.debug ("🔍 " <> truncateQuery (cs sqlText) <> " (" <> Text.pack (show queryTimeInMs) <> "ms)")
        else IO a
runQuery
{-# INLINABLE sqlQueryHasql #-}

-- | Like 'sqlQueryHasql' but for statements that don't return results (DELETE, etc.)
--
-- When RLS is enabled, the statement is wrapped in a transaction that first sets the
-- role and user id via 'setRLSConfigStatement'.
sqlExecHasql :: (?modelContext :: ModelContext) => HasqlPool.Pool -> Snippet.Snippet -> IO ()
sqlExecHasql :: (?modelContext::ModelContext) => Pool -> Snippet -> IO ()
sqlExecHasql Pool
pool Snippet
snippet = do
    let ?context = ?context::ModelContext
?modelContext::ModelContext
ModelContext
?modelContext
    let currentLogLevel :: LogLevel
currentLogLevel = ?modelContext::ModelContext
ModelContext
?modelContext.logger.level
    let statement :: Statement () ()
statement = Snippet -> Result () -> Statement () ()
forall result. Snippet -> Result result -> Statement () result
Snippet.toStatement Snippet
snippet Result ()
Decoders.noResult
    let session :: Session ()
session = case (?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner, ?modelContext::ModelContext
ModelContext
?modelContext.rowLevelSecurity) of
            (Just TransactionRunner
_, Maybe RowLevelSecurityContext
_) ->
                () -> Statement () () -> Session ()
forall params result.
params -> Statement params result -> Session result
Hasql.statement () Statement () ()
statement
            (Maybe TransactionRunner
_, Just RowLevelSecurityContext { Text
rlsAuthenticatedRole :: RowLevelSecurityContext -> Text
rlsAuthenticatedRole :: Text
rlsAuthenticatedRole, Text
rlsUserId :: RowLevelSecurityContext -> Text
rlsUserId :: Text
rlsUserId }) ->
                IsolationLevel -> Mode -> Transaction () -> Session ()
forall a. IsolationLevel -> Mode -> Transaction a -> Session a
Tx.transaction IsolationLevel
Tx.ReadCommitted Mode
Tx.Write (Transaction () -> Session ()) -> Transaction () -> Session ()
forall a b. (a -> b) -> a -> b
$ do
                    (Text, Text) -> Statement (Text, Text) () -> Transaction ()
forall a b. a -> Statement a b -> Transaction b
Tx.statement (Text
rlsAuthenticatedRole, Text
rlsUserId) Statement (Text, Text) ()
setRLSConfigStatement
                    () -> Statement () () -> Transaction ()
forall a b. a -> Statement a b -> Transaction b
Tx.statement () Statement () ()
statement
            (Maybe TransactionRunner, Maybe RowLevelSecurityContext)
_ ->
                () -> Statement () () -> Session ()
forall params result.
params -> Statement params result -> Session result
Hasql.statement () Statement () ()
statement
    let runQuery :: IO ()
runQuery = case ?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner of
            Just (TransactionRunner forall a. Session a -> IO a
runner) -> Session () -> IO ()
forall a. Session a -> IO a
runner Session ()
session
            Maybe TransactionRunner
Nothing -> do
                result <- Pool -> Session () -> IO (Either UsageError ())
forall a. Pool -> Session a -> IO (Either UsageError a)
HasqlPool.use Pool
pool Session ()
session
                case result of
                    Left UsageError
err
                        | UsageError -> Bool
isCachedPlanError UsageError
err -> do
                            Text -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.info (Text
"Resetting hasql connection pool due to stale prepared statements (e.g. after 'make db')" :: Text)
                            Pool -> IO ()
HasqlPool.release Pool
pool
                            retryResult <- Pool -> Session () -> IO (Either UsageError ())
forall a. Pool -> Session a -> IO (Either UsageError a)
HasqlPool.use Pool
pool Session ()
session
                            case retryResult of
                                Left UsageError
retryErr -> HasqlError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UsageError -> HasqlError
HasqlError UsageError
retryErr)
                                Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        | Bool
otherwise -> HasqlError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UsageError -> HasqlError
HasqlError UsageError
err)
                    Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    if LogLevel
currentLogLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
Debug
        then do
            start <- IO UTCTime
getCurrentTime
            runQuery `finally` do
                end <- getCurrentTime
                let queryTimeInMs = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime
end UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
start) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000 :: Double)
                let sqlText = Statement () () -> Text
forall params result. Statement params result -> Text
Hasql.toSql Statement () ()
statement
                Log.debug ("💾 " <> truncateQuery (cs sqlText) <> " (" <> Text.pack (show queryTimeInMs) <> "ms)")
        else IO ()
runQuery
{-# INLINABLE sqlExecHasql #-}

-- | Like 'sqlExecHasql' but returns the number of affected rows
--
-- When RLS is enabled, the statement is wrapped in a transaction that first sets the
-- role and user id via 'setRLSConfigStatement'.
sqlExecHasqlCount :: (?modelContext :: ModelContext) => HasqlPool.Pool -> Snippet.Snippet -> IO Int64
sqlExecHasqlCount :: (?modelContext::ModelContext) => Pool -> Snippet -> IO Int64
sqlExecHasqlCount Pool
pool Snippet
snippet = do
    let ?context = ?context::ModelContext
?modelContext::ModelContext
ModelContext
?modelContext
    let currentLogLevel :: LogLevel
currentLogLevel = ?modelContext::ModelContext
ModelContext
?modelContext.logger.level
    let statement :: Statement () Int64
statement = Snippet -> Result Int64 -> Statement () Int64
forall result. Snippet -> Result result -> Statement () result
Snippet.toStatement Snippet
snippet Result Int64
Decoders.rowsAffected
    let session :: Session Int64
session = case (?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner, ?modelContext::ModelContext
ModelContext
?modelContext.rowLevelSecurity) of
            (Just TransactionRunner
_, Maybe RowLevelSecurityContext
_) ->
                () -> Statement () Int64 -> Session Int64
forall params result.
params -> Statement params result -> Session result
Hasql.statement () Statement () Int64
statement
            (Maybe TransactionRunner
_, Just RowLevelSecurityContext { Text
rlsAuthenticatedRole :: RowLevelSecurityContext -> Text
rlsAuthenticatedRole :: Text
rlsAuthenticatedRole, Text
rlsUserId :: RowLevelSecurityContext -> Text
rlsUserId :: Text
rlsUserId }) ->
                IsolationLevel -> Mode -> Transaction Int64 -> Session Int64
forall a. IsolationLevel -> Mode -> Transaction a -> Session a
Tx.transaction IsolationLevel
Tx.ReadCommitted Mode
Tx.Write (Transaction Int64 -> Session Int64)
-> Transaction Int64 -> Session Int64
forall a b. (a -> b) -> a -> b
$ do
                    (Text, Text) -> Statement (Text, Text) () -> Transaction ()
forall a b. a -> Statement a b -> Transaction b
Tx.statement (Text
rlsAuthenticatedRole, Text
rlsUserId) Statement (Text, Text) ()
setRLSConfigStatement
                    () -> Statement () Int64 -> Transaction Int64
forall a b. a -> Statement a b -> Transaction b
Tx.statement () Statement () Int64
statement
            (Maybe TransactionRunner, Maybe RowLevelSecurityContext)
_ ->
                () -> Statement () Int64 -> Session Int64
forall params result.
params -> Statement params result -> Session result
Hasql.statement () Statement () Int64
statement
    let runQuery :: IO Int64
runQuery = case ?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner of
            Just (TransactionRunner forall a. Session a -> IO a
runner) -> Session Int64 -> IO Int64
forall a. Session a -> IO a
runner Session Int64
session
            Maybe TransactionRunner
Nothing -> do
                result <- Pool -> Session Int64 -> IO (Either UsageError Int64)
forall a. Pool -> Session a -> IO (Either UsageError a)
HasqlPool.use Pool
pool Session Int64
session
                case result of
                    Left UsageError
err -> HasqlError -> IO Int64
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UsageError -> HasqlError
HasqlError UsageError
err)
                    Right Int64
count -> Int64 -> IO Int64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
count
    if LogLevel
currentLogLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
Debug
        then do
            start <- IO UTCTime
getCurrentTime
            runQuery `finally` do
                end <- getCurrentTime
                let queryTimeInMs = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime
end UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
start) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000 :: Double)
                let sqlText = Statement () Int64 -> Text
forall params result. Statement params result -> Text
Hasql.toSql Statement () Int64
statement
                Log.debug ("💾 " <> cs sqlText <> " (" <> Text.pack (show queryTimeInMs) <> "ms)")
        else IO Int64
runQuery
{-# INLINABLE sqlExecHasqlCount #-}

-- | Like 'sqlExecHasql' but for raw 'Hasql.Session' values (e.g. multi-statement DDL via 'Hasql.sql')
--
-- Use this instead of 'sqlExecHasql' when you need the simple protocol (no prepared statements),
-- e.g. for multi-statement SQL like trigger creation.
--
-- __Example:__
--
-- > runSessionHasql pool (Hasql.sql "BEGIN; CREATE ...; COMMIT;")
--
runSessionHasql :: (?modelContext :: ModelContext) => HasqlPool.Pool -> Hasql.Session () -> IO ()
runSessionHasql :: (?modelContext::ModelContext) => Pool -> Session () -> IO ()
runSessionHasql Pool
pool Session ()
session = do
    let ?context = ?context::ModelContext
?modelContext::ModelContext
ModelContext
?modelContext
    let currentLogLevel :: LogLevel
currentLogLevel = ?modelContext::ModelContext
ModelContext
?modelContext.logger.level
    let runQuery :: IO ()
runQuery = case ?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner of
            Just (TransactionRunner forall a. Session a -> IO a
runner) -> Session () -> IO ()
forall a. Session a -> IO a
runner Session ()
session
            Maybe TransactionRunner
Nothing -> do
                result <- Pool -> Session () -> IO (Either UsageError ())
forall a. Pool -> Session a -> IO (Either UsageError a)
HasqlPool.use Pool
pool Session ()
session
                case result of
                    Left UsageError
err
                        | UsageError -> Bool
isCachedPlanError UsageError
err -> do
                            Text -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.info (Text
"Resetting hasql connection pool due to stale prepared statements (e.g. after 'make db')" :: Text)
                            Pool -> IO ()
HasqlPool.release Pool
pool
                            retryResult <- Pool -> Session () -> IO (Either UsageError ())
forall a. Pool -> Session a -> IO (Either UsageError a)
HasqlPool.use Pool
pool Session ()
session
                            case retryResult of
                                Left UsageError
retryErr -> HasqlError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UsageError -> HasqlError
HasqlError UsageError
retryErr)
                                Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        | Bool
otherwise -> HasqlError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UsageError -> HasqlError
HasqlError UsageError
err)
                    Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    if LogLevel
currentLogLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
Debug
        then do
            start <- IO UTCTime
getCurrentTime
            runQuery `finally` do
                end <- getCurrentTime
                let queryTimeInMs = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime
end UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
start) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000 :: Double)
                Log.debug ("💾 runSessionHasql (" <> Text.pack (show queryTimeInMs) <> "ms)")
        else IO ()
runQuery
{-# INLINABLE runSessionHasql #-}


-- | Exception type for hasql errors
data HasqlError = HasqlError HasqlPool.UsageError
    deriving (Int -> HasqlError -> ShowS
[HasqlError] -> ShowS
HasqlError -> [Char]
(Int -> HasqlError -> ShowS)
-> (HasqlError -> [Char])
-> ([HasqlError] -> ShowS)
-> Show HasqlError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HasqlError -> ShowS
showsPrec :: Int -> HasqlError -> ShowS
$cshow :: HasqlError -> [Char]
show :: HasqlError -> [Char]
$cshowList :: [HasqlError] -> ShowS
showList :: [HasqlError] -> ShowS
Show)

instance Exception HasqlError

-- | Existential wrapper for sub-session requests in a transaction
data SessionRequest where
    SessionRequest :: Hasql.Session a -> MVar (Either HasqlErrors.SessionError a) -> SessionRequest

-- | Loop that reads sub-session requests from an MVar and executes them
-- on the current transaction's connection. Stops when it receives 'Nothing'.
processRequests :: MVar (Maybe SessionRequest) -> Hasql.Session ()
processRequests :: MVar (Maybe SessionRequest) -> Session ()
processRequests MVar (Maybe SessionRequest)
requestMVar = do
    req <- IO (Maybe SessionRequest) -> Session (Maybe SessionRequest)
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar (Maybe SessionRequest) -> IO (Maybe SessionRequest)
forall a. MVar a -> IO a
takeMVar MVar (Maybe SessionRequest)
requestMVar)
    case req of
        Just (SessionRequest Session a
session MVar (Either SessionError a)
responseVar) -> do
            result <- Session (Either SessionError a)
-> (SessionError -> Session (Either SessionError a))
-> Session (Either SessionError a)
forall a. Session a -> (SessionError -> Session a) -> Session a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (a -> Either SessionError a
forall a b. b -> Either a b
Right (a -> Either SessionError a)
-> Session a -> Session (Either SessionError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session a
session) (Either SessionError a -> Session (Either SessionError a)
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SessionError a -> Session (Either SessionError a))
-> (SessionError -> Either SessionError a)
-> SessionError
-> Session (Either SessionError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionError -> Either SessionError a
forall a b. a -> Either a b
Left)
            liftIO (putMVar responseVar result)
            processRequests requestMVar
        Maybe SessionRequest
Nothing -> () -> Session ()
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Detects errors caused by stale schema after @make db@ recreates the database.
--
-- Matches four categories:
--
-- 1. PostgreSQL \"cached plan must not change result type\" (error code 0A000) —
--    the server rejects a prepared statement whose result columns changed.
--
-- 2. PostgreSQL \"cache lookup failed for type\" (error code XX000) —
--    a prepared statement references a type OID that no longer exists after
--    schema recreation (types get new OIDs).
--
-- 3. Hasql 'MissingTypesSessionError' — custom enum types (e.g. @JOB_STATUS@)
--    get new OIDs after schema recreation, and hasql's type registry can't find them.
--
-- 4. Hasql 'UnexpectedColumnTypeStatementError' — the column's type OID no longer
--    matches the OID cached in the prepared statement / decoder.
isCachedPlanError :: HasqlPool.UsageError -> Bool
isCachedPlanError :: UsageError -> Bool
isCachedPlanError (HasqlPool.SessionUsageError SessionError
sessionError) = SessionError -> Bool
isCachedPlanSessionError SessionError
sessionError
isCachedPlanError UsageError
_ = Bool
False

isCachedPlanSessionError :: HasqlErrors.SessionError -> Bool
isCachedPlanSessionError :: SessionError -> Bool
isCachedPlanSessionError (HasqlErrors.StatementSessionError Int
_ Int
_ Text
_ [Text]
_ Bool
_ (HasqlErrors.ServerStatementError (HasqlErrors.ServerError Text
"0A000" Text
_ Maybe Text
_ Maybe Text
_ Maybe Int
_))) = Bool
True
isCachedPlanSessionError (HasqlErrors.StatementSessionError Int
_ Int
_ Text
_ [Text]
_ Bool
_ (HasqlErrors.ServerStatementError (HasqlErrors.ServerError Text
"XX000" Text
_ Maybe Text
_ Maybe Text
_ Maybe Int
_))) = Bool
True
isCachedPlanSessionError (HasqlErrors.ScriptSessionError Text
_ (HasqlErrors.ServerError Text
"0A000" Text
_ Maybe Text
_ Maybe Text
_ Maybe Int
_)) = Bool
True
isCachedPlanSessionError (HasqlErrors.ScriptSessionError Text
_ (HasqlErrors.ServerError Text
"XX000" Text
_ Maybe Text
_ Maybe Text
_ Maybe Int
_)) = Bool
True
isCachedPlanSessionError (HasqlErrors.MissingTypesSessionError HashSet (Maybe Text, Text)
_) = Bool
True
isCachedPlanSessionError (HasqlErrors.StatementSessionError Int
_ Int
_ Text
_ [Text]
_ Bool
_ (HasqlErrors.UnexpectedColumnTypeStatementError Int
_ Word32
_ Word32
_)) = Bool
True
isCachedPlanSessionError SessionError
_ = Bool
False

-- | 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, ToSnippetParams q, HasqlDecodeColumn value) => Query -> q -> IO value
sqlQueryScalar :: forall q value.
(?modelContext::ModelContext, ToSnippetParams q,
 HasqlDecodeColumn value) =>
Query -> q -> IO value
sqlQueryScalar Query
theQuery q
theParameters = do
    result <- Query -> q -> IO [Only value]
forall q r.
(?modelContext::ModelContext, ToSnippetParams q, FromRowHasql r) =>
Query -> q -> IO [r]
sqlQuery Query
theQuery q
theParameters
    pure case 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 #-}

-- | 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, ToSnippetParams q, HasqlDecodeColumn value) => Query -> q -> IO (Maybe value)
sqlQueryScalarOrNothing :: forall q value.
(?modelContext::ModelContext, ToSnippetParams q,
 HasqlDecodeColumn value) =>
Query -> q -> IO (Maybe value)
sqlQueryScalarOrNothing Query
theQuery q
theParameters = do
    result <- Query -> q -> IO [Only value]
forall q r.
(?modelContext::ModelContext, ToSnippetParams q, FromRowHasql r) =>
Query -> q -> IO [r]
sqlQuery Query
theQuery q
theParameters
    pure case result of
        [] -> Maybe value
forall a. Maybe a
Nothing
        [PG.Only value
result] -> value -> Maybe value
forall a. a -> Maybe a
Just value
result
        [Only value]
_ -> [Char] -> Maybe 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
    | Maybe TransactionRunner -> Bool
forall a. Maybe a -> Bool
isJust ?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner =
        [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
"withTransaction: Nested transactions are not supported. withTransaction was called inside an existing transaction."
    | Bool
otherwise = do
    let pool :: Pool
pool = ?modelContext::ModelContext
ModelContext
?modelContext.hasqlPool
    requestMVar <- IO (MVar (Maybe SessionRequest))
forall a. IO (MVar a)
newEmptyMVar

    let runner :: forall a. Hasql.Session a -> IO a
        runner Session a
session = do
            responseVar <- IO (MVar (Either SessionError a))
forall a. IO (MVar a)
newEmptyMVar
            putMVar requestMVar (Just (SessionRequest session responseVar))
            result <- takeMVar responseVar
            case result of
                Left SessionError
err -> HasqlSessionError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (SessionError -> HasqlSessionError
HasqlSessionError SessionError
err)
                Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

    let ?modelContext = ?modelContext { transactionRunner = Just (TransactionRunner runner) }

    let ?context = ?modelContext
    let transactionSession = do
            Text -> Session ()
Hasql.script Text
"BEGIN"
            case ?modelContext::ModelContext
ModelContext
?modelContext.rowLevelSecurity of
                Just RowLevelSecurityContext { Text
rlsAuthenticatedRole :: RowLevelSecurityContext -> Text
rlsAuthenticatedRole :: Text
rlsAuthenticatedRole, Text
rlsUserId :: RowLevelSecurityContext -> Text
rlsUserId :: Text
rlsUserId } ->
                    (Text, Text) -> Statement (Text, Text) () -> Session ()
forall params result.
params -> Statement params result -> Session result
Hasql.statement (Text
rlsAuthenticatedRole, Text
rlsUserId) Statement (Text, Text) ()
setRLSConfigStatement
                Maybe RowLevelSecurityContext
Nothing -> () -> Session ()
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

            -- Fork the user's block in a separate thread
            blockResultVar <- IO (MVar (Either SomeException a))
-> Session (MVar (Either SomeException a))
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (Either SomeException a))
 -> Session (MVar (Either SomeException a)))
-> IO (MVar (Either SomeException a))
-> Session (MVar (Either SomeException a))
forall a b. (a -> b) -> a -> b
$ do
                resultVar <- IO (MVar (Either SomeException a))
forall a. IO (MVar a)
newEmptyMVar
                _ <- forkIO $ mask \forall a. IO a -> IO a
restore -> do
                    result <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO a -> IO a
forall a. IO a -> IO a
restore IO a
(?modelContext::ModelContext) => IO a
block)
                    putMVar requestMVar Nothing   -- Signal processRequests to stop
                    putMVar resultVar result
                pure resultVar

            processRequests requestMVar

            blockResult <- liftIO (takeMVar blockResultVar)
            case blockResult of
                Left SomeException
exc -> do
                    Session () -> (SessionError -> Session ()) -> Session ()
forall a. Session a -> (SessionError -> Session a) -> Session a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Text -> Session ()
Hasql.script Text
"ROLLBACK") (\SessionError
rollbackErr -> IO () -> Session ()
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$
                        Text -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.warn (Text
"withTransaction: ROLLBACK failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (SessionError -> [Char]
forall a. Show a => a -> [Char]
show SessionError
rollbackErr)))
                    IO a -> Session a
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
exc)
                Right a
a -> do
                    Text -> Session ()
Hasql.script Text
"COMMIT"
                    a -> Session a
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

    result <- HasqlPool.use pool transactionSession
    case result of
        Left UsageError
err -> HasqlError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UsageError -> HasqlError
HasqlError UsageError
err)
        Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
{-# 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
?modelContext
    let ?modelContext = ModelContext
currentModelContext { rowLevelSecurity = Nothing } in IO a
(?modelContext::ModelContext) => IO a
block
{-# INLINABLE withRowLevelSecurityDisabled #-}

commitTransaction :: (?modelContext :: ModelContext) => IO ()
commitTransaction :: (?modelContext::ModelContext) => IO ()
commitTransaction = case ?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner of
    Just (TransactionRunner forall a. Session a -> IO a
runner) -> Session () -> IO ()
forall a. Session a -> IO a
runner (Text -> Session ()
Hasql.script Text
"COMMIT")
    Maybe TransactionRunner
Nothing -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"commitTransaction: Not in a transaction"
{-# INLINABLE commitTransaction #-}

rollbackTransaction :: (?modelContext :: ModelContext) => IO ()
rollbackTransaction :: (?modelContext::ModelContext) => IO ()
rollbackTransaction = case ?modelContext::ModelContext
ModelContext
?modelContext.transactionRunner of
    Just (TransactionRunner forall a. Session a -> IO a
runner) -> Session () -> IO ()
forall a. Session a -> IO a
runner (Text -> Session ()
Hasql.script Text
"ROLLBACK")
    Maybe TransactionRunner
Nothing -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"rollbackTransaction: Not in a transaction"
{-# INLINABLE rollbackTransaction #-}

-- | 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 list of column names for a given model
    --
    -- __Example:__
    --
    -- >>> columnNames @User
    -- ["id", "email", "created_at"]
    --
    columnNames :: [Text]

    -- | Returns the list of column names, that are contained in the primary key for a given model
    --
    -- __Example:__
    --
    -- >>> primaryKeyColumnNames @User
    -- ["id"]
    --
    -- >>> primaryKeyColumnNames @PostTagging
    -- ["post_id", "tag_id"]
    --
    primaryKeyColumnNames :: [Text]


-- | Returns ByteString, that represents the part of an SQL where clause, that matches on a tuple consisting of all the primary keys
-- For table with simple primary keys this simply returns the name of the primary key column, without wrapping in a tuple
-- >>> primaryKeyColumnSelector @PostTag
-- "(post_tags.post_id, post_tags.tag_id)"
-- >>> primaryKeyColumnSelector @Post
-- "post_tags.post_id"
primaryKeyConditionColumnSelector :: forall record. (Table record) => Text
primaryKeyConditionColumnSelector :: forall record. Table record => Text
primaryKeyConditionColumnSelector =
    let
        qualifyColumnName :: Text -> Text
qualifyColumnName Text
col = forall record. Table record => Text
tableName @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
col
    in
    case forall record. Table record => [Text]
primaryKeyColumnNames @record of
            [] -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> (Text -> [Char]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"Impossible happened in primaryKeyConditionColumnSelector. No primary keys found for table " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall record. Table record => Text
tableName @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". At least one primary key is required."
            [Text
s] -> Text -> Text
qualifyColumnName Text
s
            [Text]
conds -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
qualifyColumnName [Text]
conds) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"


truncateQuery :: Text -> Text
truncateQuery :: Text -> Text
truncateQuery Text
query
    | Text -> Int
Text.length Text
query Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2000 = Int -> Text -> Text
Text.take Int
2000 Text
query Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"... (truncated)"
    | Bool
otherwise = Text
query

-- | 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, Table record, Show (PrimaryKey table), HasField "id" record (Id record), GetTableName record ~ table, record ~ GetModelByTableName table, Hasql.Implicits.Encoders.DefaultParamEncoder (Id' table)) => record -> IO ()
deleteRecord :: forall record (table :: Symbol).
(?modelContext::ModelContext, Table record,
 Show (PrimaryKey table), HasField "id" record (Id record),
 GetTableName record ~ table, record ~ GetModelByTableName table,
 DefaultParamEncoder (Id' table)) =>
record -> IO ()
deleteRecord record
record =
    forall record (table :: Symbol).
(?modelContext::ModelContext, Table record,
 Show (PrimaryKey table), GetTableName record ~ table,
 record ~ GetModelByTableName table,
 DefaultParamEncoder (Id' 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, Show (PrimaryKey table), GetTableName record ~ table, record ~ GetModelByTableName table, Hasql.Implicits.Encoders.DefaultParamEncoder (Id' table)) => Id' table -> IO ()
deleteRecordById :: forall record (table :: Symbol).
(?modelContext::ModelContext, Table record,
 Show (PrimaryKey table), GetTableName record ~ table,
 record ~ GetModelByTableName table,
 DefaultParamEncoder (Id' table)) =>
Id' table -> IO ()
deleteRecordById Id' table
id = do
    let pool :: Pool
pool = ?modelContext::ModelContext
ModelContext
?modelContext.hasqlPool
    (?modelContext::ModelContext) => Pool -> Snippet -> IO ()
Pool -> Snippet -> IO ()
sqlExecHasql Pool
pool (Snippet -> IO ()) -> Snippet -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> Snippet
Snippet.sql (Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall record. Table record => Text
tableName @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall record. Table record => Text
primaryKeyConditionColumnSelector @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ")
        Snippet -> Snippet -> Snippet
forall a. Semigroup a => a -> a -> a
<> Id' table -> Snippet
forall param. DefaultParamEncoder param => param -> Snippet
Snippet.param Id' table
id
{-# 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), GetTableName record ~ table, record ~ GetModelByTableName table, Hasql.Implicits.Encoders.DefaultParamEncoder [Id' table]) => [record] -> IO ()
deleteRecords :: forall record (table :: Symbol).
(?modelContext::ModelContext, Show (PrimaryKey table),
 Table record, HasField "id" record (Id' table),
 GetTableName record ~ table, record ~ GetModelByTableName table,
 DefaultParamEncoder [Id' table]) =>
[record] -> IO ()
deleteRecords [record]
records =
    forall record (table :: Symbol).
(?modelContext::ModelContext, Show (PrimaryKey table),
 Table record, GetTableName record ~ table,
 record ~ GetModelByTableName table,
 DefaultParamEncoder [Id' table]) =>
[Id' table] -> IO ()
deleteRecordByIds @record ([record] -> [Id' table]
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, GetTableName record ~ table, record ~ GetModelByTableName table, Hasql.Implicits.Encoders.DefaultParamEncoder [Id' table]) => [Id' table] -> IO ()
deleteRecordByIds :: forall record (table :: Symbol).
(?modelContext::ModelContext, Show (PrimaryKey table),
 Table record, GetTableName record ~ table,
 record ~ GetModelByTableName table,
 DefaultParamEncoder [Id' table]) =>
[Id' table] -> IO ()
deleteRecordByIds [Id' table]
ids = do
    let pool :: Pool
pool = ?modelContext::ModelContext
ModelContext
?modelContext.hasqlPool
    (?modelContext::ModelContext) => Pool -> Snippet -> IO ()
Pool -> Snippet -> IO ()
sqlExecHasql Pool
pool (Snippet -> IO ()) -> Snippet -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> Snippet
Snippet.sql (Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall record. Table record => Text
tableName @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall record. Table record => Text
primaryKeyConditionColumnSelector @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = ANY(")
        Snippet -> Snippet -> Snippet
forall a. Semigroup a => a -> a -> a
<> [Id' table] -> Snippet
forall param. DefaultParamEncoder param => param -> Snippet
Snippet.param [Id' table]
ids
        Snippet -> Snippet -> Snippet
forall a. Semigroup a => a -> a -> a
<> Text -> Snippet
Snippet.sql Text
")"
{-# 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 pool :: Pool
pool = ?modelContext::ModelContext
ModelContext
?modelContext.hasqlPool
    (?modelContext::ModelContext) => Pool -> Snippet -> IO ()
Pool -> Snippet -> IO ()
sqlExecHasql Pool
pool (Snippet -> IO ()) -> Snippet -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Snippet
Snippet.sql (Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall record. Table record => Text
tableName @record)
{-# INLINABLE deleteAll #-}

instance Default NominalDiffTime where
    def :: NominalDiffTime
def = NominalDiffTime
0

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 Day
forall a. Default a => a
def TimeOfDay
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 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 Default Interval where
    def :: Interval
def = Int32 -> Int32 -> Int64 -> Interval
normalizeFromMonthsDaysAndMicroseconds Int32
0 Int32
0 Int64
0

instance Default Inet where
    def :: Inet
def = Word32 -> Word8 -> Inet
normalizeFromV4 Word32
0 Word8
32

class Record model where
    newRecord :: 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 = (record -> id) -> [record] -> [id]
forall a b. (a -> b) -> [a] -> [b]
map (.id) [record]
records
{-# INLINE ids #-}

instance Default MetaBag where
    def :: MetaBag
def = MetaBag { annotations :: [(Text, Violation)]
annotations = [], touchedFields :: [Text]
touchedFields = [], originalDatabaseRecord :: Maybe Dynamic
originalDatabaseRecord = Maybe Dynamic
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 { annotations = value }
    {-# INLINE setField #-}

instance SetField "touchedFields" MetaBag [Text] where
    setField :: [Text] -> MetaBag -> MetaBag
setField [Text]
value MetaBag
meta = MetaBag
meta { touchedFields = 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 = [Text] -> Bool
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 = Proxy fieldName -> record -> Bool
forall (fieldName :: Symbol) fieldValue record.
(KnownSymbol fieldName, HasField fieldName record fieldValue,
 HasField "meta" record MetaBag, Eq fieldValue, Typeable record) =>
Proxy fieldName -> record -> Bool
didTouchField Proxy fieldName
field record
record Bool -> Bool -> Bool
&& Bool
didChangeField
    where
        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 a b. a -> (a -> b) -> b
|> forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @fieldName

        originalFieldValue :: fieldValue
        originalFieldValue :: fieldValue
originalFieldValue =
            record
record.meta.originalDatabaseRecord
            Maybe Dynamic -> (Maybe Dynamic -> Dynamic) -> Dynamic
forall a b. a -> (a -> b) -> b
|> 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 a b. a -> (a -> b) -> b
|> forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @record
            Maybe record -> (Maybe record -> record) -> record
forall a b. a -> (a -> b) -> b
|> 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 a b. a -> (a -> b) -> b
|> forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @fieldName

-- | Returns 'True' if 'set' was called on that field
--
-- __Example:__ Returns 'False' for freshly fetched records
--
-- >>> let projectId = "227fbba3-0578-4eb8-807d-b9b692c3644f" :: Id Project
-- >>> project <- fetch projectId
-- >>> didTouchField #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 project.name |> didTouchField #name
-- True
--
didTouchField :: forall fieldName fieldValue record. (KnownSymbol fieldName, HasField fieldName record fieldValue, HasField "meta" record MetaBag, Eq fieldValue, Typeable record) => Proxy fieldName -> record -> Bool
didTouchField :: forall (fieldName :: Symbol) fieldValue record.
(KnownSymbol fieldName, HasField fieldName record fieldValue,
 HasField "meta" record MetaBag, Eq fieldValue, Typeable record) =>
Proxy fieldName -> record -> Bool
didTouchField Proxy fieldName
field record
record =
    record
record.meta.touchedFields
    [Text] -> ([Text] -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
|> Element [Text] -> [Text] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes (forall (symbol :: Symbol). KnownSymbol symbol => Text
symbolToText @fieldName)

-- | 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
  | [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) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` model
model.meta.touchedFields =
    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

-- | 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
  | [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) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` model
model.meta.touchedFields =
    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

-- | Like 'fieldWithDefault' but produces a hasql 'Snippet' instead of a 'FieldWithDefault'
--
--   When the field hasn't been touched, produces @DEFAULT@. Otherwise encodes the value
--   using hasql's 'DefaultParamEncoder'.
fieldWithDefaultSnippet
  :: ( KnownSymbol name
     , HasField name model value
     , HasField "meta" model MetaBag
     , Hasql.Implicits.Encoders.DefaultParamEncoder value
     )
  => Proxy name
  -> model
  -> Snippet.Snippet
fieldWithDefaultSnippet :: forall (name :: Symbol) model value.
(KnownSymbol name, HasField name model value,
 HasField "meta" model MetaBag, DefaultParamEncoder value) =>
Proxy name -> model -> Snippet
fieldWithDefaultSnippet 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) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` model
model.meta.touchedFields = value -> Snippet
forall param. DefaultParamEncoder param => param -> Snippet
Snippet.param (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 = Text -> Snippet
Snippet.sql Text
"DEFAULT"

-- | Like 'fieldWithUpdate' but produces a hasql 'Snippet' instead of a 'FieldWithUpdate'
--
--   When the field hasn't been touched, produces the column name (keeping the current DB value).
--   Otherwise encodes the new value using hasql's 'DefaultParamEncoder'.
fieldWithUpdateSnippet
  :: ( KnownSymbol name
     , HasField name model value
     , HasField "meta" model MetaBag
     , Hasql.Implicits.Encoders.DefaultParamEncoder value
     )
  => Proxy name
  -> model
  -> Snippet.Snippet
fieldWithUpdateSnippet :: forall (name :: Symbol) model value.
(KnownSymbol name, HasField name model value,
 HasField "meta" model MetaBag, DefaultParamEncoder value) =>
Proxy name -> model -> Snippet
fieldWithUpdateSnippet 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) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` model
model.meta.touchedFields = value -> Snippet
forall param. DefaultParamEncoder param => param -> Snippet
Snippet.param (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 = Text -> Snippet
Snippet.sql (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text) -> Text -> Text
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)

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

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


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

-- | 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) => Text -> IO ()
trackTableRead :: (?modelContext::ModelContext) => Text -> IO ()
trackTableRead Text
tableName = case ?modelContext::ModelContext
ModelContext
?modelContext.trackTableReadCallback of
    Just Text -> IO ()
callback -> Text -> IO ()
callback Text
tableName
    Maybe (Text -> IO ())
Nothing -> () -> IO ()
forall a. a -> IO a
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.Set Text)) => IO ()) -> IO ()
withTableReadTracker :: (?modelContext::ModelContext) =>
((?modelContext::ModelContext, ?touchedTables::IORef (Set Text)) =>
 IO ())
-> IO ()
withTableReadTracker (?modelContext::ModelContext, ?touchedTables::IORef (Set Text)) =>
IO ()
trackedSection = do
    touchedTablesVar <- Set Text -> IO (IORef (Set Text))
forall a. a -> IO (IORef a)
newIORef Set Text
forall a. Set a
Set.empty
    let trackTableReadCallback = (Text -> IO ()) -> Maybe (Text -> IO ())
forall a. a -> Maybe a
Just \Text
tableName -> IORef (Set Text) -> (Set Text -> Set Text) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Set Text)
touchedTablesVar (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
tableName)
    let oldModelContext = ?modelContext::ModelContext
ModelContext
?modelContext
    let ?modelContext = oldModelContext { trackTableReadCallback }
    let ?touchedTables = touchedTablesVar
    trackedSection


-- | Shorthand filter function
--
-- In IHP code bases you often write filter functions such as these:
--
-- > getUserPosts user posts =
-- >     filter (\p -> p.userId == user.id) posts
--
-- This can be written in a shorter way using 'onlyWhere':
--
-- > getUserPosts user posts =
-- >     posts |> onlyWhere #userId user.id
--
-- Because the @userId@ field is an Id, we can use 'onlyWhereReferences' to make it even shorter:
--
-- > getUserPosts user posts =
-- >     posts |> onlyWhereReferences #userId user
--
-- If the Id field is nullable, we need to use 'onlyWhereReferencesMaybe':
--
-- > getUserTasks user tasks =
-- >     tasks |> onlyWhereReferencesMaybe #optionalUserId user
--
onlyWhere :: forall record fieldName value. (KnownSymbol fieldName, HasField fieldName record value, Eq value) => Proxy fieldName -> value -> [record] -> [record]
onlyWhere :: forall record (fieldName :: Symbol) value.
(KnownSymbol fieldName, HasField fieldName record value,
 Eq value) =>
Proxy fieldName -> value -> [record] -> [record]
onlyWhere Proxy fieldName
field value
value [record]
records = (record -> Bool) -> [record] -> [record]
forall a. (a -> Bool) -> [a] -> [a]
filter (\record
record -> Proxy fieldName -> record -> value
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy fieldName
field record
record value -> value -> Bool
forall a. Eq a => a -> a -> Bool
== value
value) [record]
records

-- | Shorthand filter function for Id fields
--
-- In IHP code bases you often write filter functions such as these:
--
-- > getUserPosts user posts =
-- >     filter (\p -> p.userId == user.id) posts
--
-- This can be written in a shorter way using 'onlyWhereReferences':
--
-- > getUserPosts user posts =
-- >     posts |> onlyWhereReferences #userId user
--
-- If the Id field is nullable, we need to use 'onlyWhereReferencesMaybe':
--
-- > getUserTasks user tasks =
-- >     tasks |> onlyWhereReferencesMaybe #optionalUserId user
--
--
-- See 'onlyWhere' for more details.
onlyWhereReferences :: forall record fieldName value referencedRecord. (KnownSymbol fieldName, HasField fieldName record value, Eq value, HasField "id" referencedRecord value) => Proxy fieldName -> referencedRecord -> [record] -> [record]
onlyWhereReferences :: forall record (fieldName :: Symbol) value referencedRecord.
(KnownSymbol fieldName, HasField fieldName record value, Eq value,
 HasField "id" referencedRecord value) =>
Proxy fieldName -> referencedRecord -> [record] -> [record]
onlyWhereReferences Proxy fieldName
field referencedRecord
referenced [record]
records = (record -> Bool) -> [record] -> [record]
forall a. (a -> Bool) -> [a] -> [a]
filter (\record
record -> Proxy fieldName -> record -> value
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy fieldName
field record
record value -> value -> Bool
forall a. Eq a => a -> a -> Bool
== referencedRecord
referenced.id) [record]
records

-- | Shorthand filter function for nullable Id fields
--
-- In IHP code bases you often write filter functions such as these:
--
-- > getUserTasks user tasks =
-- >     filter (\task -> task.optionalUserId == Just user.id) tasks
--
-- This can be written in a shorter way using 'onlyWhereReferencesMaybe':
--
-- > getUserTasks user tasks =
-- >     tasks |> onlyWhereReferencesMaybe #optionalUserId user
--
-- See 'onlyWhere' for more details.
onlyWhereReferencesMaybe :: forall record fieldName value referencedRecord. (KnownSymbol fieldName, HasField fieldName record (Maybe value), Eq value, HasField "id" referencedRecord value) => Proxy fieldName -> referencedRecord -> [record] -> [record]
onlyWhereReferencesMaybe :: forall record (fieldName :: Symbol) value referencedRecord.
(KnownSymbol fieldName, HasField fieldName record (Maybe value),
 Eq value, HasField "id" referencedRecord value) =>
Proxy fieldName -> referencedRecord -> [record] -> [record]
onlyWhereReferencesMaybe Proxy fieldName
field referencedRecord
referenced [record]
records = (record -> Bool) -> [record] -> [record]
forall a. (a -> Bool) -> [a] -> [a]
filter (\record
record -> Proxy fieldName -> record -> Maybe value
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy fieldName
field record
record Maybe value -> Maybe value -> Bool
forall a. Eq a => a -> a -> Bool
== value -> Maybe value
forall a. a -> Maybe a
Just referencedRecord
referenced.id) [record]
records

-- | Returns True when a record has no validation errors attached from a previous validation call
--
-- Example:
--
-- > isValidProject :: Project -> Bool
-- > isValidProject project =
-- >     project
-- >     |> validateField #name isNonEmpty
-- >     |> isValid
--
isValid :: forall record. (HasField "meta" record MetaBag) => record -> Bool
isValid :: forall model. HasField "meta" model MetaBag => model -> Bool
isValid record
record = [(Text, Violation)] -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty record
record.meta.annotations

-- | Copies all the fields (except the 'id' field) into a new record
--
-- Example: Duplicate a database record (except the primary key of course)
--
-- > project <- fetch projectId
-- > duplicatedProject <- createRecord (copyRecord project)
--
copyRecord :: forall record id. (Table record, SetField "id" record id, Default id, SetField "meta" record MetaBag) => record -> record
copyRecord :: forall record id.
(Table record, SetField "id" record id, Default id,
 SetField "meta" record MetaBag) =>
record -> record
copyRecord record
existingRecord =
    let
        fieldsExceptId :: [Text]
fieldsExceptId = (forall record. Table record => [Text]
columnNames @record) [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
field -> Text
field Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"id")

        meta :: MetaBag
        meta :: MetaBag
meta = MetaBag
forall a. Default a => a
def { touchedFields = map IHP.NameSupport.columnNameToFieldName fieldsExceptId }
    in
        record
existingRecord
            record -> (record -> record) -> record
forall a b. a -> (a -> b) -> b
|> Proxy "id" -> id -> record -> record
forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model value) =>
Proxy name -> value -> model -> model
set Proxy "id"
#id id
forall a. Default a => a
def
            record -> (record -> record) -> record
forall a b. a -> (a -> b) -> b
|> Proxy "meta" -> MetaBag -> record -> record
forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model value) =>
Proxy name -> value -> model -> model
set Proxy "meta"
#meta MetaBag
meta

-- | Runs sql queries without logging them
--
-- Example:
--
-- > users <- withoutQueryLogging (sqlQuery "SELECT * FROM users" ())
--
withoutQueryLogging :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext) => result) -> result
withoutQueryLogging :: forall result.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => result) -> result
withoutQueryLogging (?modelContext::ModelContext) => result
callback =
    let
        modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext
        nullLogger :: Logger
nullLogger = ModelContext
modelContext.logger { write = \ByteString -> LogStr
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()}
    in
        let ?modelContext = ModelContext
modelContext { logger = nullLogger }
        in
            result
(?modelContext::ModelContext) => result
callback