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

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

import IHP.HaskellSupport
import IHP.NameSupport
import ClassyPrelude hiding (UTCTime, find, ModifiedJulianDay)
import Database.PostgreSQL.Simple (Connection)
import Database.PostgreSQL.Simple.Types (Query)
import Database.PostgreSQL.Simple.FromField hiding (Field, name)
import Database.PostgreSQL.Simple.ToField
import Data.Default
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.String.Conversions (cs ,ConvertibleStrings)
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.Calendar
import Data.UUID
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.Types as PG
import qualified Database.PostgreSQL.Simple.FromRow as PGFR
import qualified Database.PostgreSQL.Simple.ToField as PG
import qualified Database.PostgreSQL.Simple.ToRow as PG
import GHC.Records
import GHC.TypeLits
import GHC.Types
import Data.Proxy
import Data.Data
import Data.Aeson (ToJSON (..), FromJSON (..))
import qualified Data.Aeson as Aeson
import qualified Data.Set as Set
import qualified Text.Read as Read
import qualified Data.Pool as Pool
import qualified GHC.Conc
import IHP.Postgres.Point
import IHP.Postgres.Polygon
import IHP.Postgres.Inet ()
import IHP.Postgres.TSVector
import IHP.Log.Types
import qualified IHP.Log as Log
import Data.Dynamic
import Data.Scientific
import GHC.Stack
import qualified Numeric
import qualified Data.Text.Encoding as Text
import qualified Data.ByteString.Builder as Builder

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

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

-- | Provides a mock ModelContext to be used when a database connection is not available
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext :: Logger -> ModelContext
notConnectedModelContext Logger
logger = ModelContext :: Pool Connection
-> Maybe Connection
-> Logger
-> Maybe (ByteString -> IO ())
-> Maybe RowLevelSecurityContext
-> 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
    , $sel:rowLevelSecurity:ModelContext :: Maybe RowLevelSecurityContext
rowLevelSecurity = Maybe RowLevelSecurityContext
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 trackTableReadCallback :: Maybe a
trackTableReadCallback = Maybe a
forall a. Maybe a
Nothing
    let transactionConnection :: Maybe a
transactionConnection = Maybe a
forall a. Maybe a
Nothing
    let rowLevelSecurity :: Maybe a
rowLevelSecurity = 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 ())
-> Maybe RowLevelSecurityContext
-> ModelContext
ModelContext { Maybe Connection
Maybe RowLevelSecurityContext
Maybe (ByteString -> IO ())
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
.. }

instance LoggingProvider ModelContext where
    getLogger :: ModelContext -> Logger
getLogger ModelContext { Maybe Connection
Maybe RowLevelSecurityContext
Maybe (ByteString -> IO ())
Logger
Pool Connection
rowLevelSecurity :: Maybe RowLevelSecurityContext
trackTableReadCallback :: Maybe (ByteString -> IO ())
logger :: Logger
transactionConnection :: Maybe Connection
connectionPool :: Pool Connection
$sel:rowLevelSecurity:ModelContext :: ModelContext -> Maybe RowLevelSecurityContext
$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
double = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Maybe Int -> Double -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
Numeric.showFFloat Maybe Int
forall a. Maybe a
Nothing Double
double [Char]
"")

instance InputValue Float where
    inputValue :: Float -> Text
inputValue Float
float = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Maybe Int -> Float -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
Numeric.showFFloat Maybe Int
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 = [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 TimeOfDay where
    inputValue :: TimeOfDay -> Text
inputValue TimeOfDay
timeOfDay = TimeOfDay -> Text
forall a. Show a => a -> Text
tshow TimeOfDay
timeOfDay

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 InputValue Scientific where
    inputValue :: Scientific -> Text
inputValue = Scientific -> Text
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 Double
forall a. Default a => a
def Double
forall a. Default a => a
def

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

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

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

type FieldName = ByteString

-- | Returns @True@ when the record has not been saved to the database yet. Returns @False@ otherwise.
--
-- __Example:__ Returns @True@ when a record has not been inserted yet.
--
-- >>> let project = newRecord @Project
-- >>> isNew project
-- True
--
-- __Example:__ Returns @False@ after inserting a record.
--
-- >>> project <- createRecord project
-- >>> isNew project
-- False
--
-- __Example:__ Returns @False@ for records which have been fetched from the database.
--
-- >>> book <- query @Book |> fetchOne
-- >>> isNew book
-- False
isNew :: forall model. (HasField "meta" model MetaBag) => model -> Bool
isNew :: model -> Bool
isNew model
model = model
model
        model -> (model -> MetaBag) -> MetaBag
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> 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
        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 -> Bool) -> Bool
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Maybe Dynamic -> Bool
forall a. Maybe a -> Bool
isNothing
{-# INLINABLE isNew #-}

type family GetModelName model :: Symbol

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

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

newtype Id' table = Id (PrimaryKey table)

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

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

instance InputValue (PrimaryKey model') => InputValue (Id' model') where
    {-# INLINE inputValue #-}
    inputValue :: Id' model' -> Text
inputValue = 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 (model :: Symbol). Id' model -> PrimaryKey model
unpackId

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

recordToInputValue :: (HasField "id" entity (Id entity), Show (PrimaryKey (GetTableName entity))) => entity -> Text
recordToInputValue :: 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 (model :: Symbol). Id' model -> PrimaryKey model
unpackId
    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 (model :: Symbol). Id' model -> PrimaryKey model
unpackId

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 (model :: Symbol). Id' model -> PrimaryKey model
unpackId

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

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

-- | Record type for objects of model types labeled with values from different database tables. (e.g. comments labeled with the IDs of the posts they belong to).
data LabeledData a b = LabeledData { LabeledData a b -> a
labelValue :: a, LabeledData a b -> b
contentValue :: b }
    deriving (Int -> LabeledData a b -> ShowS
[LabeledData a b] -> ShowS
LabeledData a b -> [Char]
(Int -> LabeledData a b -> ShowS)
-> (LabeledData a b -> [Char])
-> ([LabeledData a b] -> ShowS)
-> Show (LabeledData a b)
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 = label -> a -> LabeledData label a
forall a b. a -> b -> LabeledData a b
LabeledData (label -> a -> LabeledData label a)
-> RowParser label -> RowParser (a -> LabeledData label a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser label
forall a. FromField a => RowParser a
PGFR.field RowParser (a -> LabeledData label a)
-> RowParser a -> RowParser (LabeledData label a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser a
forall a. FromRow a => RowParser a
PGFR.fromRow

-- | Sometimes you have a hardcoded UUID value which represents some record id. This instance allows you
-- to write the Id like a string:
--
-- > let projectId = "ca63aace-af4b-4e6c-bcfa-76ca061dbdc6" :: Id Project
instance (Read (PrimaryKey model), ParsePrimaryKey (PrimaryKey model)) => IsString (Id' model) where
    fromString :: [Char] -> Id' model
fromString [Char]
uuid = [Char] -> Id' model
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 = [Char] -> Maybe UUID
forall a. Read a => [Char] -> Maybe a
Read.readMaybe ([Char] -> Maybe UUID) -> (Text -> [Char]) -> Text -> Maybe UUID
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs

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

-- | Transforms a text, bytestring or string into an Id. Throws an exception if the input is invalid.
--
-- __Example:__
--
-- > let projectIdText = "7cbc76e2-1c4f-49b6-a7d9-5015e7575a9b" :: Text
-- > let projectId = (textToId projectIdText) :: Id Project
--
-- In case your UUID value is hardcoded, there is also an 'IsString' instance, so you
-- can just write it like:
--
-- > let projectId = "ca63aace-af4b-4e6c-bcfa-76ca061dbdc6" :: Id Project
textToId :: (HasCallStack, 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 #-}

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

-- | Runs a raw sql query
--
-- __Example:__
--
-- > users <- sqlQuery "SELECT id, firstname, lastname FROM users" ()
--
-- Take a look at "IHP.QueryBuilder" for a typesafe approach on building simple queries.
--
-- *AutoRefresh:* When using 'sqlQuery' with AutoRefresh, you need to use 'trackTableRead' to let AutoRefresh know that you have accessed a certain table. Otherwise AutoRefresh will not watch table of your custom sql query.
--
sqlQuery :: (?modelContext :: ModelContext, PG.ToRow q, PG.FromRow r, 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 -> Query -> q -> IO [r] -> IO [r]
forall parameters a.
ToRow parameters =>
Query -> parameters -> IO a -> IO a
enhanceSqlError Query
theQuery q
theParameters do
            (Query -> [Action] -> IO [r]) -> Query -> q -> IO [r]
forall params result.
(?modelContext::ModelContext, ToRow params) =>
(Query -> [Action] -> result) -> Query -> params -> result
withRLSParams (Connection -> Query -> [Action] -> IO [r]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
connection) Query
theQuery q
theParameters
        )
        Query
theQuery
        q
theParameters
{-# INLINABLE sqlQuery #-}

-- | Runs a sql statement (like a CREATE statement)
--
-- __Example:__
--
-- > sqlExec "CREATE TABLE users ()" ()
sqlExec :: (?modelContext :: ModelContext, PG.ToRow q, Show q) => Query -> q -> IO Int64
sqlExec :: Query -> q -> IO Int64
sqlExec Query
theQuery q
theParameters = do
    IO Int64 -> Query -> q -> IO Int64
forall q a.
(?modelContext::ModelContext, Show q) =>
IO a -> Query -> q -> IO a
measureTimeIfLogging
        ((Connection -> IO Int64) -> IO Int64
forall a.
(?modelContext::ModelContext) =>
(Connection -> IO a) -> IO a
withDatabaseConnection \Connection
connection -> Query -> q -> IO Int64 -> IO Int64
forall parameters a.
ToRow parameters =>
Query -> parameters -> IO a -> IO a
enhanceSqlError Query
theQuery q
theParameters do
            (Query -> [Action] -> IO Int64) -> Query -> q -> IO Int64
forall params result.
(?modelContext::ModelContext, ToRow params) =>
(Query -> [Action] -> result) -> Query -> params -> result
withRLSParams (Connection -> Query -> [Action] -> 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 #-}

-- | Wraps the query with Row level security boilerplate, if a row level security context was provided
--
-- __Example:__
--
-- If a row level security context is given, this will turn a query like the following
--
-- > withRLSParams runQuery "SELECT * FROM projects WHERE id = ?" (Only "..")
--
-- Into the following equivalent:
--
-- > runQuery "SET LOCAL ROLE ?; SET LOCAL rls.ihp_user_id = ?; SELECT * FROM projects WHERE id = ?" ["ihp_authenticated", "<user id>", .."]
--
withRLSParams :: (?modelContext :: ModelContext, PG.ToRow params) => (PG.Query -> [PG.Action] -> result) -> PG.Query -> params -> result
withRLSParams :: (Query -> [Action] -> result) -> Query -> params -> result
withRLSParams Query -> [Action] -> result
runQuery Query
query params
params = do
    case Proxy "rowLevelSecurity"
-> ModelContext -> Maybe RowLevelSecurityContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "rowLevelSecurity" (Proxy "rowLevelSecurity")
Proxy "rowLevelSecurity"
#rowLevelSecurity ?modelContext::ModelContext
ModelContext
?modelContext 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 = ?; " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
query
            let params' :: [Action]
params' = [Identifier -> Action
forall a. ToField a => a -> Action
PG.toField (Text -> Identifier
PG.Identifier Text
rlsAuthenticatedRole), Action -> Action
forall a. ToField a => a -> Action
PG.toField Action
rlsUserId] [Action] -> [Action] -> [Action]
forall a. Semigroup a => a -> a -> a
<> params -> [Action]
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 (params -> [Action]
forall a. ToRow a => a -> [Action]
PG.toRow params
params)

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

-- | Runs a raw sql query which results in a single scalar value such as an integer or string
--
-- __Example:__
--
-- > usersCount <- sqlQueryScalar "SELECT COUNT(*) FROM users"
--
-- Take a look at "IHP.QueryBuilder" for a typesafe approach on building simple queries.
sqlQueryScalar :: (?modelContext :: ModelContext) => (PG.ToRow q, 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 -> Query -> q -> IO [Only value] -> IO [Only value]
forall parameters a.
ToRow parameters =>
Query -> parameters -> IO a -> IO a
enhanceSqlError Query
theQuery q
theParameters do
            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 #-}

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

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

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

-- | Returns the postgres connection when called within a 'withTransaction' block
--
-- Throws an error if called from outside a 'withTransaction'
transactionConnectionOrError :: (?modelContext :: ModelContext) => Connection
transactionConnectionOrError :: 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
    let ModelContext { Pool Connection
connectionPool :: Pool Connection
$sel:connectionPool:ModelContext :: ModelContext -> Pool Connection
connectionPool } = ?modelContext::ModelContext
ModelContext
?modelContext
    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
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 #-}

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

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

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

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

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

logQuery :: (?modelContext :: ModelContext, Show query, Show parameters) => query -> parameters -> NominalDiffTime -> IO ()
logQuery :: query -> parameters -> NominalDiffTime -> IO ()
logQuery query
query parameters
parameters NominalDiffTime
time = do
        let ?context = ?modelContext
        -- NominalTimeDiff is represented as seconds, and doesn't provide a FormatTime option for printing in ms.
        -- To get around that we convert to and from a rational so we can format as desired.
        let queryTimeInMs :: Double
queryTimeInMs = (NominalDiffTime
time NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000) NominalDiffTime -> (NominalDiffTime -> Rational) -> Rational
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational Rational -> (Rational -> Double) -> Double
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Fractional Double => Rational -> Double
forall a. Fractional a => Rational -> a
fromRational @Double
        let formatRLSInfo :: a -> a
formatRLSInfo a
userId = a
" { ihp_user_id = " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
userId a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" }"
        let rlsInfo :: Text
rlsInfo = case Proxy "rowLevelSecurity"
-> ModelContext -> Maybe RowLevelSecurityContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "rowLevelSecurity" (Proxy "rowLevelSecurity")
Proxy "rowLevelSecurity"
#rowLevelSecurity ?context::ModelContext
ModelContext
?context of
                Just RowLevelSecurityContext { $sel:rlsUserId:RowLevelSecurityContext :: RowLevelSecurityContext -> Action
rlsUserId = PG.Plain Builder
rlsUserId } -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
formatRLSInfo (ByteString -> Text
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 } -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
formatRLSInfo (Action -> Text
forall a. Show a => a -> Text
tshow Action
rlsUserId)
                Maybe RowLevelSecurityContext
Nothing -> Text
""
        Text -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> 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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rlsInfo)
{-# INLINABLE logQuery #-}

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

-- | Like 'deleteRecord' but using an Id
--
-- >>> let project :: Id Project = ...
-- >>> delete projectId
-- DELETE FROM projects WHERE id = '..'
--
deleteRecordById :: forall record table. (?modelContext :: ModelContext, Table record, ToField (PrimaryKey table), Show (PrimaryKey table), record ~ GetModelByTableName table) => Id' table -> IO ()
deleteRecordById :: Id' table -> IO ()
deleteRecordById Id' table
id = do
    let theQuery :: Text
theQuery = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table record => Text
forall record. Table record => Text
tableName @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = ?"
    let theParameters :: Only (Id' table)
theParameters = Id' table -> Only (Id' table)
forall a. a -> Only a
PG.Only Id' table
id
    Query -> Only (Id' table) -> 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' table)
theParameters
    () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE deleteRecordById #-}

-- | Runs a @DELETE@ query for a list of records.
--
-- >>> let projects :: [Project] = ...
-- >>> deleteRecords projects
-- DELETE FROM projects WHERE id IN (..)
deleteRecords :: forall record table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, HasField "id" record (Id' table), ToField (PrimaryKey table), record ~ GetModelByTableName table) => [record] -> IO ()
deleteRecords :: [record] -> IO ()
deleteRecords [record]
records =
    [Id' table] -> IO ()
forall record (table :: Symbol).
(?modelContext::ModelContext, Show (PrimaryKey table),
 Table record, ToField (PrimaryKey table),
 record ~ GetModelByTableName table) =>
[Id' table] -> IO ()
deleteRecordByIds @record ([record] -> [Id' table]
forall record id. HasField "id" record id => [record] -> [id]
ids [record]
records)
{-# INLINABLE deleteRecords #-}

-- | Like 'deleteRecordById' but for a list of Ids.
--
-- >>> let projectIds :: [ Id Project ] = ...
-- >>> delete projectIds
-- DELETE FROM projects WHERE id IN ('..')
--
deleteRecordByIds :: forall record table. (?modelContext :: ModelContext, Show (PrimaryKey table), Table record, ToField (PrimaryKey table), record ~ GetModelByTableName table) => [Id' table] -> IO ()
deleteRecordByIds :: [Id' table] -> IO ()
deleteRecordByIds [Id' table]
ids = do
    let theQuery :: Text
theQuery = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table record => Text
forall record. Table record => Text
tableName @record Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id IN ?"
    let theParameters :: Only (In [Id' table])
theParameters = (In [Id' table] -> Only (In [Id' table])
forall a. a -> Only a
PG.Only ([Id' table] -> In [Id' table]
forall a. a -> In a
PG.In [Id' table]
ids))
    Query -> Only (In [Id' table]) -> 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' table])
theParameters
    () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE deleteRecordByIds #-}

-- | Runs a @DELETE@ query to delete all rows in a table.
--
-- >>> deleteAll @Project
-- DELETE FROM projects
deleteAll :: forall record. (?modelContext :: ModelContext, Table record) => IO ()
deleteAll :: IO ()
deleteAll = do
    let theQuery :: Text
theQuery = Text
"DELETE FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table record => Text
forall record. Table record => 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 TimeOfDay where
    def :: TimeOfDay
def = Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
0 Int
0 Pico
0

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

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

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

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

class Record model where
    newRecord :: model

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

instance Exception RecordNotFoundException

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

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

instance Exception EnhancedSqlError

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


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

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

-- | Useful to manually mark a table read when doing a custom sql query inside AutoRefresh or 'withTableReadTracker'.
--
-- When using 'fetch' on a query builder, this function is automatically called. That's why you only need to call
-- it yourself when using 'sqlQuery' to run a custom query.
--
-- __Example:__
--
-- > action MyAction = autoRefresh do
-- >     users <- sqlQuery "SELECT * FROM users WHERE .."
-- >     trackTableRead "users"
-- >
-- >     render MyView { .. }
--
--
trackTableRead :: (?modelContext :: ModelContext) => ByteString -> IO ()
trackTableRead :: ByteString -> IO ()
trackTableRead ByteString
tableName = case Proxy "trackTableReadCallback"
-> ModelContext -> Maybe (ByteString -> IO ())
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "trackTableReadCallback" (Proxy "trackTableReadCallback")
Proxy "trackTableReadCallback"
#trackTableReadCallback ?modelContext::ModelContext
ModelContext
?modelContext of
    Just ByteString -> IO ()
callback -> ByteString -> IO ()
callback ByteString
tableName
    Maybe (ByteString -> IO ())
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINABLE trackTableRead #-}

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