componentm (empty) → 0.0.0.0

raw patch · 10 files changed

+1237/−0 lines, 10 filesdep +basedep +componentmdep +containerssetup-changed

Dependencies added: base, componentm, containers, deepseq, exceptions, prettyprinter, rio, tasty, tasty-hunit, teardown, time

Files

• CHANGELOG.md +15/−0
• LICENSE +13/−0
• README.md +99/−0
• Setup.hs +2/−0
• componentm.cabal +72/−0
• src/Control/Monad/Component.hs +182/−0
• src/Control/Monad/Component/Internal/Core.hs +183/−0
• src/Control/Monad/Component/Internal/Types.hs +299/−0
• test/tasty/ComponentTest.hs +357/−0
• test/tasty/TestSuite.hs +15/−0

@@ -0,0 +1,15 @@+Change log+==========++teardown uses [Semantic Versioning][1].+The change log is available [on GitHub][2].++[1]: http://semver.org/spec/v2.0.0.html+[2]: https://github.com/roman/Haskell-teardown/libraries/teardown/CHANGELOG.md++## v0.0.0.0++* Add `ComponentM` type, which supports `Monad` and `Applicative`+* Add `buildComponent` to build components in IO with attached cleanup functions+* Add `buildComponent_` to build components in IO without cleanup functions+* Add `withComponentM` to run an application

@@ -0,0 +1,13 @@+Copyright (c) 2017, Roman Gonzalez++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

@@ -0,0 +1,99 @@+# componentm++> An utility library to build multiple components (config, db, cache, logging,+> etc.) of an application in a traceable, reliable and efficient fashion++## Table Of Contents++* [Installation](#installation)+* [Purpose](#purpose)+ * [Differences with ResourceT](#differences-with-resourcet)+* [Development](#development)+* [Documentation](#documentation)+* [License](#license)++## Installation++[![Hackage](https://img.shields.io/hackage/v/componentm.svg)](https://img.shields.io/hackage/v/componentm.svg)+[![Stackage LTS](http://stackage.org/package/componentm/badge/lts)](http://stackage.org/lts/package/componentm)+[![Stackage Nightly](http://stackage.org/package/componentm/badge/nightly)](http://stackage.org/nightly/package/componentm)++Make sure you include the following entry on your [cabal file's+dependecies](https://www.haskell.org/cabal/users-guide/developing-packages.html#build-information)+section.++```cabal+library:+  build-depends: componentm+```++Or on your `package.yaml`++```+dependencies:+- componentm+```++## Purpose++This library is intended to be a high level API for the+[teardown](http://hackage.haskell.org/package/teardown) library; it provides a+high level monad interface that helps composition of resource+allocation/teardown in a safe and reliable way.++### Differences with ResourceT++The [resourcet](http://hackage.haskell.org/package/resourcet) library provides a+monad transformer that keeps track of allocated resources at runtime making sure+that if an exception happens or the block of execution finishes, the resources+allocated are cleaned up.++The [componentm](http://hackage.haskell.org/package/componentm) library on the+other hand, does not run as a Monad transformer, but rather it gets called at+the very beginning of your application, it builds the _environment_ needed by+your application environment to work (e.g. [Layer+1](http://www.parsonsmatt.org/2018/03/22/three_layer_haskell_cake.html)), and+provides helper _bracket style_ functions that cleanup all allocated resources+in the right order when your application terminates either normally or with an+error.++## Development+[![Build Status](https://travis-ci.org/roman/Haskell-componentm.svg?branch=master)](https://travis-ci.org/roman/Haskell-componentm)+[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/componentm.svg)](http://packdeps.haskellers.com/feed?needle=componentm)+[![Github](https://img.shields.io/github/commits-since/roman/haskell-componentm/v0.0.0.0.svg)](https://img.shields.io/github/commits-since/roman/haskell-componentm/v0.0.0.0.svg)++This library is intended to be minimal, providing a few functions that work+reliably among many different kind of projects. If you want to contribute, Pull+Request are very welcome! Please try to follow these simple rules:++* Please create a topic branch for every separate change you make.+* Update the README.md file if necessary.+* Please _do not_ change the version number on your Pull Request.++### Open Commit Bit++This project has an open commit bit policy: Anyone with an accepted pull request+gets added as a repository collaborator. Please try to follow these simple+rules:++* Commit directly onto the master branch only for typos, improvements to the+  README and documentation.+* Create a feature branch and open a pull-request early for any new features to+  get feedback.+* Make sure you adhere to the general pull request rules above.++## License++Copyright (c) 2017-2018 Roman Gonzalez++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,72 @@+cabal-version: >=1.10+name: componentm+version: 0.0.0.0+license: MIT+license-file: LICENSE+copyright: © 2017 Roman Gonzalez+maintainer: romanandreg@gmail.com+author: Roman Gonzalez+stability: alpha (experimental)+tested-with: ghc ==8.0.1 ghc ==8.0.2 ghc ==8.2.1+homepage: https://github.com/roman/Haskell-componentm#readme+bug-reports: https://github.com/roman/Haskell-componentm/issues+synopsis: Monad for allocation and cleanup of application resources+description:+    This library allows you to allocate resources with+    clean up strategies when initializing your application.+    It then provides a Monadic interface to compose multiple+    resources without having to deal with cleanup operations+    explicitely.+    .+    Check Control.Monad.Component.Tutorial for an example and+    more information.+category: System+build-type: Simple+extra-source-files:+    CHANGELOG.md+    README.md++source-repository head+    type: git+    location: https://github.com/roman/Haskell-componentm++library+    exposed-modules:+        Control.Monad.Component+    hs-source-dirs: src+    other-modules:+        Control.Monad.Component.Internal.Types+        Control.Monad.Component.Internal.Core+    default-language: Haskell2010+    ghc-options: -Wall -Wincomplete-uni-patterns+                 -Wincomplete-record-updates+    build-depends:+        base >=4.8 && <5,+        containers >=0.5.11.0,+        deepseq >=1.4.3.0,+        exceptions >=0.8.3,+        prettyprinter >=1.2.0.1,+        rio >=0.0.3,+        teardown >=0.3,+        time >=1.8.0.2++test-suite componentm-tests+    type: exitcode-stdio-1.0+    main-is: TestSuite.hs+    hs-source-dirs: test/tasty+    other-modules:+        ComponentTest+        Paths_componentm+    default-language: Haskell2010+    ghc-options: -Wall -Wincomplete-uni-patterns+                 -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        base >=4.8 && <5,+        componentm -any,+        containers >=0.5.11.0,+        prettyprinter >=1.2.0.1,+        rio >=0.0.3,+        tasty >=1.0.1.1,+        tasty-hunit >=0.10.0.1,+        teardown >=0.3,+        time >=1.8.0.2

@@ -0,0 +1,182 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-|+Module      : Control.Monad.Component+Description : Sane resource allocation library for complex applications+Copyright   : (c) Roman Gonzalez, 2017-2018+License     : MIT+Maintainer  : open-source@roman-gonzalez.info+Stability   : experimental++= Why use 'ComponentM'?++'ComponentM' values wraps vanilla 'IO' sub-routines whose responsibility is to+allocate resources that your application may need (e.g. database connections,+tcp sockets, etc). Your program will execute these 'ComponentM' sub-routines at+the beginning of it's lifecyle, building an environment that your main+application needs in order to work as intended.++By using 'ComponentM' sub-routines your program will automatically:++* Compose the cleanup sub-routines of all your allocated resources++* Keep track of initialization time for each resource needed in your application++* Keep track of teardown time for each resources needed in your application.++* Isolate the teardown of each resource in your application, ensuring no thrown+  exception will affect the cleanup of resources.++* Initialize resources concurrently when using 'Applicative' notation++* Build a dependency graph of your application resources when using+  'Applicative' or 'Monad' notation; and then guarantees the execution of+  cleanup operations in a topological sorted order++* Make sure that previously allocated resources are cleaned up when a resource+  throws an exception on initialization++* Report all exceptions thrown on each resource teardown++* Document (through types) what is the purpose of some of the 'IO' sub-routines+  in your program++These properties are crucial when applications need to run for long periods of+time and they are reloaded (without a process restart). It also ensures that+resources are cleaned tightly when doing REPL driven development through GHCi.++-}+module Control.Monad.Component+  (++  -- * How to build 'ComponentM' values+  -- $howto_componentm_values+    buildComponent+  , buildComponent_++  -- * Making 'ComponentM' values useful+  -- $monad_and_runners+  , ComponentM+  , runComponentM+  , runComponentM1+++  -- * Error Records+  -- $errors+  , ComponentError (..)+  , ComponentBuildError (..)+++  -- * 'ComponentM' tracing accessors+  , ComponentEvent (..)+  , Build+  , buildElapsedTime+  , buildFailure+  , BuildResult+  , toBuildList+++  -- * Re-exports+  , TeardownResult (..)+  , throwM++  ) where++import           Control.Monad.Catch                    (throwM)+import           Control.Monad.Component.Internal.Core  (buildComponent,+                                                         buildComponent_,+                                                         runComponentM,+                                                         runComponentM1)+import           Control.Monad.Component.Internal.Types (Build (..),+                                                         BuildResult (..),+                                                         ComponentBuildError (..),+                                                         ComponentError (..),+                                                         ComponentEvent (..),+                                                         ComponentM)+import           Control.Teardown                       (TeardownResult (..))++{- $howto_componentm_values++'ComponentM' values are built from vanilla 'IO' sub-routines that allocate resources, the+two functions provided are:++['buildComponent_']: Used when a component in your application does not allocate+  a resource++['buildComponent']: Used when a component in your application allocates a+  resource and requires a cleanup on teardown++Following is an example on how to++@+{-# LANGUAGE PackageImports #-}+import "sqlite-simple" qualified Database.SQLite.Simple as SQLite+import "componentm" Control.Monad.Component (ComponentM, buildComponent, buildComponent_)++-- | App environment record+data AppEnv = AppEnv { appDb :: !SQLite.Connection }++-- | Configuration record+data Config = Config { dbPath :: !String }++readConfig :: IO Config+readConfig =+  -- NOTE: Here we would have a more sophisticated algorithm for fetching+  -- configuration values for our app+  return (Config ":memory:")++configComponent :: ComponentM AppConfig+configComponent = buildComponent_ "Config" $ do+  readConfigFile "./resources/config.yml"++dbComponent :: FilePath -> ComponentM SQLite.Connection+dbComponent dbPath =+  buildComponent "Database" (SQLite.open dbPath) SQLite.close++buildAppEnv :: ComponentM AppEnv+buildAppEnv = do+  config <- configComponent+  AppEnv <$> dbComponent (dbPath config)++@++In the previous example, we use both 'buildComponent_' and 'buildComponent' to+create different components that our application needs.++-}++{- $monad_and_runers++To execute our 'ComponentM' sub-routines, we can use two different functions+'runComponentM' or 'runComponentM1'; following is an example:+++@+appMain :: AppEnv -> IO ()+appMain = error "pending"++main :: IO ()+main =+  runComponentM1+    -- Our logging function+    print+    -- The name of our application+    "my-fancy-application"+    -- The 'ComponentM' sub-routine that builds the 'AppEnv'+    buildAppEnv+    -- Our main application runs here+    appMain+@++-}++{- $errors++There are two possible failures that the 'runComponentM' functions can thrown++['ComponentBuildFailed']: This error happens when allocation of some component's+resource fails++['ComponentRuntimeFailed']: This error happens when there is an exception thrown+from our main application callback++-}

@@ -0,0 +1,183 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Control.Monad.Component.Internal.Core+  ( buildComponent+  , buildComponent_+  , runComponentM+  , runComponentM1+  ) where++import           RIO+import           RIO.Time                               (NominalDiffTime,+                                                         diffUTCTime,+                                                         getCurrentTime)++import qualified RIO.HashMap                            as HashMap+import qualified RIO.Set                                as Set++import           Control.Monad.Component.Internal.Types+import           Control.Teardown                       (emptyTeardown,+                                                         newTeardown,+                                                         runTeardown)++--------------------------------------------------------------------------------++-- | Track duration time of the execution of an IO sub-routine+trackExecutionTime :: IO a -> IO (NominalDiffTime, a)+trackExecutionTime routine = do+  start  <- getCurrentTime+  result <- routine+  end    <- getCurrentTime+  return (diffUTCTime end start, result)++-- | Transforms an `IO` sub-routine into a `ComponentM` sub-routine; the given+-- `IO` sub-routine returns a resource that does not allocate any other+-- resources that would need to be cleaned up on a system shutdown.+--+-- This is similar to using 'liftIO', with the caveat that the library will+-- register the given 'IO' sub-routine as a Component, and it will keep track+-- and report its initialization timespan+--+buildComponent_ :: Text -> IO a -> ComponentM a+buildComponent_ !componentDesc ma = ComponentM $ mask $ \restore -> do+  (buildElapsedTime, result) <- trackExecutionTime (try $ restore ma)+  case result of+    Left err -> do+      let build = Build+            { componentDesc+            , componentTeardown = emptyTeardown componentDesc+            , buildElapsedTime+            , buildFailure      = Just err+            , buildDependencies = Set.empty+            }+          buildTable = HashMap.singleton componentDesc build+      return $ Left ([ComponentAllocationFailed componentDesc err], buildTable)++    Right output -> do+      let build = Build+            { componentDesc+            , componentTeardown = emptyTeardown componentDesc+            , buildElapsedTime+            , buildFailure      = Nothing+            , buildDependencies = Set.empty+            }+          buildTable = HashMap.singleton componentDesc build+      return $ Right (output, buildTable)++-- | Use this function when you want to allocate a new resource (e.g. Database,+-- Socket, etc). It registers the constructed resource in your application+-- component tree and guarantees that its cleanup sub-routine is executed at the+-- end of your program.+--+-- This function is similar to the 'bracket' function with the caveat that it+-- expects a 'Text' argument which identifies the component being allocated.+--+-- NOTE: The name of your component must be unique; otherwise a+-- 'DuplicatedComponentKeyDetected' will be thrown+--+buildComponent+  :: Text         -- ^ Unique name for the component being allocated+  -> IO a         -- ^ Allocation 'IO' sub-routine+  -> (a -> IO ()) -- ^ Cleanup 'IO' sub-routine+  -> ComponentM a+buildComponent !componentDesc construct release =+  ComponentM $ mask $ \restore -> do++    (buildElapsedTime, (result, componentTeardown)) <- trackExecutionTime+      $ startComponent restore++    let buildFailure = either (Just . toException) (const Nothing) result++        build        = Build+          { componentDesc+          , componentTeardown+          , buildElapsedTime+          , buildFailure+          , buildDependencies = Set.empty+          }++        buildTable = HashMap.singleton componentDesc build++    case result of+      Left  err      -> return $ Left ([err], buildTable)+      Right resource -> return $ Right (resource, buildTable)+ where+  startComponent restore = do+    result <- restore (try construct)+    case result of+      Left err -> return+        ( Left $ ComponentAllocationFailed componentDesc err+        , emptyTeardown componentDesc+        )+      Right resource -> do+        resourceTeardown <- newTeardown componentDesc (release resource)+        return (Right resource, resourceTeardown)++-- | Enhances 'runComponentM' with a callback function that emits+-- 'ComponentEvent' records. These events are a great way of tracing the+-- lifecycle and structure of your application.+runComponentM1+  :: (ComponentEvent -> IO ()) -- ^ Callback function to trace 'ComponentEvent' records+  -> Text                      -- ^ Name of your application (used for tracing purposes)+  -> ComponentM a              -- ^ Builder of your application environment+  -> (a -> IO b)               -- ^ Function where your main application will live+  -> IO b+runComponentM1 !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 $ ComponentReleased teardownResult+        throwIO $ ComponentBuildFailed errList teardownResult++      Right (resource, buildTable) -> do+        let buildList = buildTableToOrderedList buildTable+        restore $ logFn $ ComponentBuilt $ BuildResult $ reverse buildList++        appTeardown    <- buildTableToTeardown appName buildTable+        appResult      <- tryAny $ restore $ appFn resource+        teardownResult <- runTeardown appTeardown+        restore $ logFn $ ComponentReleased teardownResult++        case appResult of+          Left appError ->+            throwIO $ ComponentRuntimeFailed appError teardownResult+          Right output -> return output++-- | Constructs the /environment/ of your application by executing the 'IO'+-- sub-routines provided in the 'buildComponent' and 'buildComponent_'+-- functions; it then executes a callback where your main application will run.+--+-- This function:+--+-- * Keeps track of initialization elapsed time for each component of your+--   application+--+-- * Initializes components concurrently as long as they are composed using+--   'Applicative' functions+--+-- * Builds a graph of your dependencies automatically when composing your+--   'ComponentM' values via 'Applicative' or 'Monad' interfaces; it then+--   guarantees the execution of cleanup operations in a topological sorted+--   order+--+-- * Guarantees the proper cleanup of previously allocated resources if the+--   creation of a resource throws an exception on initialization+--+-- * Guarantees best-effort cleanup of resources on application teardown in the+--   scenario where a cleanup sub-routine throws an exception+--+-- * Keeps track of teardown elasped time for each component of your+--   application; and reports what exceptions was thrown in case of failures+--+-- If you want to trace the behavior of your application on initialization and+-- teardown, use 'runComponentM1' instead+runComponentM+  :: Text           -- ^ Name of your application (used for tracing purposes)+  -> ComponentM a   -- ^ Builder of your application environment+  -> (a -> IO b)    -- ^ Function where your main application will live+  -> IO b+runComponentM = runComponentM1 (const $ return ())

@@ -0,0 +1,299 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Control.Monad.Component.Internal.Types+  ( ComponentError (..)+  , ComponentBuildError (..)+  , ComponentM (..)+  , Build (..)+  , BuildResult (..)+  , TeardownResult+  , ComponentEvent (..)+  , buildTableToOrderedList+  , buildTableToTeardown+  ) where++import           RIO+import qualified RIO.HashMap               as M.Hash+import qualified RIO.Set                   as S+import           RIO.Time                  (NominalDiffTime)++import           Data.Text.Prettyprint.Doc (Pretty, pretty, (<+>))+import qualified Data.Text.Prettyprint.Doc as Pretty++import           Control.Monad.Catch       (MonadThrow (..))+import           Data.Graph                (graphFromEdges', topSort)++import           Control.Teardown          (Teardown, TeardownResult,+                                            newTeardown)++--------------------------------------------------------------------------------++-- | Exception thrown by the 'runComponentM' family of functions+data ComponentError+    -- | Failure raised when the Application Callback given to a 'runComponentM'+    -- function throws an exception+  = ComponentRuntimeFailed+    {+      -- | Exception that was originally thrown by the Application Callback+      componentErrorOriginalException :: !SomeException+      -- | Result from the execution allocated resources teardown+    , componentErrorTeardownResult    :: !TeardownResult+    }+    -- | Failure raised when execution of 'ComponentM' throws an exception+  | ComponentBuildFailed+    {+      -- | Exceptions thrown by 'IO' sub-routines used when constructing+      -- 'ComponentM' values (e.g. 'buildComponent')+      componentErrorBuildErrors    :: ![ComponentBuildError]+      -- | Result from the execution allocated resources teardown+    , componentErrorTeardownResult :: !TeardownResult+    }+  deriving (Generic, Show)++instance Exception ComponentError++-- | Exception raised on the execution of 'IO' sub-routines used when+-- constructing 'ComponentM' values (e.g. 'buildComponent')+data ComponentBuildError+  -- | Failure thrown when using the same component key on a Component composition+  = DuplicatedComponentKeyDetected !Description+  -- | Failure thrown when the allocation sub-routine of a Component fails with an exception+  | ComponentAllocationFailed !Description !SomeException+  -- | Failure thrown when calling the 'throwM' when composing 'ComponentM' values+  | ComponentErrorThrown !SomeException+  -- | Failure thrown when calling 'liftIO' fails with an exception+  | ComponentIOLiftFailed !SomeException+  deriving (Generic, Show)++instance Exception ComponentBuildError++type Description = Text++-- | Contains metadata about the build of a resource from a 'ComponentM' value+data Build+  = Build {+      -- | Name of the component built+      componentDesc     :: !Description+      -- | Cleanup sub-routine of the component built+    , componentTeardown :: !Teardown+      -- | Elasped time in the allocation of a component resource+    , buildElapsedTime  :: !NominalDiffTime+      -- | Error thrown in the allocation of a component resource+    , buildFailure      :: !(Maybe SomeException)+      -- | What other components this build depends on+    , buildDependencies :: !(Set Description)+    }+  deriving (Generic)++instance Pretty Build where+  pretty Build {componentDesc, buildElapsedTime, buildFailure} =+    let+      statusSymbol :: Text+      statusSymbol = if isJust buildFailure then "✘" else "✓"++      errorInfo =+        if isJust buildFailure then+          [+            Pretty.hardline+          , Pretty.pipe <+> pretty (show buildFailure)+          ]+        else+          []++    in+      Pretty.hang 2+          $ Pretty.hsep+          $ [ pretty statusSymbol+            , pretty componentDesc+            , Pretty.parens (pretty $ show buildElapsedTime)+            ] <> errorInfo+++instance Display Build where+  display = displayShow . pretty++type BuildTable = HashMap Description Build++-- | Wraps a collection of 'Build' records+newtype BuildResult+  = BuildResult { toBuildList :: [Build] }++instance Pretty BuildResult where+  pretty (BuildResult builds) =+      pretty ("Application Initialized" :: Text)+      <> Pretty.hardline+      <> Pretty.vsep (map pretty builds)++instance Display BuildResult where+  display buildResult =+    displayShow $ pretty buildResult++-- | An event record used to trace the execution of an application+-- initialization and teardown+data ComponentEvent+  = ComponentBuilt !BuildResult+  | ComponentReleased !TeardownResult++instance Pretty ComponentEvent where+  pretty ev =+    case ev of+      ComponentBuilt buildResult ->+        pretty buildResult+      ComponentReleased teardownResult ->+        "Application Teardown"+        <> Pretty.hardline+        <> pretty teardownResult++instance Display ComponentEvent where+  display = displayShow . pretty++--------------------++-- | Represents the construction of a Component in your application, components+-- may be composed using a 'Monad' or 'Applicative' interface.+newtype ComponentM a+  = ComponentM (IO (Either ([ComponentBuildError], BuildTable)+                           (a, BuildTable)))++--------------------++instance Functor ComponentM where+  fmap f (ComponentM action) =+    ComponentM $ do+      result <- action+      return $! case result of+        Left err ->+          Left err+        Right (a, builds) ->+          Right (f a, builds)++--------------------++validateKeyDuplication+  :: Monad m+  => (HashMap Text v -> HashMap Text v -> HashMap Text v)+  -> HashMap Text v+  -> HashMap Text v+  -> m+       ( Either+           ([ComponentBuildError], HashMap Text v)+           (HashMap Text v)+       )+validateKeyDuplication mergeFn a b =+  case M.Hash.keys $ M.Hash.intersection a b of+    []   -> return $ Right (mergeFn a b)+    keys -> do+      let errors = map DuplicatedComponentKeyDetected keys+      return (Left (errors, M.Hash.union a b))++instance Applicative ComponentM where+  pure a = ComponentM $+    return $ Right (a, M.Hash.empty)++  (<*>) (ComponentM cf) (ComponentM ca) = ComponentM $ do+    -- NOTE: We do not handle IO errors here because they are being managed in+    -- the leafs; we don't expose the constructor of ComponentM+    let validateKeys =+          validateKeyDuplication M.Hash.union++    (rf, ra) <- concurrently cf ca+    case (rf, ra) of+      (Right (f, depsF), Right (a, depsA)) ->+        validateKeys depsF depsA >>= \case+          Right deps  -> return $ Right (f a, deps)+          Left (errors, deps) -> return $ Left (errors, deps)+++      (Right (_, depsF), Left (errA, depsA)) ->+        validateKeys depsF depsA >>= \case+          Right deps -> return $ Left (errA, deps)+          Left (errors, deps) -> return $ Left (errA <> errors, deps)++      (Left (errF, depsF), Right (_, depsA)) ->+        validateKeys depsF depsA >>= \case+          Right deps -> return $ Left (errF, deps)+          Left (errors, deps) -> return $ Left (errF <> errors, deps)++      (Left (errF, depsF), Left (errA, depsA)) ->+        validateKeys depsF depsA >>= \case+          Right deps -> return $ Left (errF <> errA, deps)+          Left (errors, deps) -> return $ Left (errF <> errA <> errors, deps)++--------------------++appendDependency :: Description -> Build -> Build+appendDependency depDesc build =+  build { buildDependencies = S.insert depDesc (buildDependencies build) }++appendDependencies :: BuildTable -> BuildTable -> BuildTable+appendDependencies fromBuildTable toBuildTable =+  let appendDependenciesToBuild build =+        foldr appendDependency build (M.Hash.keys fromBuildTable)+  in+    -- First, we add all keys from fromBuildTable to all entries of toBuildTable+    -- Then, we join both fromBuildTable and toBuildTable+      M.Hash.map appendDependenciesToBuild toBuildTable+        & M.Hash.union fromBuildTable++instance Monad ComponentM where+  return = pure+  (>>=) (ComponentM ma) f = ComponentM $ do+    let validateKeys =+          validateKeyDuplication appendDependencies++    resultA <- ma+    case resultA of+      Left (errA, depsA) ->+        return $ Left (errA, depsA)++      Right (a, depsA) -> do+        let (ComponentM mb) = f a+        resultB <- mb++        case resultB of+          Left (errB, depsB) ->+            validateKeys depsA depsB >>= \case+              Right deps -> return $ Left (errB, deps)+              Left (errors, deps) -> return $ Left (errB <> errors, deps)++          Right (b, depsB) ->+            validateKeys depsA depsB >>= \case+              Right deps -> return $ Right (b, deps)+              Left (errors, deps) -> return $ Left (errors, deps)++instance MonadThrow ComponentM where+  throwM e =+    ComponentM+      $ return+      $ Left ([ComponentErrorThrown $ toException e], M.Hash.empty)++instance MonadIO ComponentM where+  liftIO action = ComponentM $ do+    eresult <- try action+    case eresult of+      Left err -> return $ Left ([ComponentIOLiftFailed err], M.Hash.empty)+      Right a  -> return $ Right (a, M.Hash.empty)+++--------------------------------------------------------------------------------++buildTableToOrderedList :: BuildTable -> [Build]+buildTableToOrderedList buildTable =+  let buildGraphEdges :: [(Build, Description, [Description])]+      buildGraphEdges = M.Hash.foldrWithKey+        (\k build acc -> (build, k, S.toList $ buildDependencies build) : acc)+        []+        buildTable++      (componentGraph, lookupBuild) = graphFromEdges' buildGraphEdges+  in  map+        (\buildIndex -> let (build, _, _) = lookupBuild buildIndex in build)+        (topSort componentGraph)++buildTableToTeardown :: Text -> BuildTable -> IO Teardown+buildTableToTeardown appName buildTable = newTeardown+  appName+  (map componentTeardown $ buildTableToOrderedList buildTable)

@@ -0,0 +1,357 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module ComponentTest where++import           Control.Exception       (ErrorCall (..), MaskingState (..),+                                          getMaskingState)+import           RIO++import           Test.Tasty              (TestTree, testGroup)+import           Test.Tasty.HUnit++import qualified Control.Monad.Component as SUT+import           Control.Teardown        (toredownCount)+++tests :: TestTree+tests = testGroup+  "ComponentM"+  [ testGroup+    "Async Exceptions"+    [ testCase "it releases previously allocated resources" $ do+        callCountRef <- newIORef (0 :: Int)++        let alloc = do+              modifyIORef callCountRef (+ 1)+              return ()+            release         = const $ return ()++            componentOne    = SUT.buildComponent "one" alloc release++            componentTwo    = SUT.buildComponent "two" alloc release++            componentThree  = SUT.buildComponent_ "three" (threadDelay 10100100)++            componentAction = do+              componentOne+              componentTwo+              componentThree++        resultAsync <- async $ SUT.runComponentM "test application"+                                                 componentAction+                                                 (const $ return ())++        threadDelay 500+        cancel resultAsync++        result <- waitCatch resultAsync+        case result of+          Left _err -> do+            callCount <- readIORef callCountRef+            assertEqual "teardown action got called more than once" 2 callCount++          Right _ -> assertFailure "expecting failure; got success instead"+    ]+  , testGroup+    "Sync Exceptions"+    [ testCase "it releases previously allocated resources" $ do+      callCountRef <- newIORef (0 :: Int)++      let+        alloc = do+          modifyIORef callCountRef (+ 1)+          return ()+        release        = const $ return ()++        componentOne   = SUT.buildComponent "one" alloc release++        componentTwo   = SUT.buildComponent "two" alloc release++        componentThree = SUT.buildComponent+          "three"+          (throwIO (ErrorCall "failing three"))+          release++        componentFour =+          SUT.buildComponent_ "four" (throwIO $ ErrorCall "failing four")++        componentAction = do+          componentOne+          void componentTwo+          void componentThree+          componentFour++      result <- try $ SUT.runComponentM "test application"+                                        componentAction+                                        (const $ return ())+      case result of+        Left (SUT.ComponentBuildFailed _appErr teardownResult) -> do+          callCount <- readIORef callCountRef+          assertEqual "got more than one two valid components" 2 callCount++          -- 1. component one+          -- 2. component two+          -- 3. allocated component three (notice, error happens once allocation is done)+          assertEqual "There should be three toredown resources"+                      3+                      (toredownCount teardownResult)++        _ ->+          assertFailure $ "expected error, but did not happen, " <> show result+    , testCase "component construction allows throwM calls" $ do+      callCountRef <- newIORef (0 :: Int)++      let alloc = do+            modifyIORef callCountRef (+ 1)+            return ()+          release         = const $ return ()++          componentOne    = SUT.buildComponent "one" alloc release++          componentTwo    = SUT.buildComponent "two" alloc release++          componentAction = do+            componentOne+            void $ throwM (ErrorCall "failing via MonadThrow")+            componentTwo++      result <- try+        $ SUT.runComponentM "test application" componentAction return+      case result of+        Left (SUT.ComponentBuildFailed [SUT.ComponentErrorThrown err] _teardownResult)+          -> do+            callCount <- readIORef callCountRef+            assertEqual "expected introduced error, got different one"+                        (Just $ ErrorCall "failing via MonadThrow")+                        (fromException err)+            assertEqual "teardown action got called more than once" 1 callCount++        Left err ->+          assertFailure+            $  "expected ComponentStartupFailure exception, got instead: "+            <> show err++        Right _ -> assertFailure "expected error, but did not happen"+    ]+  , testGroup+    "Masking"+    [ testCase "app callback is _always_ on unmasked state" $ do+        maskingVar <- newEmptyMVar+        let alloc = return ()+            release _ = getMaskingState >>= putMVar maskingVar+            componentOne = SUT.buildComponent "one" alloc release++        SUT.runComponentM "app" componentOne return+        masking <- takeMVar maskingVar++        assertEqual "App callback is always in unmasked state"+                    MaskedUninterruptible+                    masking+    ]+  , testGroup+    "Duplicate component names"+    [ testCase "fails with an exception" $ do+        callCountRef <- newIORef (0 :: Int)++        let alloc = do+              modifyIORef callCountRef (+ 1)+              return ()+            release         = const $ return ()++            componentOne    = SUT.buildComponent "one" alloc release++            componentTwo    = SUT.buildComponent "two" alloc release++            componentThree  = SUT.buildComponent_ "three" (return ())+++            componentAction = do+              componentOne+              void componentTwo+              void componentThree+              void componentThree++        result <- try $ SUT.runComponentM "test application"+                                          componentAction+                                          (const $ return ())+        case result of+          Left (SUT.ComponentBuildFailed appErr teardownResult) -> do+            callCount <- readIORef callCountRef+            case appErr of+              [SUT.DuplicatedComponentKeyDetected componentName] -> assertEqual+                "should report duplicated component name"+                "three"+                componentName+              _ ->+                assertFailure+                  $  "expecting single component build error error; got: "+                  <> show appErr++            assertEqual "got more than one two valid components" 2 callCount++            -- 1. component one+            -- 2. component two+            -- 3. allocated component three (notice, error happens once allocation is done)+            assertEqual "There should be three toredown resources"+                        3+                        (toredownCount teardownResult)++          _ -> assertFailure "expected error, but did not happen"+    ]+  , testGroup+    "Monad"+    [ testCase "aggregates multiple component teardown values" $ do+      callCountRef <- newIORef (0 :: Int)++      let alloc = do+            modifyIORef callCountRef (+ 1)+            return ()+          release         = const $ return ()++          componentOne    = SUT.buildComponent "one" alloc release++          componentTwo    = SUT.buildComponent "two" alloc release++          componentThree  = SUT.buildComponent_ "three" $ return ()++          componentAction = do+            componentOne+            componentTwo+            componentThree++      _result <- SUT.runComponentM "test application"+                                   componentAction+                                   (const $ return ())++      callCount <- readIORef callCountRef+      assertEqual "teardown action got called more than once" 2 callCount+    , testCase "initializes components sequentially on the same thread" $ do+      let componentOne    = SUT.buildComponent_ "one" myThreadId++          componentTwo    = SUT.buildComponent_ "two" myThreadId++          componentThree  = SUT.buildComponent_ "three" myThreadId++          componentAction = do+            t1 <- componentOne+            t2 <- componentTwo+            t3 <- componentThree+            return (t1, t2, t3)+++      (t1, t2, t3) <- SUT.runComponentM "test application"+                                        componentAction+                                        return++      assertBool "expecting t1 to be equal to t2" (t1 == t2)+      assertBool "expecting t2 to be equal to t3" (t2 == t3)+    ]+  , testGroup+    "Applicative"+    [ testCase "reports multiple failures" $ do+      callCountRef <- newIORef (0 :: Int)++      let+        alloc = do+          modifyIORef callCountRef (+ 1)+          return ()+        release      = const $ return ()++        componentOne = SUT.buildComponent "one" alloc release++        componentTwo =+          SUT.buildComponent_ "two" $ throwIO (ErrorCall "failing two")++        componentThree = SUT.buildComponent+          "three"+          (throwIO (ErrorCall "failing three"))+          release++        componentAction = componentOne *> componentTwo *> componentThree++      result <- try+        $ SUT.runComponentM "test application" componentAction return+      case result of+        Left (SUT.ComponentBuildFailed [SUT.ComponentAllocationFailed _desc2 err2, SUT.ComponentAllocationFailed _desc3 err3] _teardownResult)+          -> do++            assertEqual "expected introduced error, got different one"+                        (Just $ ErrorCall "failing two")+                        (fromException err2)++            assertEqual "expected introduced error, got different one"+                        (Just $ ErrorCall "failing three")+                        (fromException err3)++            callCount <- readIORef callCountRef+            assertEqual "teardown action got called more than once" 1 callCount++        Left err ->+          assertFailure+            $ "expected ComponentStartupFailure exception with two errors, got instead: "+            <> show err++        Right _ -> assertFailure "expected error, but did not happen"+    , testCase "initializes components concurrently" $ do+      let+        componentOne   = SUT.buildComponent_ "one" myThreadId++        componentTwo   = SUT.buildComponent_ "two" myThreadId++        componentThree = SUT.buildComponent_ "three" myThreadId++        componentAction =+          (,,) <$> componentOne <*> componentTwo <*> componentThree+++      (t1, t2, t3) <- SUT.runComponentM "test application"+                                        componentAction+                                        return++      assertBool "expecting t1 to be different than t2" (t1 /= t2)+      assertBool "expecting t2 to be different than t3" (t2 /= t3)+      assertBool "expecting t1 to be different than t3" (t1 /= t3)+    ]+  , testGroup+    "MonadIO"+    [ testCase "wraps IO exceptions with info" $ do+        callCountRef <- newIORef (0 :: Int)++        let alloc   = return ()+            release = const $ do+              modifyIORef callCountRef (+ 1)+              return ()++            componentOne    = SUT.buildComponent "one" alloc release++            componentTwo    = SUT.buildComponent_ "two" $ return ()++            componentAction = do+              componentOne+              void $ liftIO $ throwIO (ErrorCall "failing on liftIO")+              componentTwo++        result <- try+          $ SUT.runComponentM "test application" componentAction return+        case result of+          Left (SUT.ComponentBuildFailed [SUT.ComponentIOLiftFailed ex] teardownResult)+            -> do+              releaseCount <- readIORef callCountRef+              assertEqual+                "should have called the release of component one, but didn't"+                1+                releaseCount+              assertEqual+                "should have called the release of component one, but didn't"+                1+                (toredownCount teardownResult)+              assertEqual "should have reported the liftIO error, but didn't"+                          (Just $ ErrorCall "failing on liftIO")+                          (fromException ex)+          _ ->+            assertFailure+              $  "expecting to get component build failed error, got instead: "+              <> show result+    ]+  ]

@@ -0,0 +1,15 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import           RIO++import           Test.Tasty         (defaultMainWithIngredients, testGroup)+import           Test.Tasty.Runners (consoleTestReporter, listingTests)++import qualified ComponentTest      as Component++main :: IO ()+main = defaultMainWithIngredients+  [listingTests, consoleTestReporter]+  (testGroup "componentm library" [Component.tests])