diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/componentm.cabal b/componentm.cabal new file mode 100644 --- /dev/null +++ b/componentm.cabal @@ -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 diff --git a/src/Control/Monad/Component.hs b/src/Control/Monad/Component.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Component.hs @@ -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 + +-} diff --git a/src/Control/Monad/Component/Internal/Core.hs b/src/Control/Monad/Component/Internal/Core.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Component/Internal/Core.hs @@ -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 ()) diff --git a/src/Control/Monad/Component/Internal/Types.hs b/src/Control/Monad/Component/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Component/Internal/Types.hs @@ -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) diff --git a/test/tasty/ComponentTest.hs b/test/tasty/ComponentTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/ComponentTest.hs @@ -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 + ] + ] diff --git a/test/tasty/TestSuite.hs b/test/tasty/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/tasty/TestSuite.hs @@ -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])