module Internal.Control.Effects.Basic (module Internal.Control.Effects.Basic, module Control.Effects)
where
import Internal.Interlude hiding (Error)
import Control.Effects
import Database.PostgreSQL.Simple
import qualified Database.PostgreSQL.Simple.Types as PSQL
import Internal.Data.Basic.Types
import Internal.Data.Basic.Sql.Types
import Internal.Data.Basic.Compiler
import Control.Effects.Logging
import Control.Exception
import Control.Effects.Signal
import Control.Monad.Trans
newtype SqlRequest a = SqlRequest { getSqlRequest :: SqlExp } deriving Show
data Basic
instance Effect Basic where
data EffMethods Basic m = BasicMethods
{ _runSql :: forall a. FromRow a => SqlRequest a -> m [a]
, _executeSql :: SqlExp -> m () }
liftThrough (BasicMethods r e) = BasicMethods
(lift . r)
(lift . e)
mergeContext m = BasicMethods
(\a -> ($ a) . _runSql =<< m)
(\a -> ($ a) . _executeSql =<< m)
runSql :: MonadEffect Basic m => forall a. FromRow a => SqlRequest a -> m [a]
executeSql :: MonadEffect Basic m => SqlExp -> m ()
BasicMethods runSql executeSql = effect
data BasicException =
BasicFormatError FormatError
| BasicQueryError QueryError
| BasicResultError ResultError
| BasicSqlError SqlError
deriving (Eq, Show)
handleBasicPsqlWithLogging ::
forall m a. (MonadEffects '[Logging, Signal BasicException Query] m, MonadIO m)
=> Connection -> RuntimeImplemented Basic m a -> m a
handleBasicPsqlWithLogging conn = implement $
BasicMethods (queryOrExec query . sqlExpToQuery . getSqlRequest) (void . queryOrExec execute . sqlExpToQuery)
where
queryOrExec :: forall b. (forall q. ToRow q => Connection -> Query -> q -> IO b) -> QuerySegment -> m b
queryOrExec qe qs@(QuerySegment q as) = do
logDebug "Executing query"
& setDataToShowOf qs
& layerLogs (Context "data-basic")
& setTimestampToNow
eitherRes <- liftIO $
qe conn q as
& fmap Right
& handle (\(e :: FormatError) -> return $ Left (BasicFormatError e))
& handle (\(e :: QueryError) -> return $ Left (BasicQueryError e))
& handle (\(e :: ResultError) -> return $ Left (BasicResultError e))
& handle (\(e :: SqlError) -> return $ Left (BasicSqlError e))
case eitherRes of
Left e -> do
logError "Error while executing query" & setDataToShowOf e
q' <- signal e
queryOrExec qe (QuerySegment q' [])
Right res -> return res
throwBasicToIO :: forall m a. MonadIO m => ExceptT BasicException m a -> m a
throwBasicToIO = handleException throwBasicEx
where
throwBasicEx :: BasicException -> m a
throwBasicEx (BasicFormatError fe) = liftIO $ throwIO fe
throwBasicEx (BasicQueryError fe) = liftIO $ throwIO fe
throwBasicEx (BasicResultError fe) = liftIO $ throwIO fe
throwBasicEx (BasicSqlError fe) = liftIO $ throwIO fe
logOnlyErrors :: MonadEffect Logging m => RuntimeImplemented Logging m a -> m a
logOnlyErrors = filterLogs (\l -> originContext l /= Just (Context "data-basic") || logLevel l == Error)
handleBasicPsql ::
MonadIO m
=> Connection -> RuntimeImplemented Basic (RuntimeImplemented Logging (ExceptT BasicException m)) a -> m a
handleBasicPsql conn =
throwBasicToIO
. prettyPrintSummary 100
. handleBasicPsqlWithLogging conn
type family AllTables tables where
AllTables '[x] = x
AllTables (x ': xs) = x :. AllTables xs
class (FromRow (AllTables ts)) => AllHaveFromRowInstance ts where
compositeToTuple :: proxy ts -> AllTables ts -> DbResult ts
instance (FromRow a) => AllHaveFromRowInstance '[a] where
compositeToTuple _ = Entity
instance (FromRow a, FromRow b) => AllHaveFromRowInstance '[a, b] where
compositeToTuple _ (a :. b) = (Entity a, Entity b)
instance (FromRow a, FromRow b, FromRow c) => AllHaveFromRowInstance '[a, b, c] where
compositeToTuple _ (a :. b :. c) = (Entity a, Entity b, Entity c)
runDbStatement :: forall ts m f.
(AllHaveFromRowInstance ts, MonadEffect Basic m)
=> DbStatement f ts -> m [DbResult ts]
runDbStatement = fmap (map (compositeToTuple (Proxy @ts)))
. runSql
. SqlRequest
. compileToSql
executeDbStatement :: MonadEffect Basic m => DbStatement f ts -> m ()
executeDbStatement = executeSql . compileToSql
runAggregateStatement ::
forall aggr m.
( MonadEffect Basic m
, FromRow (AggregationResult aggr))
=> AggregateStatement aggr 'AM -> m (AggregationResult aggr)
runAggregateStatement =
fmap unsafeHead
. runSql
. SqlRequest
. aggregateStatementToSql
type family WithoutOnly a where
WithoutOnly (PSQL.Only a) = a
WithoutOnly a = a
class NoOnly a where
noOnly :: a -> WithoutOnly a
instance NoOnly (PSQL.Only a) where
noOnly (PSQL.Only a) = a
instance
WithoutOnly a ~ a
=> NoOnly a where
noOnly = identity
runMapStatement ::
forall res m f.
( MonadEffect Basic m
, FromRow res
, NoOnly res )
=> DbStatement f '[res] -> m [WithoutOnly res]
runMapStatement =
fmap (fmap (noOnly @res))
. runSql
. SqlRequest
. compileToSql