{-# 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
, module IHP.Postgres.TimeParser
) 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.Interval
import IHP.Postgres.Polygon
import IHP.Postgres.Inet ()
import IHP.Postgres.TSVector
import IHP.Postgres.TimeParser
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
data ModelContext = ModelContext
{ ModelContext -> Pool Connection
connectionPool :: Pool.Pool Connection
, ModelContext -> Maybe Connection
transactionConnection :: Maybe Connection
, ModelContext -> Logger
logger :: Logger
, ModelContext -> Maybe (ByteString -> IO ())
trackTableReadCallback :: Maybe (ByteString -> IO ())
, ModelContext -> Maybe RowLevelSecurityContext
rowLevelSecurity :: Maybe RowLevelSecurityContext
}
data RowLevelSecurityContext = RowLevelSecurityContext
{ RowLevelSecurityContext -> Text
rlsAuthenticatedRole :: Text
, RowLevelSecurityContext -> Action
rlsUserId :: PG.Action
}
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 PGInterval where
inputValue :: PGInterval -> Text
inputValue (PGInterval ByteString
pgInterval) = forall a. Show a => a -> Text
tshow ByteString
pgInterval
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
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
type family PrimaryKey (tableName :: Symbol)
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)
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
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
unpackId :: Id' model -> PrimaryKey model
unpackId :: forall (model :: Symbol). Id' model -> PrimaryKey model
unpackId (Id PrimaryKey model
uuid) = PrimaryKey model
uuid
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
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
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 #-}
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
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
class
( KnownSymbol (GetTableName record)
) => Table record where
tableName :: Text
tableName = forall (symbol :: Symbol). KnownSymbol symbol => Text
symbolToText @(GetTableName record)
{-# INLINE tableName #-}
tableNameByteString :: ByteString
tableNameByteString = Text -> ByteString
Text.encodeUtf8 (forall record. Table record => Text
tableName @record)
{-# INLINE tableNameByteString #-}
columnNames :: [ByteString]
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
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
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 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 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
""
instance Default PGInterval where
def :: PGInterval
def = ByteString -> PGInterval
PGInterval ByteString
"00:00:00"
class Record model where
newRecord :: model
type NormalizeModel model = GetModelByTableName (GetTableName model)
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 #-}
data Violation
= TextViolation { Violation -> Text
message :: !Text }
| HtmlViolation { message :: !Text }
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)
data MetaBag = MetaBag
{ MetaBag -> [(Text, Violation)]
annotations :: ![(Text, Violation)]
, MetaBag -> [Text]
touchedFields :: ![Text]
, MetaBag -> Maybe Dynamic
originalDatabaseRecord :: Maybe Dynamic
} 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 #-}
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
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
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
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
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
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
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
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)
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
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)
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)
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 #-}
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
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 = forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter (\Element [record]
record -> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy fieldName
field Element [record]
record forall a. Eq a => a -> a -> Bool
== value
value) [record]
records
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 = forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter (\Element [record]
record -> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy fieldName
field Element [record]
record forall a. Eq a => a -> a -> Bool
== referencedRecord
referenced.id) [record]
records
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 = forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter (\Element [record]
record -> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy fieldName
field Element [record]
record forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just referencedRecord
referenced.id) [record]
records