{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, UndecidableInstances, FlexibleInstances, IncoherentInstances, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, TypeInType, ConstraintKinds, TypeOperators, GADTs, GeneralizedNewtypeDeriving #-}
module IHP.ModelSupport
( module IHP.ModelSupport
, module IHP.Postgres.Point
, module IHP.Postgres.Inet
) where
import IHP.HaskellSupport
import IHP.NameSupport
import qualified Prelude
import ClassyPrelude hiding (UTCTime, find, ModifiedJulianDay)
import qualified ClassyPrelude
import Database.PostgreSQL.Simple (Connection)
import qualified Text.Inflections
import Database.PostgreSQL.Simple.Types (Query (Query))
import Database.PostgreSQL.Simple.FromField hiding (Field, name)
import Database.PostgreSQL.Simple.ToField
import Data.Default
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.String.Conversions (cs ,ConvertibleStrings)
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.Calendar
import Data.Time.Format
import Unsafe.Coerce
import Data.UUID
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.Types as PG
import GHC.Records
import GHC.OverloadedLabels
import GHC.TypeLits
import GHC.Types
import Data.Proxy
import Data.Data
import qualified Control.Newtype.Generics as Newtype
import Control.Applicative (Const)
import qualified GHC.Types as Type
import qualified Data.Text as Text
import Data.Aeson (ToJSON (..))
import qualified Data.Aeson as Aeson
import qualified Data.Set as Set
import qualified Text.Read as Read
import qualified Data.Pool as Pool
import qualified GHC.Conc
import IHP.Postgres.Point
import IHP.Postgres.Inet
import qualified Data.ByteString.Char8 as ByteString
import IHP.Log.Types
import qualified IHP.Log as Log
import Data.Dynamic
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 ())
}
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext Logger
logger = ModelContext :: Pool Connection
-> Maybe Connection
-> Logger
-> Maybe (ByteString -> IO ())
-> ModelContext
ModelContext
{ $sel:connectionPool:ModelContext :: Pool Connection
connectionPool = [Char] -> Pool Connection
forall a. HasCallStack => [Char] -> a
error [Char]
"Not connected"
, $sel:transactionConnection:ModelContext :: Maybe Connection
transactionConnection = Maybe Connection
forall a. Maybe a
Nothing
, $sel:logger:ModelContext :: Logger
logger = Logger
logger
, $sel:trackTableReadCallback:ModelContext :: Maybe (ByteString -> IO ())
trackTableReadCallback = Maybe (ByteString -> IO ())
forall a. Maybe a
Nothing
}
createModelContext :: NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
createModelContext :: NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
createModelContext NominalDiffTime
idleTime Int
maxConnections ByteString
databaseUrl Logger
logger = do
Int
numStripes <- IO Int
GHC.Conc.getNumCapabilities
let create :: IO Connection
create = ByteString -> IO Connection
PG.connectPostgreSQL ByteString
databaseUrl
let destroy :: Connection -> IO ()
destroy = Connection -> IO ()
PG.close
Pool Connection
connectionPool <- IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool Connection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
Pool.createPool IO Connection
create Connection -> IO ()
destroy Int
numStripes NominalDiffTime
idleTime Int
maxConnections
let queryDebuggingEnabled :: Bool
queryDebuggingEnabled = Bool
False
let trackTableReadCallback :: Maybe a
trackTableReadCallback = Maybe a
forall a. Maybe a
Nothing
let transactionConnection :: Maybe a
transactionConnection = Maybe a
forall a. Maybe a
Nothing
ModelContext -> IO ModelContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModelContext :: Pool Connection
-> Maybe Connection
-> Logger
-> Maybe (ByteString -> IO ())
-> ModelContext
ModelContext { Maybe Connection
Maybe (ByteString -> IO ())
Logger
Pool Connection
forall a. Maybe a
transactionConnection :: forall a. Maybe a
trackTableReadCallback :: forall a. Maybe a
connectionPool :: Pool Connection
logger :: Logger
$sel:trackTableReadCallback:ModelContext :: Maybe (ByteString -> IO ())
$sel:logger:ModelContext :: Logger
$sel:transactionConnection:ModelContext :: Maybe Connection
$sel:connectionPool:ModelContext :: Pool Connection
.. }
instance LoggingProvider ModelContext where
getLogger :: ModelContext -> Logger
getLogger ModelContext { Maybe Connection
Maybe (ByteString -> IO ())
Logger
Pool Connection
trackTableReadCallback :: Maybe (ByteString -> IO ())
logger :: Logger
transactionConnection :: Maybe Connection
connectionPool :: Pool Connection
$sel:trackTableReadCallback:ModelContext :: ModelContext -> Maybe (ByteString -> IO ())
$sel:logger:ModelContext :: ModelContext -> Logger
$sel:transactionConnection:ModelContext :: ModelContext -> Maybe Connection
$sel:connectionPool:ModelContext :: ModelContext -> Pool Connection
.. } = Logger
logger
type family GetModelById id :: Type where
GetModelById (Maybe (Id' tableName)) = Maybe (GetModelByTableName tableName)
GetModelById (Id' tableName) = GetModelByTableName tableName
type family GetTableName model :: Symbol
type family GetModelByTableName (tableName :: Symbol) :: Type
class CanCreate a where
create :: (?modelContext :: ModelContext) => a -> IO a
createMany :: (?modelContext :: ModelContext) => [a] -> IO [a]
class CanUpdate a where
updateRecord :: (?modelContext :: ModelContext) => a -> IO a
{-# INLINE createRecord #-}
createRecord :: (?modelContext :: ModelContext, CanCreate model) => model -> IO model
createRecord :: model -> IO model
createRecord = model -> IO model
forall a. (CanCreate a, ?modelContext::ModelContext) => a -> IO a
create
class InputValue a where
inputValue :: a -> Text
instance InputValue Text where
inputValue :: Text -> Text
inputValue Text
text = Text
text
instance InputValue Int where
inputValue :: Int -> Text
inputValue = Int -> Text
forall a. Show a => a -> Text
tshow
instance InputValue Integer where
inputValue :: Integer -> Text
inputValue = Integer -> Text
forall a. Show a => a -> Text
tshow
instance InputValue Double where
inputValue :: Double -> Text
inputValue = Double -> Text
forall a. Show a => a -> Text
tshow
instance InputValue Float where
inputValue :: Float -> Text
inputValue = Float -> Text
forall a. Show a => a -> Text
tshow
instance InputValue Bool where
inputValue :: Bool -> Text
inputValue Bool
True = Text
"on"
inputValue Bool
False = Text
"off"
instance InputValue Data.UUID.UUID where
inputValue :: UUID -> Text
inputValue = UUID -> Text
Data.UUID.toText
instance InputValue () where
inputValue :: () -> Text
inputValue () = Text
"error: inputValue(()) not supported"
instance InputValue UTCTime where
inputValue :: UTCTime -> Text
inputValue UTCTime
time = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (UTCTime -> [Char]
forall t. ISO8601 t => t -> [Char]
iso8601Show UTCTime
time)
instance InputValue LocalTime where
inputValue :: LocalTime -> Text
inputValue LocalTime
time = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (LocalTime -> [Char]
forall t. ISO8601 t => t -> [Char]
iso8601Show LocalTime
time)
instance InputValue Day where
inputValue :: Day -> Text
inputValue Day
date = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Day -> [Char]
forall t. ISO8601 t => t -> [Char]
iso8601Show Day
date)
instance InputValue fieldType => InputValue (Maybe fieldType) where
inputValue :: Maybe fieldType -> Text
inputValue (Just fieldType
value) = fieldType -> Text
forall a. InputValue a => a -> Text
inputValue fieldType
value
inputValue Maybe fieldType
Nothing = Text
""
instance InputValue value => InputValue [value] where
inputValue :: [value] -> Text
inputValue [value]
list = [value]
list [value] -> ([value] -> [Text]) -> [Text]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> (value -> Text) -> [value] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map value -> Text
forall a. InputValue a => a -> Text
inputValue [Text] -> ([Text] -> Text) -> Text
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
","
instance InputValue Aeson.Value where
inputValue :: Value -> Text
inputValue Value
json = Value
json Value -> (Value -> ByteString) -> ByteString
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode ByteString -> (ByteString -> Text) -> Text
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs
instance Default Text where
{-# INLINE def #-}
def :: Text
def = Text
""
instance Default Bool where
{-# INLINE def #-}
def :: Bool
def = Bool
False
instance Default Point where
def :: Point
def = Double -> Double -> Point
Point Double
forall a. Default a => a
def Double
forall a. Default a => a
def
type FieldName = ByteString
isNew :: forall model id. (HasField "id" model id, Default id, Eq id) => model -> Bool
isNew :: model -> Bool
isNew model
model = id
forall a. Default a => a
def id -> id -> Bool
forall a. Eq a => a -> a -> Bool
== (model -> id
forall k (x :: k) r a. HasField x r a => r -> a
getField @"id" model
model)
{-# INLINE isNew #-}
type family GetModelName model :: Symbol
type family PrimaryKey (tableName :: Symbol)
getModelName :: forall model. KnownSymbol (GetModelName model) => Text
getModelName :: Text
getModelName = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$! Proxy (GetModelName model) -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy (GetModelName model)
forall k (t :: k). Proxy t
Proxy :: Proxy (GetModelName model))
{-# INLINE getModelName #-}
newtype Id' table = Id (PrimaryKey table)
deriving instance (Eq (PrimaryKey table)) => Eq (Id' table)
deriving instance (Ord (PrimaryKey table)) => Ord (Id' table)
deriving instance (Hashable (PrimaryKey table)) => Hashable (Id' table)
deriving instance (KnownSymbol table, Data (PrimaryKey table)) => Data (Id' table)
deriving instance (KnownSymbol table, NFData (PrimaryKey table)) => NFData (Id' table)
type Id model = Id' (GetTableName model)
instance InputValue (PrimaryKey model') => InputValue (Id' model') where
{-# INLINE inputValue #-}
inputValue :: Id' model' -> Text
inputValue = PrimaryKey model' -> Text
forall a. InputValue a => a -> Text
inputValue (PrimaryKey model' -> Text)
-> (Id' model' -> PrimaryKey model') -> Id' model' -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Id' model' -> PrimaryKey model'
forall n. Newtype n => n -> O n
Newtype.unpack
instance IsEmpty (PrimaryKey table) => IsEmpty (Id' table) where
isEmpty :: Id' table -> Bool
isEmpty (Id PrimaryKey table
primaryKey) = PrimaryKey table -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty PrimaryKey table
primaryKey
recordToInputValue :: (HasField "id" entity (Id entity), Show (PrimaryKey (GetTableName entity))) => entity -> Text
recordToInputValue :: entity -> Text
recordToInputValue entity
entity =
entity -> Id' (GetTableName entity)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"id" entity
entity
Id' (GetTableName entity)
-> (Id' (GetTableName entity) -> PrimaryKey (GetTableName entity))
-> PrimaryKey (GetTableName entity)
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Id' (GetTableName entity) -> PrimaryKey (GetTableName entity)
forall n. Newtype n => n -> O n
Newtype.unpack
PrimaryKey (GetTableName entity)
-> (PrimaryKey (GetTableName entity) -> Text) -> Text
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> PrimaryKey (GetTableName entity) -> Text
forall a. Show a => a -> Text
tshow
{-# INLINE recordToInputValue #-}
instance FromField (PrimaryKey model) => FromField (Id' model) where
{-# INLINE fromField #-}
fromField :: FieldParser (Id' model)
fromField Field
value Maybe ByteString
metaData = do
PrimaryKey model
fieldValue <- FieldParser (PrimaryKey model)
forall a. FromField a => FieldParser a
fromField Field
value Maybe ByteString
metaData
Id' model -> Conversion (Id' model)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimaryKey model -> Id' model
forall (table :: Symbol). PrimaryKey table -> Id' table
Id PrimaryKey model
fieldValue)
instance ToField (PrimaryKey model) => ToField (Id' model) where
{-# INLINE toField #-}
toField :: Id' model -> Action
toField = PrimaryKey model -> Action
forall a. ToField a => a -> Action
toField (PrimaryKey model -> Action)
-> (Id' model -> PrimaryKey model) -> Id' model -> Action
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Id' model -> PrimaryKey model
forall n. Newtype n => n -> O n
Newtype.unpack
instance Show (PrimaryKey model) => Show (Id' model) where
{-# INLINE show #-}
show :: Id' model -> [Char]
show = PrimaryKey model -> [Char]
forall a. Show a => a -> [Char]
show (PrimaryKey model -> [Char])
-> (Id' model -> PrimaryKey model) -> Id' model -> [Char]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Id' model -> PrimaryKey model
forall n. Newtype n => n -> O n
Newtype.unpack
instance Newtype.Newtype (Id' model) where
type O (Id' model) = PrimaryKey model
pack :: O (Id' model) -> Id' model
pack = O (Id' model) -> Id' model
forall (table :: Symbol). PrimaryKey table -> Id' table
Id
unpack :: Id' model -> O (Id' model)
unpack (Id PrimaryKey model
uuid) = O (Id' model)
PrimaryKey model
uuid
instance (Read (PrimaryKey model), ParsePrimaryKey (PrimaryKey model)) => IsString (Id' model) where
fromString :: [Char] -> Id' model
fromString [Char]
uuid = [Char] -> Id' model
forall (model :: Symbol) text.
(ParsePrimaryKey (PrimaryKey model),
ConvertibleStrings text Text) =>
text -> Id' model
textToId [Char]
uuid
class ParsePrimaryKey primaryKey where
parsePrimaryKey :: Text -> Maybe primaryKey
instance ParsePrimaryKey UUID where
parsePrimaryKey :: Text -> Maybe UUID
parsePrimaryKey = [Char] -> Maybe UUID
forall a. Read a => [Char] -> Maybe a
Read.readMaybe ([Char] -> Maybe UUID) -> (Text -> [Char]) -> Text -> Maybe UUID
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs
instance ParsePrimaryKey Text where
parsePrimaryKey :: Text -> Maybe Text
parsePrimaryKey Text
text = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
text
textToId :: (ParsePrimaryKey (PrimaryKey model), ConvertibleStrings text Text) => text -> Id' model
textToId :: text -> Id' model
textToId text
text = case Text -> Maybe (PrimaryKey model)
forall primaryKey.
ParsePrimaryKey primaryKey =>
Text -> Maybe primaryKey
parsePrimaryKey (text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs text
text) of
Just PrimaryKey model
id -> PrimaryKey model -> Id' model
forall (table :: Symbol). PrimaryKey table -> Id' table
Id PrimaryKey model
id
Maybe (PrimaryKey model)
Nothing -> [Char] -> Id' model
forall a. HasCallStack => [Char] -> a
error (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text
"Unable to convert " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs text
text :: Text) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to Id value. Is it a valid uuid?")
{-# INLINE textToId #-}
instance Default (PrimaryKey model) => Default (Id' model) where
{-# INLINE def #-}
def :: Id' model
def = O (Id' model) -> Id' model
forall n. Newtype n => O n -> n
Newtype.pack O (Id' model)
forall a. Default a => a
def
measureTimeIfLogging :: (?modelContext :: ModelContext, Show q) => IO a -> Query -> q -> IO a
measureTimeIfLogging :: IO a -> Query -> q -> IO a
measureTimeIfLogging IO a
queryAction Query
theQuery q
theParameters = do
let currentLogLevel :: LogLevel
currentLogLevel = Proxy "logger" -> ModelContext -> Logger
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "logger" (Proxy "logger")
Proxy "logger"
#logger ?modelContext::ModelContext
ModelContext
?modelContext Logger -> (Logger -> LogLevel) -> LogLevel
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "level" -> Logger -> LogLevel
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "level" (Proxy "level")
Proxy "level"
#level
if LogLevel
currentLogLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
Debug
then do
UTCTime
start <- IO UTCTime
getCurrentTime
a
result <- IO a
queryAction
UTCTime
end <- IO UTCTime
getCurrentTime
let theTime :: NominalDiffTime
theTime = UTCTime
end UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
start
Query -> q -> NominalDiffTime -> IO ()
forall query parameters.
(?modelContext::ModelContext, Show query, Show parameters) =>
query -> parameters -> NominalDiffTime -> IO ()
logQuery Query
theQuery q
theParameters NominalDiffTime
theTime
a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
else IO a
queryAction
sqlQuery :: (?modelContext :: ModelContext, PG.ToRow q, PG.FromRow r, Show q) => Query -> q -> IO [r]
sqlQuery :: Query -> q -> IO [r]
sqlQuery Query
theQuery q
theParameters = do
IO [r] -> Query -> q -> IO [r]
forall q a.
(?modelContext::ModelContext, Show q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
((Connection -> IO [r]) -> IO [r]
forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> Connection -> Query -> q -> IO [r]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
connection Query
theQuery q
theParameters)
Query
theQuery
q
theParameters
{-# INLINABLE sqlQuery #-}
sqlExec :: (?modelContext :: ModelContext, PG.ToRow q, Show q) => Query -> q -> IO Int64
sqlExec :: Query -> q -> IO Int64
sqlExec Query
theQuery q
theParameters = do
IO Int64 -> Query -> q -> IO Int64
forall q a.
(?modelContext::ModelContext, Show q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
((Connection -> IO Int64) -> IO Int64
forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> Connection -> Query -> q -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
PG.execute Connection
connection Query
theQuery q
theParameters)
Query
theQuery
q
theParameters
{-# INLINABLE sqlExec #-}
withDatabaseConnection :: (?modelContext :: ModelContext) => (Connection -> IO a) -> IO a
withDatabaseConnection :: (Connection -> IO a) -> IO a
withDatabaseConnection Connection -> IO a
block =
let
ModelContext { Pool Connection
connectionPool :: Pool Connection
$sel:connectionPool:ModelContext :: ModelContext -> Pool Connection
connectionPool, Maybe Connection
transactionConnection :: Maybe Connection
$sel:transactionConnection:ModelContext :: ModelContext -> Maybe Connection
transactionConnection } = ?modelContext::ModelContext
ModelContext
?modelContext
in case Maybe Connection
transactionConnection of
Just Connection
transactionConnection -> Connection -> IO a
block Connection
transactionConnection
Maybe Connection
Nothing -> Pool Connection -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource Pool Connection
connectionPool Connection -> IO a
block
{-# INLINABLE withDatabaseConnection #-}
sqlQueryScalar :: (?modelContext :: ModelContext) => (PG.ToRow q, Show q, FromField value) => Query -> q -> IO value
sqlQueryScalar :: Query -> q -> IO value
sqlQueryScalar Query
theQuery q
theParameters = do
[Only value]
result <- IO [Only value] -> Query -> q -> IO [Only value]
forall q a.
(?modelContext::ModelContext, Show q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
((Connection -> IO [Only value]) -> IO [Only value]
forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> Connection -> Query -> q -> IO [Only value]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
connection Query
theQuery q
theParameters)
Query
theQuery
q
theParameters
value -> IO value
forall (f :: * -> *) a. Applicative f => a -> f a
pure case [Only value]
result of
[PG.Only value
result] -> value
result
[Only value]
_ -> [Char] -> value
forall a. HasCallStack => [Char] -> a
error [Char]
"sqlQueryScalar: Expected a scalar result value"
{-# INLINABLE sqlQueryScalar #-}
withTransaction :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext) => IO a) -> IO a
withTransaction :: ((?modelContext::ModelContext) => IO a) -> IO a
withTransaction (?modelContext::ModelContext) => IO a
block = ((?modelContext::ModelContext) => IO a) -> IO a
forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withTransactionConnection do
let connection :: Connection
connection = ?modelContext::ModelContext
ModelContext
?modelContext
ModelContext
-> (ModelContext -> Maybe Connection) -> Maybe Connection
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "transactionConnection" -> ModelContext -> Maybe Connection
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "transactionConnection" (Proxy "transactionConnection")
Proxy "transactionConnection"
#transactionConnection
Maybe Connection -> (Maybe Connection -> Connection) -> Connection
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
Just Connection
connection -> Connection
connection
Maybe Connection
Nothing -> [Char] -> Connection
forall a. HasCallStack => [Char] -> a
error [Char]
"withTransaction: transactionConnection not set as expected"
Connection -> IO a -> IO a
forall a. Connection -> IO a -> IO a
PG.withTransaction Connection
connection IO a
(?modelContext::ModelContext) => IO a
block
{-# INLINABLE withTransaction #-}
transactionConnectionOrError :: (?modelContext :: ModelContext) => Connection
transactionConnectionOrError :: Connection
transactionConnectionOrError = ?modelContext::ModelContext
ModelContext
?modelContext
ModelContext
-> (ModelContext -> Maybe Connection) -> Maybe Connection
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "transactionConnection" -> ModelContext -> Maybe Connection
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "transactionConnection" (Proxy "transactionConnection")
Proxy "transactionConnection"
#transactionConnection
Maybe Connection -> (Maybe Connection -> Connection) -> Connection
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> \case
Just Connection
connection -> Connection
connection
Maybe Connection
Nothing -> [Char] -> Connection
forall a. HasCallStack => [Char] -> a
error [Char]
"getTransactionConnectionOrError: Not in a transaction state"
commitTransaction :: (?modelContext :: ModelContext) => IO ()
commitTransaction :: IO ()
commitTransaction = Connection -> IO ()
PG.commit Connection
(?modelContext::ModelContext) => Connection
transactionConnectionOrError
{-# INLINABLE commitTransaction #-}
rollbackTransaction :: (?modelContext :: ModelContext) => IO ()
rollbackTransaction :: IO ()
rollbackTransaction = Connection -> IO ()
PG.rollback Connection
(?modelContext::ModelContext) => Connection
transactionConnectionOrError
{-# INLINABLE rollbackTransaction #-}
withTransactionConnection :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext) => IO a) -> IO a
withTransactionConnection :: ((?modelContext::ModelContext) => IO a) -> IO a
withTransactionConnection (?modelContext::ModelContext) => IO a
block = do
(Connection -> IO a) -> IO a
forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> do
let modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext { $sel:transactionConnection:ModelContext :: Maybe Connection
transactionConnection = Connection -> Maybe Connection
forall a. a -> Maybe a
Just Connection
connection }
let ?modelContext = modelContext in IO a
(?modelContext::ModelContext) => IO a
block
{-# INLINABLE withTransactionConnection #-}
tableName :: forall model. (KnownSymbol (GetTableName model)) => Text
tableName :: Text
tableName = KnownSymbol (GetTableName model) => Text
forall (symbol :: Symbol). KnownSymbol symbol => Text
symbolToText @(GetTableName model)
{-# INLINE tableName #-}
tableNameByteString :: forall model. (KnownSymbol (GetTableName model)) => ByteString
tableNameByteString :: ByteString
tableNameByteString = KnownSymbol (GetTableName model) => ByteString
forall (symbol :: Symbol). KnownSymbol symbol => ByteString
symbolToByteString @(GetTableName model)
{-# INLINE tableNameByteString #-}
logQuery :: (?modelContext :: ModelContext, Show query, Show parameters) => query -> parameters -> NominalDiffTime -> IO ()
logQuery :: query -> parameters -> NominalDiffTime -> IO ()
logQuery query
query parameters
parameters NominalDiffTime
time = do
let ?context = ?modelContext
let queryTimeInMs :: Double
queryTimeInMs = (NominalDiffTime
time NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000) NominalDiffTime -> (NominalDiffTime -> Rational) -> Rational
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational Rational -> (Rational -> Double) -> Double
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Fractional Double => Rational -> Double
forall a. Fractional a => Rational -> a
fromRational @Double
Text -> IO ()
forall context.
(?context::context, LoggingProvider context) =>
Text -> IO ()
Log.debug (Text
"Query (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
forall a. Show a => a -> Text
tshow Double
queryTimeInMs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ms): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> query -> Text
forall a. Show a => a -> Text
tshow query
query Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> parameters -> Text
forall a. Show a => a -> Text
tshow parameters
parameters)
{-# INLINABLE logQuery #-}
deleteRecord :: forall model id. (?modelContext :: ModelContext, Show id, KnownSymbol (GetTableName model), HasField "id" model id, ToField id) => model -> IO ()
deleteRecord :: model -> IO ()
deleteRecord model
model = Proxy "id" -> model -> id
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "id" (Proxy "id")
Proxy "id"
#id model
model id -> (id -> IO ()) -> IO ()
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> (?modelContext::ModelContext, Show id,
KnownSymbol (GetTableName model), HasField "id" model id,
ToField id) =>
id -> IO ()
forall model id.
(?modelContext::ModelContext, Show id,
KnownSymbol (GetTableName model), HasField "id" model id,
ToField id) =>
id -> IO ()
deleteRecordById @model @id
{-# INLINABLE deleteRecord #-}
deleteRecordById :: forall model id. (?modelContext :: ModelContext, Show id, KnownSymbol (GetTableName model), HasField "id" model id, ToField id) => id -> IO ()
deleteRecordById :: id -> IO ()
deleteRecordById id
id = do
let theQuery :: Text
theQuery = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KnownSymbol (GetTableName model) => Text
forall model. KnownSymbol (GetTableName model) => Text
tableName @model Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = ?"
let theParameters :: Only id
theParameters = (id -> Only id
forall a. a -> Only a
PG.Only id
id)
Query -> Only id -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q, Show q) =>
Query -> q -> IO Int64
sqlExec (ByteString -> Query
PG.Query (ByteString -> Query) -> (Text -> ByteString) -> Text -> Query
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$! Text
theQuery) Only id
theParameters
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE deleteRecordById #-}
deleteRecords :: forall record id. (?modelContext :: ModelContext, Show id, KnownSymbol (GetTableName record), HasField "id" record id, record ~ GetModelById id, ToField id) => [record] -> IO ()
deleteRecords :: [record] -> IO ()
deleteRecords [record]
records = do
let theQuery :: Text
theQuery = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KnownSymbol (GetTableName record) => Text
forall model. KnownSymbol (GetTableName model) => Text
tableName @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id IN ?"
let theParameters :: Only (In [id])
theParameters = In [id] -> Only (In [id])
forall a. a -> Only a
PG.Only ([id] -> In [id]
forall a. a -> In a
PG.In ([record] -> [id]
forall record id. HasField "id" record id => [record] -> [id]
ids [record]
records))
Query -> Only (In [id]) -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q, Show q) =>
Query -> q -> IO Int64
sqlExec (ByteString -> Query
PG.Query (ByteString -> Query) -> (Text -> ByteString) -> Text -> Query
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$! Text
theQuery) Only (In [id])
theParameters
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE deleteRecords #-}
deleteAll :: forall record. (?modelContext :: ModelContext, KnownSymbol (GetTableName record)) => IO ()
deleteAll :: IO ()
deleteAll = do
let theQuery :: Text
theQuery = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> KnownSymbol (GetTableName record) => Text
forall model. KnownSymbol (GetTableName model) => Text
tableName @record
Query -> () -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q, Show q) =>
Query -> q -> IO Int64
sqlExec (ByteString -> Query
PG.Query (ByteString -> Query) -> (Text -> ByteString) -> Text -> Query
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$! Text
theQuery) ()
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE deleteAll #-}
type family Include (name :: GHC.Types.Symbol) model
type family Include' (name :: [GHC.Types.Symbol]) model where
Include' '[] model = model
Include' (x:xs) model = Include' xs (Include x model)
instance Default LocalTime where
def :: LocalTime
def = Day -> TimeOfDay -> LocalTime
LocalTime Day
forall a. Default a => a
def (Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
0 Int
0 Pico
0)
instance Default Day where
def :: Day
def = Integer -> Day
ModifiedJulianDay Integer
0
instance Default UTCTime where
def :: UTCTime
def = Day -> DiffTime -> UTCTime
UTCTime Day
forall a. Default a => a
def DiffTime
0
instance Default (PG.Binary ByteString) where
def :: Binary ByteString
def = ByteString -> Binary ByteString
forall a. a -> Binary a
PG.Binary ByteString
""
instance Newtype.Newtype (PG.Binary payload) where
type O (PG.Binary payload) = payload
pack :: O (Binary payload) -> Binary payload
pack = O (Binary payload) -> Binary payload
forall a. a -> Binary a
PG.Binary
unpack :: Binary payload -> O (Binary payload)
unpack (PG.Binary payload
payload) = payload
O (Binary payload)
payload
class Record model where
newRecord :: model
type NormalizeModel model = GetModelByTableName (GetTableName model)
ids :: (HasField "id" record id) => [record] -> [id]
ids :: [record] -> [id]
ids [record]
records = (record -> id) -> [record] -> [id]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "id" r a => r -> a
getField @"id") [record]
records
{-# INLINE ids #-}
data MetaBag = MetaBag
{ MetaBag -> [(Text, Text)]
annotations :: ![(Text, Text)]
, MetaBag -> [Text]
touchedFields :: ![Text]
, MetaBag -> Maybe Dynamic
originalDatabaseRecord :: Maybe Dynamic
} deriving (Int -> MetaBag -> ShowS
[MetaBag] -> ShowS
MetaBag -> [Char]
(Int -> MetaBag -> ShowS)
-> (MetaBag -> [Char]) -> ([MetaBag] -> ShowS) -> Show MetaBag
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MetaBag] -> ShowS
$cshowList :: [MetaBag] -> ShowS
show :: MetaBag -> [Char]
$cshow :: MetaBag -> [Char]
showsPrec :: Int -> MetaBag -> ShowS
$cshowsPrec :: Int -> MetaBag -> ShowS
Show)
instance Eq MetaBag where
MetaBag { [(Text, Text)]
annotations :: [(Text, Text)]
$sel:annotations:MetaBag :: MetaBag -> [(Text, Text)]
annotations, [Text]
touchedFields :: [Text]
$sel:touchedFields:MetaBag :: MetaBag -> [Text]
touchedFields } == :: MetaBag -> MetaBag -> Bool
== MetaBag { $sel:annotations:MetaBag :: MetaBag -> [(Text, Text)]
annotations = [(Text, Text)]
annotations', $sel:touchedFields:MetaBag :: MetaBag -> [Text]
touchedFields = [Text]
touchedFields' } = [(Text, Text)]
annotations [(Text, Text)] -> [(Text, Text)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Text, Text)]
annotations' Bool -> Bool -> Bool
&& [Text]
touchedFields [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
touchedFields'
instance Default MetaBag where
def :: MetaBag
def = MetaBag :: [(Text, Text)] -> [Text] -> Maybe Dynamic -> MetaBag
MetaBag { $sel:annotations:MetaBag :: [(Text, Text)]
annotations = [], $sel:touchedFields:MetaBag :: [Text]
touchedFields = [], $sel:originalDatabaseRecord:MetaBag :: Maybe Dynamic
originalDatabaseRecord = Maybe Dynamic
forall a. Maybe a
Nothing }
{-# INLINE def #-}
instance SetField "annotations" MetaBag [(Text, Text)] where
setField :: [(Text, Text)] -> MetaBag -> MetaBag
setField [(Text, Text)]
value MetaBag
meta = MetaBag
meta { $sel:annotations:MetaBag :: [(Text, Text)]
annotations = [(Text, Text)]
value }
{-# INLINE setField #-}
instance SetField "touchedFields" MetaBag [Text] where
setField :: [Text] -> MetaBag -> MetaBag
setField [Text]
value MetaBag
meta = MetaBag
meta { $sel:touchedFields:MetaBag :: [Text]
touchedFields = [Text]
value }
{-# INLINE setField #-}
didChangeRecord :: (HasField "meta" record MetaBag) => record -> Bool
didChangeRecord :: record -> Bool
didChangeRecord record
record =
record
record
record -> (record -> MetaBag) -> MetaBag
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "meta" -> record -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta
MetaBag -> (MetaBag -> [Text]) -> [Text]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "touchedFields" -> MetaBag -> [Text]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "touchedFields" (Proxy "touchedFields")
Proxy "touchedFields"
#touchedFields
[Text] -> ([Text] -> Bool) -> Bool
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> [Text] -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty
didChange :: forall fieldName fieldValue record. (KnownSymbol fieldName, HasField fieldName record fieldValue, HasField "meta" record MetaBag, Eq fieldValue, Typeable record) => Proxy fieldName -> record -> Bool
didChange :: Proxy fieldName -> record -> Bool
didChange Proxy fieldName
field record
record = Bool
didTouchField Bool -> Bool -> Bool
&& Bool
didChangeField
where
didTouchField :: Bool
didTouchField :: Bool
didTouchField =
record
record
record -> (record -> MetaBag) -> MetaBag
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "meta" -> record -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta
MetaBag -> (MetaBag -> [Text]) -> [Text]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "touchedFields" -> MetaBag -> [Text]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "touchedFields" (Proxy "touchedFields")
Proxy "touchedFields"
#touchedFields
[Text] -> ([Text] -> Bool) -> Bool
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Element [Text] -> [Text] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes ([Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$! Proxy fieldName -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy fieldName
field)
didChangeField :: Bool
didChangeField :: Bool
didChangeField = fieldValue
originalFieldValue fieldValue -> fieldValue -> Bool
forall a. Eq a => a -> a -> Bool
/= fieldValue
fieldValue
fieldValue :: fieldValue
fieldValue :: fieldValue
fieldValue = record
record record -> (record -> fieldValue) -> fieldValue
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField fieldName r a => r -> a
getField @fieldName
originalFieldValue :: fieldValue
originalFieldValue :: fieldValue
originalFieldValue =
record
record
record -> (record -> MetaBag) -> MetaBag
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "meta" -> record -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta
MetaBag -> (MetaBag -> Maybe Dynamic) -> Maybe Dynamic
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "originalDatabaseRecord" -> MetaBag -> Maybe Dynamic
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "originalDatabaseRecord" (Proxy "originalDatabaseRecord")
Proxy "originalDatabaseRecord"
#originalDatabaseRecord
Maybe Dynamic -> (Maybe Dynamic -> Dynamic) -> Dynamic
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Dynamic -> Maybe Dynamic -> Dynamic
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Dynamic
forall a. HasCallStack => [Char] -> a
error [Char]
"didChange called on a record without originalDatabaseRecord")
Dynamic -> (Dynamic -> Maybe record) -> Maybe record
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Typeable record => Dynamic -> Maybe record
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @record
Maybe record -> (Maybe record -> record) -> record
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> record -> Maybe record -> record
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> record
forall a. HasCallStack => [Char] -> a
error [Char]
"didChange failed to retrieve originalDatabaseRecord")
record -> (record -> fieldValue) -> fieldValue
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField fieldName r a => r -> a
getField @fieldName
data FieldWithDefault valueType = Default | NonDefault valueType deriving (FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
(FieldWithDefault valueType -> FieldWithDefault valueType -> Bool)
-> (FieldWithDefault valueType
-> FieldWithDefault valueType -> Bool)
-> Eq (FieldWithDefault valueType)
forall valueType.
Eq valueType =>
FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
$c/= :: forall valueType.
Eq valueType =>
FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
== :: FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
$c== :: forall valueType.
Eq valueType =>
FieldWithDefault valueType -> FieldWithDefault valueType -> Bool
Eq, Int -> FieldWithDefault valueType -> ShowS
[FieldWithDefault valueType] -> ShowS
FieldWithDefault valueType -> [Char]
(Int -> FieldWithDefault valueType -> ShowS)
-> (FieldWithDefault valueType -> [Char])
-> ([FieldWithDefault valueType] -> ShowS)
-> Show (FieldWithDefault valueType)
forall valueType.
Show valueType =>
Int -> FieldWithDefault valueType -> ShowS
forall valueType.
Show valueType =>
[FieldWithDefault valueType] -> ShowS
forall valueType.
Show valueType =>
FieldWithDefault valueType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FieldWithDefault valueType] -> ShowS
$cshowList :: forall valueType.
Show valueType =>
[FieldWithDefault valueType] -> ShowS
show :: FieldWithDefault valueType -> [Char]
$cshow :: forall valueType.
Show valueType =>
FieldWithDefault valueType -> [Char]
showsPrec :: Int -> FieldWithDefault valueType -> ShowS
$cshowsPrec :: forall valueType.
Show valueType =>
Int -> FieldWithDefault valueType -> ShowS
Show)
instance ToField valueType => ToField (FieldWithDefault valueType) where
toField :: FieldWithDefault valueType -> Action
toField FieldWithDefault valueType
Default = Builder -> Action
Plain Builder
"DEFAULT"
toField (NonDefault valueType
a) = valueType -> Action
forall a. ToField a => a -> Action
toField valueType
a
fieldWithDefault
:: ( KnownSymbol name
, HasField name model value
, HasField "meta" model MetaBag
)
=> Proxy name
-> model
-> FieldWithDefault value
fieldWithDefault :: Proxy name -> model -> FieldWithDefault value
fieldWithDefault Proxy name
name model
model
| [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy name
name) Element [Text] -> [Text] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
`elem` Proxy "touchedFields" -> MetaBag -> [Text]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "touchedFields" (Proxy "touchedFields")
Proxy "touchedFields"
#touchedFields (Proxy "meta" -> model -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta model
model) =
value -> FieldWithDefault value
forall valueType. valueType -> FieldWithDefault valueType
NonDefault (Proxy name -> model -> value
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy name
name model
model)
| Bool
otherwise = FieldWithDefault value
forall valueType. FieldWithDefault valueType
Default
data FieldWithUpdate name value
= NoUpdate (Proxy name)
| Update value
deriving (FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
(FieldWithUpdate name value -> FieldWithUpdate name value -> Bool)
-> (FieldWithUpdate name value
-> FieldWithUpdate name value -> Bool)
-> Eq (FieldWithUpdate name value)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (name :: k) value.
Eq value =>
FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
/= :: FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
$c/= :: forall k (name :: k) value.
Eq value =>
FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
== :: FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
$c== :: forall k (name :: k) value.
Eq value =>
FieldWithUpdate name value -> FieldWithUpdate name value -> Bool
Eq, Int -> FieldWithUpdate name value -> ShowS
[FieldWithUpdate name value] -> ShowS
FieldWithUpdate name value -> [Char]
(Int -> FieldWithUpdate name value -> ShowS)
-> (FieldWithUpdate name value -> [Char])
-> ([FieldWithUpdate name value] -> ShowS)
-> Show (FieldWithUpdate name value)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall k (name :: k) value.
Show value =>
Int -> FieldWithUpdate name value -> ShowS
forall k (name :: k) value.
Show value =>
[FieldWithUpdate name value] -> ShowS
forall k (name :: k) value.
Show value =>
FieldWithUpdate name value -> [Char]
showList :: [FieldWithUpdate name value] -> ShowS
$cshowList :: forall k (name :: k) value.
Show value =>
[FieldWithUpdate name value] -> ShowS
show :: FieldWithUpdate name value -> [Char]
$cshow :: forall k (name :: k) value.
Show value =>
FieldWithUpdate name value -> [Char]
showsPrec :: Int -> FieldWithUpdate name value -> ShowS
$cshowsPrec :: forall k (name :: k) value.
Show value =>
Int -> FieldWithUpdate name value -> ShowS
Show)
instance (KnownSymbol name, ToField value) => ToField (FieldWithUpdate name value) where
toField :: FieldWithUpdate name value -> Action
toField (NoUpdate Proxy name
name) =
Builder -> Action
Plain ([Char] -> Builder
forall a. IsString a => [Char] -> a
ClassyPrelude.fromString ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text -> Text
fieldNameToColumnName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy name
name)
toField (Update value
a) = value -> Action
forall a. ToField a => a -> Action
toField value
a
fieldWithUpdate
:: ( KnownSymbol name
, HasField name model value
, HasField "meta" model MetaBag
)
=> Proxy name
-> model
-> FieldWithUpdate name value
fieldWithUpdate :: Proxy name -> model -> FieldWithUpdate name value
fieldWithUpdate Proxy name
name model
model
| [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal Proxy name
name) Element [Text] -> [Text] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
`elem` Proxy "touchedFields" -> MetaBag -> [Text]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "touchedFields" (Proxy "touchedFields")
Proxy "touchedFields"
#touchedFields (Proxy "meta" -> model -> MetaBag
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "meta" (Proxy "meta")
Proxy "meta"
#meta model
model) =
value -> FieldWithUpdate name value
forall k (name :: k) value. value -> FieldWithUpdate name value
Update (Proxy name -> model -> value
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get Proxy name
name model
model)
| Bool
otherwise = Proxy name -> FieldWithUpdate name value
forall k (name :: k) value.
Proxy name -> FieldWithUpdate name value
NoUpdate Proxy name
name
instance (ToJSON (PrimaryKey a)) => ToJSON (Id' a) where
toJSON :: Id' a -> Value
toJSON (Id PrimaryKey a
a) = PrimaryKey a -> Value
forall a. ToJSON a => a -> Value
toJSON PrimaryKey a
a
data RecordNotFoundException
= RecordNotFoundException { RecordNotFoundException -> (ByteString, [Action])
queryAndParams :: (ByteString, [Action]) }
deriving (Int -> RecordNotFoundException -> ShowS
[RecordNotFoundException] -> ShowS
RecordNotFoundException -> [Char]
(Int -> RecordNotFoundException -> ShowS)
-> (RecordNotFoundException -> [Char])
-> ([RecordNotFoundException] -> ShowS)
-> Show RecordNotFoundException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RecordNotFoundException] -> ShowS
$cshowList :: [RecordNotFoundException] -> ShowS
show :: RecordNotFoundException -> [Char]
$cshow :: RecordNotFoundException -> [Char]
showsPrec :: Int -> RecordNotFoundException -> ShowS
$cshowsPrec :: Int -> RecordNotFoundException -> ShowS
Show)
instance Exception RecordNotFoundException
instance Default Aeson.Value where
def :: Value
def = Value
Aeson.Null
instance ToField value => ToField [value] where
toField :: [value] -> Action
toField [value]
list = PGArray value -> Action
forall a. ToField a => a -> Action
toField ([value] -> PGArray value
forall a. [a] -> PGArray a
PG.PGArray [value]
list)
instance (FromField value, Typeable value) => FromField [value] where
fromField :: FieldParser [value]
fromField Field
field Maybe ByteString
value = PGArray value -> [value]
forall a. PGArray a -> [a]
PG.fromPGArray (PGArray value -> [value])
-> Conversion (PGArray value) -> Conversion [value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldParser (PGArray value)
forall a. FromField a => FieldParser a
fromField Field
field Maybe ByteString
value)
trackTableRead :: (?modelContext :: ModelContext) => ByteString -> IO ()
trackTableRead :: ByteString -> IO ()
trackTableRead ByteString
tableName = case Proxy "trackTableReadCallback"
-> ModelContext -> Maybe (ByteString -> IO ())
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "trackTableReadCallback" (Proxy "trackTableReadCallback")
Proxy "trackTableReadCallback"
#trackTableReadCallback ?modelContext::ModelContext
ModelContext
?modelContext of
Just ByteString -> IO ()
callback -> ByteString -> IO ()
callback ByteString
tableName
Maybe (ByteString -> IO ())
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE trackTableRead #-}
withTableReadTracker :: (?modelContext :: ModelContext) => ((?modelContext :: ModelContext, ?touchedTables :: IORef (Set ByteString)) => IO ()) -> IO ()
withTableReadTracker :: ((?modelContext::ModelContext,
?touchedTables::IORef (Set ByteString)) =>
IO ())
-> IO ()
withTableReadTracker (?modelContext::ModelContext,
?touchedTables::IORef (Set ByteString)) =>
IO ()
trackedSection = do
IORef (Set ByteString)
touchedTablesVar <- Set ByteString -> IO (IORef (Set ByteString))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Set ByteString
forall a. Set a
Set.empty
let trackTableReadCallback :: Maybe (ByteString -> IO ())
trackTableReadCallback = (ByteString -> IO ()) -> Maybe (ByteString -> IO ())
forall a. a -> Maybe a
Just \ByteString
tableName -> IORef (Set ByteString)
-> (Set ByteString -> Set ByteString) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef (Set ByteString)
touchedTablesVar (ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => a -> Set a -> Set a
Set.insert ByteString
tableName)
let oldModelContext :: ModelContext
oldModelContext = ?modelContext::ModelContext
ModelContext
?modelContext
let ?modelContext = oldModelContext { trackTableReadCallback }
let ?touchedTables = touchedTablesVar
IO ()
(?modelContext::ModelContext,
?touchedTables::IORef (Set ByteString)) =>
IO ()
trackedSection