{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Control.Monad.Component.Development
(
ComponentM
, runComponentDevel
, ComponentError (..)
, ComponentBuildError (..)
, ComponentEvent (..)
, Build
, buildElapsedTime
, buildFailure
, BuildResult
, toBuildList
)
where
import RIO
import Control.Monad.Component.Internal.Types
import Control.Teardown (Teardown,
emptyTeardown,
newTeardown,
runTeardown)
import Foreign.Store
devTeardownStoreNum :: Word32
devTeardownStoreNum = 0
runComponentDevel_
:: (ComponentEvent -> IO ())
-> Text
-> ComponentM a
-> (a -> IO b)
-> IO Teardown
runComponentDevel_ !logFn !appName (ComponentM buildFn) !appFn =
mask $ \restore -> do
result <- restore buildFn
case result of
Left (errList, buildTable) -> do
appTeardown <- buildTableToTeardown appName buildTable
teardownResult <- runTeardown appTeardown
restore $ logFn $ ComponentErrorDetected
(ComponentBuildFailed errList teardownResult)
return $ emptyTeardown "development"
Right (resource, buildTable) -> do
let buildList = buildTableToOrderedList buildTable
restore $ logFn $ ComponentBuilt $ BuildResult $ reverse buildList
appTeardown <- buildTableToTeardown appName buildTable
appAsync <- asyncWithUnmask $ \unmask -> unmask $ appFn resource
appAsyncTeardown <- newTeardown "application async"
(cancel appAsync :: IO ())
newTeardown "development" [appTeardown, appAsyncTeardown]
runComponentDevel
:: (ComponentEvent -> IO ())
-> Text
-> ComponentM a
-> (a -> IO b)
-> IO ()
runComponentDevel !logFn !appName !builder !appFn = do
mdevTeardownStore <- lookupStore devTeardownStoreNum
case mdevTeardownStore of
Nothing -> do
devTeardown <- runComponentDevel_ logFn appName builder appFn
writeStore (Store devTeardownStoreNum) devTeardown
Just devTeardownStore -> do
devTeardown0 <- readStore devTeardownStore
teardownResult <- runTeardown (devTeardown0 :: Teardown)
logFn $ ComponentReleased teardownResult
devTeardown <- runComponentDevel_ logFn appName builder appFn
writeStore (Store devTeardownStoreNum) devTeardown