Initialization and reverse deinitialization in case of error

ComponentsPlayground.hs

{-# LANGUAGE RecordWildCards #-}
module Main where

import Control.Monad.Trans.Either
import Control.Monad.Trans.Maybe
import Control.Monad.State.Lazy
import Control.Monad.IO.Class
import Control.Monad

type InitComponentF = EitherT String IO ()

data Component = Component  { componentName      :: String
                            , initComponent      :: InitComponentF
                            , shutdownComponent  :: IO ()
                            }

instance Show Component where
    show Component{..} = "Component " ++ show componentName

mkInit :: String -> EitherT String IO ()
mkInit s = do
    liftIO $ putStrLn ("Initializing component: " ++ s)
    return ()

mkErrInit :: String -> EitherT String IO ()
mkErrInit s = do
    liftIO $ putStrLn ("The initialization of " ++ s ++ " FAILED.")
    left $ "Some specific error related to " ++ s

mkErrComponent :: String -> Component
mkErrComponent xs = mkComponent'' (mkErrInit xs) xs

mkComponent :: String -> Component
mkComponent xs = mkComponent'' (mkInit xs) xs

mkComponent'' :: InitComponentF -> String -> Component
mkComponent'' initF xs = let
    shut = putStrLn $ "Shutting down component: " ++ xs
    in
        Component xs initF shut


database        = mkComponent    "Database"
logging         = mkComponent    "Logging"
socketConn      = mkComponent    "SocketConn"
nativeResource  = mkErrComponent "NativeResource"

allOkComponents :: [Component]
allOkComponents = [database, logging, socketConn]

oneErrComponents :: [Component]
oneErrComponents = [database, logging, nativeResource, socketConn]

initSingle :: Component -> StateT [Component] (MaybeT IO) Component
initSingle c@Component{..} = do
    res <- liftIO $ runEitherT initComponent
    case res of
        Left xs -> do
            liftIO $ putStrLn ("An unexpected error ocurred: [" ++ xs ++ "]")
            deinitComponents =<< get
            mzero
        Right _ -> modify (c :) >> return c

deinitComponents :: MonadIO m => [Component] -> m ()
deinitComponents = liftIO . mapM_ shutdownComponent

initAll :: [Component] -> IO (Maybe [Component])
initAll xs = runMaybeT $ execStateT (mapM initSingle xs) []



main = do
    putStrLn "All components will be initialized:"
    initAll allOkComponents
    putStrLn "-----------------------------------"
    putStrLn "One component will fail, stopping the components bringup"
    putStrLn " additionally, the initialized components will be shutdown"
    putStrLn " in the reverse order of their initialization"
    initAll oneErrComponents
    return ()

HackageDependencies.txt

- either
- mtl
- transformers