teardown 0.3.0.0 → 0.4.0.0

raw patch · 17 files changed

+416/−1128 lines, 17 filesdep +riodep +typed-processdep +unliftiodep −Globdep −QuickCheckdep −deepseqdep ~ansi-wl-pprintdep ~criteriondep ~tastyPVP ok

version bump matches the API change (PVP)

Dependencies added: rio, typed-process, unliftio

Dependencies removed: Glob, QuickCheck, deepseq, doctest, exceptions, protolude, safe-exceptions, tasty-hspec, tasty-rerun, tasty-smallcheck, text, time

Dependency ranges changed: ansi-wl-pprint, criterion, tasty, tasty-hunit

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−1
• LICENSE +1/−1
• README.md +24/−97
• benchmark/Main.hs +13/−11
• src/Control/Monad/Component.hs +0/−49
• src/Control/Monad/Component/Internal/Core.hs +0/−75
• src/Control/Monad/Component/Internal/Types.hs +0/−154
• src/Control/Teardown.hs +15/−8
• src/Control/Teardown/Internal/Core.hs +102/−70
• src/Control/Teardown/Internal/Printer.hs +52/−63
• src/Control/Teardown/Internal/Types.hs +13/−7
• src/Control/Teardown/Tutorial.hs +0/−184
• teardown.cabal +79/−109
• test/doctest/DocTest.hs +0/−7
• test/tasty/ComponentTest.hs +0/−188
• test/tasty/TeardownTest.hs +94/−90
• test/tasty/TestSuite.hs +7/−14

@@ -7,8 +7,21 @@ [1]: http://semver.org/spec/v2.0.0.html [2]: https://github.com/roman/Haskell-teardown/libraries/teardown/CHANGELOG.md +## v0.4.0.0++**BREAKING CHANGES**++* Bump from lts-9.5 to lts-11+* Replace `ITeardown` typeclass in favor of `HasTeardown`+* Replace `teardown` function in favor of `runTeardown` and `runTeardown_`+* Replace `protolude` in favor of `rio`+* Rename `renderTeardownReport` to `prettyTeardownResult`+* Remove `Control.Monad.Component` in favor of having it on its own package `componentm`+ ## v0.3.0.0 +**BREAKING CHANGES**+ * Bump from lts-9.1 to lts-9.5 * Add `Control.Monad.Component` module * Add `Control.Teardown.Tutorial` module@@ -16,6 +29,8 @@  ## v0.2.0.0 +**BREAKING CHANGES**+ * Bump from lts-8.21 to lts-9.1 * Re-organize test files to support nightly (GHC-8.2) * Drop support for lts-6 (GHC-7.10)@@ -30,7 +45,7 @@  ## v0.1.0.0 -> BREAKING CHANGES+**BREAKING CHANGES**  * Relax Glob dependency bounds * Add `IResource` typeclass and make `newTeardown` part of it

@@ -1,4 +1,4 @@-Copyright (c) 2017, Roman Gonzalez+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

@@ -1,125 +1,52 @@-[![Hackage](https://img.shields.io/hackage/v/teardown.svg)](https://img.shields.io/hackage/v/teardown.svg)-[![Stackage LTS](http://stackage.org/package/teardown/badge/lts)](http://stackage.org/lts/package/teardown)-[![Stackage Nightly](http://stackage.org/package/teardown/badge/nightly)](http://stackage.org/nightly/package/teardown) # 🗑️  teardown  > Composable, idempotent & transparent application resource cleanup sub-routines  ## Table Of Contents -* [Raison d'etre](#raison-detre)-* [Development](#development)+* [Installation](#installation) * [Documentation](#documentation)-* [License](#license)-* [Report teardown sub-routine results](#report-teardown-sub-routine-tree-with-results)--## Raison d'etre--The _correct_ teardown of a system becomes a crucial matter when running-applications through GHCi while doing REPL driven development; this library-provides a stable API to manage the cleanup process of resources your-application allocates when it starts up.--One could naively implement a teardown sub-routine of an application by doing-something like the following:+* [Development](#development) -```haskell--- All functions in this example initialize hypothetical resources, the--- idea stands that there is a way to allocate a system resource--- using some sort of configuration record, and there is a--- sub-routine to release those resources once the application--- shuts down+## Installation -initDb :: Logger -> DbConnInfo -> IO (DbConn, IO ())-initDb logger connInfo = do-  conn <- newConn connInfo-  return (conn, info logger "Teardown Database" >> closeConn conn)+[![Hackage](https://img.shields.io/hackage/v/teardown.svg)](https://img.shields.io/hackage/v/teardown.svg)+[![Stackage LTS](https://www.stackage.org/package/teardown/badge/lts)](http://stackage.org/lts/package/teardown)+[![Stackage Nightly](https://www.stackage.org/package/teardown/badge/nightly)](http://stackage.org/nightly/package/teardown) -initTcpServer :: Logger -> ServerInfo -> IO (Socket, IO ())-initTcpServer logger serverInfo = do-  socket <- startServer serverInfo-  return (socket, info logger "Teardown Tcp Server" >> closeSocket socket)+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. -initApp :: Logger -> DbConnInfo -> ServerInfo -> IO (IO ())-initApp logger connInfo serverInfo = do-  (connInfo, teardownDb) <- initDb logger connInfo-  (serverInfo, teardownSocket) <- initTcpServer logger serverInfo-  -- do something with connInfo and serverInfo ...-  return (info logger "Teardown Application"-          >> teardownDb-          >> teardownSocket)+```cabal+library:+  build-depends: teardown ``` -The previous implementation does not address a few concerns:--* If for some reason we execute the @IO ()@ sub-routine returned by the-  @initApp@ function more than once, there is likely going to be a runtime-  exception of the "already closed resource" nature. This library ensures that-  teardown sub-routines are executed /exactly/ once, even on the scenario where-  we execute the teardown procedure multiple times.--* The teardown of sub-systems can be built and composed via the @(>>)@ operator,-  what happens if the @teardownDb@ sub-routine in the previous example throws an-  exception? Likely other resource teardown sub-routines are going to be-  affected. This library ensures that errors are isolated from every other-  resource teardown sub-routines.--* All teardown sub-routines use a description argument to keep track of what is-  being cleaned up; By requiring this, we avoid confusion around what is going-  on when shutting down an application. This library makes this documentation a-  /required/ argument when building teardown sub-routines, thus helping-  trace-ability.--* You may notice the structure of teardown sub-routines form a tree shape. This-  library provides a data structure representation of this tree that allows the-  developer to report all teardown sub-routines in hierarchy order, with other-  details around if sub-routines failed (or not).--* Also, this library keeps track how much time every teardown sub-routine takes,-  allowing the developer to learn which parts of the teardown procedure are slow-  and adequately address those on development time (e.g., Faster reload =>-  Faster development feedback loops).+Or on your `package.yaml` -By using this library, you may implement without much effort a good, reliable-and transparent strategy for application resource teardown sub-routines.+```+dependencies:+- teardown+```  ## Documentation -To learn more about the library, please refer to the documentation in Hackage for--* [Teardown](http://hackage.haskell.org/package/teardown-0.3.0.0/docs/Control-Teardown-Tutorial.html)--* [ComponentM](#) [pending]+* [Tutorial](https://romanandreg.gitbooks.io/teardown/v0.4/tutorial.html)+* [How-To Guides](https://romanandreg.gitbooks.io/teardown/v0.4/how-to/create-teardown.html)+* [API Reference](https://hackage.haskell.org/package/teardown)  ## Development+ [![Build Status](https://travis-ci.org/roman/Haskell-teardown.svg?branch=master)](https://travis-ci.org/roman/Haskell-teardown)+[![Github](https://img.shields.io/github/commits-since/roman/haskell-teardown/v0.1.0.1.svg)](https://img.shields.io/github/commits-since/roman/haskell-teardown/v0.1.0.1.svg) [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/teardown.svg)](http://packdeps.haskellers.com/feed?needle=teardown)-[![Github](https://img.shields.io/github/commits-since/roman/haskell-teardown/v0.3.0.0.svg)](https://img.shields.io/github/commits-since/roman/haskell-teardown/v0.3.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.+Follow the [developer guidelines](https://romanandreg.gitbooks.io/teardown/content/CONTRIBUTING.html)  ## License -Copyright (c) 2027, Roman Gonzalez+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

@@ -1,21 +1,23 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} module Main where -import Protolude+import RIO  import Criterion import Criterion.Main -import Control.Teardown (newTeardown, teardown)+import Control.Teardown (newTeardown, runTeardown_)  main :: IO ()-main = defaultMain [-    bgroup "simple IO unit return"-    [-      bench "without teardown" (whnfIO $ return ())-    , env-        (newTeardown "benchmark" $ (return () :: IO ()))-        (\unitTeardown -> bench "with teardown" (whnfIO $ void $ teardown unitTeardown))-    ]+main = defaultMain+  [ bgroup+      "simple IO unit return"+      [ bench "without teardown" (whnfIO $ return ())+      , env+        (newTeardown "benchmark" (return () :: IO ()))+        (\unitTeardown ->+          bench "with teardown" (whnfIO $ runTeardown_ unitTeardown)+        )+      ]   ]

@@ -1,49 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-|-Module      : Control.Monad.Component-Description : Build composable, idempotent & transparent application cleanup sub-routines for an application-Copyright   : (c) Roman Gonzalez, 2017-License     : MIT-Maintainer  : romanandreg@gmail.com-Stability   : experimental--Provides functions that help on the creation of Application teardown sub-routines--}-module Control.Monad.Component-  (--  -- * 'ComponentM' monad and runner-    ComponentM-  , runComponentM--  -- * 'Component' record and functions-  , Component-  , fromComponent--  -- * 'Component' error record-  , ComponentError (..)--  -- * 'Teardown' functions-  , Teardown-  , TeardownResult (..)-  , teardown-  , newTeardown--  -- * Re-exports-  , throwM-  , fail--  -- * Functions to build 'ComponentM' sub-routines-  , buildComponent-  , buildComponentWithCleanup-  , buildComponentWithTeardown-  ) where--import Control.Monad.Catch                    (throwM)-import Control.Monad.Component.Internal.Core-    (buildComponent, buildComponentWithCleanup, buildComponentWithTeardown, runComponentM)-import Control.Monad.Component.Internal.Types-    (Component, ComponentError (..), ComponentM, fromComponent)-import Control.Monad.Fail                     (fail)-import Control.Teardown-    (Teardown, TeardownResult (..), newTeardown, teardown)

@@ -1,75 +0,0 @@-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE NoImplicitPrelude #-}-module Control.Monad.Component.Internal.Core where--import Protolude--import Control.Monad.Component.Internal.Types-import Control.Teardown                       (Teardown, newTeardown, teardown)-------------------------------------------------------------------------------------- | Given the name and a `ComponentM` sub-routine, this function builds an `IO`--- sub-routine that returns a `Component` record.------ The name argument is used for trace-ability purposes when executing the--- `teardown` of a resulting `Component`.------ * A note on error scenarios:------ Sometimes the given `ComponentM` sub-routine may fail on execution, in such--- cases, this function will teardown all component resources allocated so far--- and throw a `ComponentStartupFailure` exception.----runComponentM :: Text -> ComponentM a -> IO (Component a)-runComponentM !appName (ComponentM ma) = do-  eResult <- ma-  case eResult of-    Left (errList, cleanupActions) -> do-      appTeardown <- newTeardown appName cleanupActions-      -- Cleanup resources allocated so far and throw error-      -- list-      void $ teardown appTeardown-      throwIO (ComponentStartupFailure errList)--    Right (a, cleanupActions) -> do-      appTeardown <- newTeardown appName cleanupActions-      return $! Component a appTeardown---- | Transforms an `IO` sub-routine into a `ComponentM` sub-routine; the given--- `IO` sub-routine must return a tuple where:------ * First position represents the resource being returned from---   the component------ * Second position represents a named cleanup action that tears down---   allocated resources to create the first element of the tuple----buildComponentWithCleanup :: IO (a, (Text, IO ())) -> ComponentM a-buildComponentWithCleanup !ma =-  ComponentM $ do-    (a, (desc, cleanupAction)) <- ma-    teardownAction <- newTeardown desc cleanupAction-    return $ Right (a, [teardownAction])---- | Transforms an `IO` sub-routine into a `ComponentM` sub-routine; the given--- `IO` sub-routine must return a tuple where:------ * First position represents the resource being returned from---   the component------ * Second position represents a `Teardown` record that cleans up allocated---   resources to create the first element of the tuple----buildComponentWithTeardown :: IO (a, Teardown) -> ComponentM a-buildComponentWithTeardown !ma =-  ComponentM $ (\(a, resourceTeardown) ->-                  Right (a, [resourceTeardown])) <$> ma---- | 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.----buildComponent :: IO a -> ComponentM a-buildComponent !ma =-  ComponentM $ (\a -> Right (a, [])) <$> ma

@@ -1,154 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE NoImplicitPrelude #-}-module Control.Monad.Component.Internal.Types where--import Protolude hiding (try)--import           Control.Exception.Safe (try)-import           Control.Monad.Catch    (MonadThrow (..))-import           Control.Monad.Fail     (MonadFail (..))-import qualified Data.Text              as T--import Control.Teardown (ITeardown (..), Teardown)------------------------------------------------------------------------------------data ComponentError-  = ComponentFailure !Text-  | ComponentStartupFailure ![SomeException]-  deriving (Generic, Show)--instance Exception ComponentError---- | `ComponentM` is a wrapper of the `IO` monad that automatically deals with--- the composition of `Teardown` sub-routines from resources allocated in every--- resource of your application. To build `ComponentM` actions see the--- `buildComponent`, `buildComponentWithCleanup` and--- `buildComponentWithTeardown` functions.-newtype ComponentM a-  = ComponentM (IO (Either ([SomeException], [Teardown])-                           (a, [Teardown])))--instance Functor ComponentM where-  fmap f (ComponentM action) =-    ComponentM $ do-      result <- action-      return $! case result of-        Left err ->-          Left err-        Right (a, teardownList) ->-          Right (f a, teardownList)--instance Applicative ComponentM where-  pure a =-    ComponentM-      $ return-      $ Right (a, [])--  (ComponentM mf) <*> (ComponentM mm) = ComponentM $ do-    ef <- try mf-    em <- try mm-    case (ef, em) of-      ( Left err1, Left err2 ) ->-        return $ Left ( [err1, err2], [] )--      ( Left err1, Right (Left (err2, cs2)) ) ->-        return $ Left ( [err1] <> err2, cs2 )--      ( Left err1, Right (Right (_, cs2)) ) ->-        return $ Left ( [err1], cs2 )---      ( Right (Left (err1, cs1)), Left err2 ) ->-        return $ Left ( err1 <> [err2], cs1 )--      ( Right (Right (_, cs1)), Left err2 ) ->-        return $ Left ( [err2], cs1 )--      ( Right (Left (err, cs1)), Right (Right (_, cs2)) ) ->-        return $ Left ( err-                      , cs1 <> cs2-                      )--      ( Right (Left (err1, cs1)), Right (Left (err2, cs2)) ) ->-        return $ Left ( err1 <> err2-                      , cs1 <> cs2-                      )--      ( Right (Right (_, cs1)), Right (Left (err, cs2)) ) ->-        return $ Left ( err-                      , cs1 <> cs2-                      )--      ( Right (Right (f, cs1)), Right (Right (a, cs2)) ) ->-        return $ Right ( f a-                       , cs1 <> cs2-                       )--instance Monad ComponentM where-  return =-    pure--  (ComponentM action0) >>= f = ComponentM $ do-    eResult0 <- action0-    case eResult0 of-      Right (a, cs0) -> do-        let-          (ComponentM action1) = f a--        eResult1 <- try action1--        case eResult1 of-          -- There was an exception via the IO Monad-          Left err ->-            return $ Left ([err], cs0)--          -- There was an exception either via `fail` or `throwM`-          Right (Left (err, cs1)) ->-            return $ Left (err, cs0 <> cs1)--          Right (Right (b, cs1)) ->-            return $ Right (b, cs0 <> cs1)---      Left (err, cs0) ->-        return $ Left (err, cs0)--instance MonadFail ComponentM where-  fail str =-    ComponentM-      $ return-      $ Left ([toException $! ComponentFailure (T.pack str)], [])--instance MonadThrow ComponentM where-  throwM e =-    ComponentM-      $ return-      $ Left ([toException e], [])--instance MonadIO ComponentM where-  liftIO action = ComponentM $ do-    result <- action-    return $ Right (result, [])----- | Represents the result of a `ComponentM` sub-routine, it contains a resource--- record which can be recovered using `fromComponent` and a `Teardown`--- sub-routine that can be executed using the `teardown` function.-data Component a-  = Component { componentResource :: !a-              , componentTeardown :: !Teardown }-  deriving (Generic)---- | Fetches the resource of a `Component` returned by a `ComponentM`--- sub-routine.-fromComponent :: Component a -> a-fromComponent =-  componentResource-{-# INLINE fromComponent #-}--instance NFData a => NFData (Component a)--instance ITeardown (Component a) where-  teardown =-    teardown . componentTeardown

@@ -2,9 +2,9 @@ {-| Module      : Control.Teardown Description : Build composable, idempotent & transparent application cleanup sub-routines-Copyright   : (c) Roman Gonzalez, 2017+Copyright   : (c) Roman Gonzalez, 2017,2018 License     : MIT-Maintainer  : romanandreg@gmail.com+Maintainer  : open-source@roman-gonzalez.info Stability   : experimental  Provides functions that help on the creation of Application teardown@@ -13,13 +13,14 @@ module Control.Teardown   (   -- * Typeclasses for extending teardown functionality-    ITeardown+    HasTeardown(..)   , IResource    -- * Cleanup main type and function   , Teardown   , TeardownResult (..)-  , teardown+  , runTeardown+  , runTeardown_    -- * Functions to create a 'Teardown' record   , emptyTeardown@@ -29,13 +30,19 @@   , didTeardownFail   , failedToredownCount   , toredownCount-  , renderTeardownReport+  , prettyTeardownResult   ) where  import Control.Teardown.Internal.Types-    (IResource (..), ITeardown (..), Teardown, TeardownResult (..))+    (HasTeardown (..), IResource (..), Teardown, TeardownResult (..))  import Control.Teardown.Internal.Core-    (didTeardownFail, emptyTeardown, failedToredownCount, toredownCount)+    ( didTeardownFail+    , emptyTeardown+    , failedToredownCount+    , runTeardown+    , runTeardown_+    , toredownCount+    ) -import Control.Teardown.Internal.Printer (renderTeardownReport)+import Control.Teardown.Internal.Printer (prettyTeardownResult)

@@ -1,39 +1,46 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-}-module Control.Teardown.Internal.Core where+module Control.Teardown.Internal.Core+  ( emptyTeardown -import Protolude hiding (first)+  , didTeardownFail+  , failedToredownCount+  , toredownCount -import Data.IORef      (atomicModifyIORef, newIORef, readIORef, writeIORef)-import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)+  , runTeardown+  , runTeardown_+  )+where +import RIO++import RIO.Time (NominalDiffTime, diffUTCTime, getCurrentTime)+ import Control.Teardown.Internal.Types  -------------------------------------------------------------------------------- +-- | Track duration time of the execution of an IO sub-routine trackExecutionTime :: IO a -> IO (NominalDiffTime, a) trackExecutionTime routine = do-  start <- getCurrentTime+  start  <- getCurrentTime   result <- routine-  end <- getCurrentTime+  end    <- getCurrentTime   return (diffUTCTime end start, result) +-- | Defines a Teardown that does not have any sub-routines associated to it. emptyTeardownResult :: Description -> TeardownResult emptyTeardownResult = EmptyResult  -- | Returns a boolean indicating if any of the cleanup sub-routine failed didTeardownFail :: TeardownResult -> Bool-didTeardownFail result =-  case result of-    LeafResult {} ->-      isJust (resultError result)+didTeardownFail result = case result of+  LeafResult{}   -> isJust (resultError result) -    BranchResult {} ->-      resultDidFail result+  BranchResult{} -> resultDidFail result -    EmptyResult {} ->-      False+  EmptyResult{}  -> False  -- | Creates a new "Teardown" sub-routine from a cleanup "IO" action, the -- side-effects from this action are guaranteed to be executed only once, and@@ -44,38 +51,32 @@   teardownResultLock <- newIORef False   teardownResultRef  <- newIORef Nothing   return $ Teardown $ do-      shouldExecute <--        atomicModifyIORef teardownResultLock-                          (\toredown ->-                             if toredown then-                               (True, False)-                             else-                               (True, True))+    shouldExecute <- atomicModifyIORef+      teardownResultLock+      (\toredown -> if toredown then (True, False) else (True, True)) -      if shouldExecute then do-          (elapsed, disposeResult0) <- trackExecutionTime (try disposingAction)-          let-            disposeResult =-              LeafResult desc elapsed (either Just (const Nothing) disposeResult0)+    if shouldExecute+      then do+        (elapsed, disposeResult0) <- trackExecutionTime (try disposingAction)+        let disposeResult = LeafResult+              desc+              elapsed+              (either Just (const Nothing) disposeResult0) -          writeIORef teardownResultRef (Just disposeResult)-          return disposeResult-      else-          fromMaybe (emptyTeardownResult desc) <$> readIORef teardownResultRef+        writeIORef teardownResultRef (Just disposeResult)+        return disposeResult+      else fromMaybe (emptyTeardownResult desc) <$> readIORef teardownResultRef --- | Creates a "Teardown" sub-routine that is composed of other smaller sub-routines. This--- is ideal for composing the cleanup of an application from smaller resources allocations that--- are known at compilation time.+-- | Creates a "Teardown" sub-routine that is composed of other smaller+-- sub-routines. This is ideal for composing the cleanup of an application from+-- smaller resources allocations that are known beforehand. concatTeardown :: Description -> [Teardown] -> Teardown concatTeardown desc teardownChildren = Teardown $ do   teardownResults <- mapM (\(Teardown action) -> action) teardownChildren -  let-    elapsed =-      sum $ map resultElapsedTime teardownResults+  let elapsed        = sum $ map getElapsedTime teardownResults -    teardownFailed =-      any didTeardownFail teardownResults+      teardownFailed = any didTeardownFail teardownResults    return $ BranchResult desc elapsed teardownFailed teardownResults @@ -88,20 +89,16 @@ newDynTeardown desc action = Teardown $ do   teardownResults <- action -  let-    elapsed =-      sum $ map resultElapsedTime teardownResults+  let elapsed        = sum $ map getElapsedTime teardownResults -    teardownFailed =-      any didTeardownFail teardownResults+      teardownFailed = any didTeardownFail teardownResults    return $ BranchResult desc elapsed teardownFailed teardownResults  -- | Creates a stub "Teardown" sub-routine, normally used when a contract --  expects a teardown return but there is no allocation being made emptyTeardown :: Description -> Teardown-emptyTeardown desc =-  Teardown (return $ emptyTeardownResult desc)+emptyTeardown desc = Teardown (return $ emptyTeardownResult desc)  -------------------------------------------------------------------------------- @@ -115,54 +112,89 @@   -> acc foldTeardownResult leafStep branchStep acc disposeResult =   case disposeResult of-    EmptyResult desc ->-      leafStep acc desc Nothing+    EmptyResult desc       -> leafStep acc desc Nothing -    LeafResult desc _ mErr ->-      leafStep acc desc mErr+    LeafResult desc _ mErr -> leafStep acc desc mErr      BranchResult desc _ _ results ->-      let-        result =-          map (foldTeardownResult leafStep branchStep acc) results-      in-        branchStep result desc+      let result = map (foldTeardownResult leafStep branchStep acc) results+      in  branchStep result desc  -- | Returns number of sub-routines executed at teardown toredownCount :: TeardownResult -> Int toredownCount =-  foldTeardownResult (\acc _ _ -> acc + 1)-                     (\results _ -> sum results)-                     0+  foldTeardownResult (\acc _ _ -> acc + 1) (\results _ -> sum results) 0  -- | Returns number of sub-routines that threw an exception on execution of -- teardown failedToredownCount :: TeardownResult -> Int-failedToredownCount =-  foldTeardownResult (\acc _ mErr -> acc + maybe 0 (const 1) mErr)-                     (\results _ -> sum results)-                     0+failedToredownCount = foldTeardownResult+  (\acc _ mErr -> acc + maybe 0 (const 1) mErr)+  (\results _ -> sum results)+  0  -------------------------------------------------------------------------------- -instance ITeardown Teardown where-  teardown (Teardown action) =-    action+instance HasTeardown Teardown where+  getTeardown = id +-- | Creates a Teardown record from a simple `IO ()` sub-routine instance IResource (IO ()) where   newTeardown =     newTeardownIO +-- | Creates a Teardown record from a simple list of cleanup sub-routines+-- (creating a Teardown record for each), ideal when one single component has+-- many resources allocated and need to be cleaned out all at once.+--+-- NOTE: The @IO ()@ sub-routines given are going to be executed in reverse+-- order at teardown time.+-- instance IResource [(Text, IO ())] where-  newTeardown desc actionList = do-    teardownList <- mapM (uncurry newTeardown) actionList-    return $ concatTeardown desc teardownList+  newTeardown desc actionList =+    concatTeardown desc <$> mapM (uncurry newTeardown) actionList +-- | Wraps a "Teardown" record; the new record will have one extra level of+-- description.+--+instance IResource Teardown where+  newTeardown desc =+    return . concatTeardown desc . return++-- | Wraps a list of "Teardown" record; the new record will have one extra level+-- of description. Same behaviour as the @[(Text, IO ())]@ instance, but works+-- for APIs that already return a "Teardown" as their cleanup.+-- instance IResource [Teardown] where   newTeardown desc =     return . concatTeardown desc +-- | Wraps an IO action that returns a list of "Teardown" record; the new record+-- will have one extra level of description. Same behaviour as the @[(Text, IO+-- ())]@ instance, but works for APIs that already return a "Teardown" as their+-- cleanup.+-- instance IResource (IO [Teardown]) where-  newTeardown desc getTeardownList = do-    teardownList <- getTeardownList-    return $ concatTeardown desc teardownList+  newTeardown desc getTeardownList =+    concatTeardown desc <$> getTeardownList++-- | Creates a "Teardown" sub-routine that is composed of inner sub-routines+--  that are allocated at runtime. This is useful if allocations are being+--  created and being hold on a Mutable variable of some sort (e.g. "IORef",+--  "TVar", etc) so that on teardown time this Mutable variable is read and+--  executed and the results are returned.+instance IResource (IO [TeardownResult]) where+  newTeardown desc =+    return . newDynTeardown desc++--------------------------------------------------------------------------------++-- | Executes all composed "Teardown" sub-routines safely, and returns a Tree+-- data structure wich can be used to gather facts from the cleanup process.+runTeardown :: HasTeardown t => t -> IO TeardownResult+runTeardown t0 =+  let (Teardown teardownAction) = getTeardown t0 in teardownAction++-- | Executes all composed "Teardown" sub-routines safely.+runTeardown_ :: HasTeardown t => t -> IO ()+runTeardown_ = void . runTeardown

@@ -2,83 +2,72 @@ {-# LANGUAGE OverloadedStrings #-} module Control.Teardown.Internal.Printer where -import Protolude hiding ((<>))+import RIO -import qualified Data.Text     as Text import           Data.Typeable (typeOf)+import qualified RIO.Text      as Text -import Data.Monoid                  ((<>)) import Text.PrettyPrint.ANSI.Leijen hiding ((<>))  import Control.Teardown.Internal.Types  treeTrunk :: Int -> Int -> Doc-treeTrunk start level =-  hcat (map (\_ -> text "    ") [1..start]) <>-  hcat (map (\_ -> text "   |") [start..pred level])+treeTrunk start level = hcat (map (\_ -> text "    ") [1 .. start])+  <> hcat (map (\_ -> text "   |") [start .. level - 1])  -- | Renders an ASCII Tree with the "TeardownResult" of a "Teardown" sub-routine -- execution-renderTeardownReport :: TeardownResult -> Doc-renderTeardownReport result =-    render 0 0 result <> hardline-  where-    renderError start level (SomeException err) =-      let-        (fstErrLine, errLines) =-          case Text.lines (show err) of-            [] ->-              panic "Expecting reported error to have a line of content, got none"+prettyTeardownResult :: TeardownResult -> Doc+prettyTeardownResult result = render 0 0 result <> hardline+ where+  renderError start level (SomeException err) =+    let+      (fstErrLine, errLines) = case Text.lines (tshow err) of+        [] ->+          error "Expecting reported error to have a line of content, got none" -            (fstErrLine' : errLines') ->-              (fstErrLine', errLines')+        (fstErrLine' : errLines') -> (fstErrLine', errLines') -        errorReport =-          treeTrunk (pred start) (succ level)-           <> ">"-           <> indent 2 (text (show (typeOf err)) <> ":")-           <+> text (Text.unpack fstErrLine)-          : map (\l ->-                    treeTrunk (pred start) (succ level)-                    <> ">"-                    <> indent 2 (text $ Text.unpack l))-                 errLines-      in-        vcat errorReport+      errorReport =+        treeTrunk (start - 1) (level + 1)+          <>  ">"+          <>  indent 2 (text (show (typeOf err)) <> ":")+          <+> text (Text.unpack fstErrLine)+          :   map+                (\l -> treeTrunk (start - 1) (level + 1) <> ">" <> indent+                  2+                  (text $ Text.unpack l)+                )+                errLines+    in+      vcat errorReport -    renderTree start level disposeResults =-      case disposeResults of-        [] ->-          mempty-        [ lastResult ] ->-          treeTrunk start (succ level) <> render (succ start) (succ level) lastResult-        (r : results) ->-          treeTrunk start (succ level) <> render start (succ level) r <$$> renderTree start level results-    render start level disposeResult =-      case disposeResult of-        EmptyResult desc ->-            "`-"-             <+> "✓"-             <+> text (Text.unpack desc)-             <+> "(empty)"+  renderTree start level disposeResults = case disposeResults of+    [] -> mempty+    [lastResult] ->+      treeTrunk start (level + 1) <> render (start + 1) (level + 1) lastResult+    (r : results) ->+      treeTrunk start (level + 1)+        <>   render     start (level + 1) r+        <$$> renderTree start level       results+  render start level disposeResult = case disposeResult of+    EmptyResult desc -> "`-" <+> "✓" <+> text (Text.unpack desc) <+> "(empty)" -        LeafResult desc elapsed Nothing ->-            "`-"-             <+> "✓"-             <+> text (Text.unpack desc)-             <+> text ("(" <> show elapsed <> ")")+    LeafResult desc elapsed Nothing ->+      "`-" <+> "✓" <+> text (Text.unpack desc) <+> text+        ("(" <> show elapsed <> ")") -        LeafResult desc elapsed (Just err) ->-            "`-"-             <+> "✘"-             <+> text (Text.unpack desc)-             <+> text ("(" <> show elapsed <> ")")-             <$$> renderError start level err+    LeafResult desc elapsed (Just err) ->+      "`-"+        <+>  "✘"+        <+>  text (Text.unpack desc)+        <+>  text ("(" <> show elapsed <> ")")+        <$$> renderError start level err -        BranchResult desc elapsed didFail results ->-          vcat [ "`-"-                 <+> (if didFail then "✘" else "✓")-                 <+> text (Text.unpack desc)-                 <+> text ("(" <> show elapsed <> ")")-               , renderTree start level results-               ]+    BranchResult desc elapsed didFail results -> vcat+      [ "`-"+      <+> (if didFail then "✘" else "✓")+      <+> text (Text.unpack desc)+      <+> text ("(" <> show elapsed <> ")")+      , renderTree start level results+      ]

@@ -1,16 +1,15 @@ {-# LANGUAGE BangPatterns      #-} {-# LANGUAGE CPP               #-} {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE NoImplicitPrelude #-} module Control.Teardown.Internal.Types where -import Protolude--import Data.Time.Clock (NominalDiffTime)+import RIO+import RIO.Time (NominalDiffTime)  #if MIN_VERSION_base(4,9,0)-import Control.DeepSeq (NFData (..))-import GHC.Generics    (Generic)+import GHC.Generics (Generic) #endif  --------------------------------------------------------------------------------@@ -49,6 +48,13 @@     }   deriving (Generic, Show) +getElapsedTime :: TeardownResult -> NominalDiffTime+getElapsedTime result =+  case result of+    BranchResult {resultElapsedTime} -> resultElapsedTime+    LeafResult {resultElapsedTime}   -> resultElapsedTime+    EmptyResult {}                   -> 0+ instance NFData TeardownResult where   rnf result =     case result of@@ -69,9 +75,9 @@  -- | A record that __is__ or __contains__ a 'Teardown' sub-routine should -- instantiate this typeclass-class ITeardown teardown where+class HasTeardown teardown where   -- | Executes teardown sub-routine returning a "TeardownResult"-  teardown :: teardown -> IO TeardownResult+  getTeardown :: teardown -> Teardown  -- | A resource or sub-routine that can be transformed into a 'Teardown' -- operation

@@ -1,184 +0,0 @@-{-| The /correct/ teardown of a system becomes a crucial matter when running applications through GHCi while doing REPL driven development; this library provides a stable API to manage the cleanup process of resources your application allocates when it starts up.--One could naively implement a teardown sub-routine of an application by doing something like the following:--> -- All functions in this example initialize hypothetical resources, the-> -- idea stands that there is a way to allocate a system resource-> -- using some sort of configuration record, and there is a-> -- sub-routine to release those resources once the application-> -- shuts down->-> initDb :: Logger -> DbConnInfo -> IO (DbConn, IO ())-> initDb logger connInfo = do->   conn <- newConn connInfo->   return (conn, info logger "Teardown Database" >> closeConn conn)->-> initTcpServer :: Logger -> ServerInfo -> IO (Socket, IO ())-> initTcpServer logger serverInfo = do->   socket <- startServer serverInfo->   return (socket, info logger "Teardown Tcp Server" >> closeSocket socket)->-> initApp :: Logger -> DbConnInfo -> ServerInfo -> IO (IO ())-> initApp logger connInfo serverInfo = do->   (connInfo, teardownDb) <- initDb logger connInfo->   (serverInfo, teardownSocket) <- initTcpServer logger serverInfo->   -- do something with connInfo and serverInfo ...->   return (info logger "Teardown Application"->           >> teardownDb->           >> teardownSocket)---The previous implementation does not address a few concerns:--    * If for some reason we execute the @IO ()@ sub-routine returned by the @initApp@  function more than once, there is likely going to be a runtime exception of the "already closed resource" nature. This library ensures that teardown sub-routines are executed /exactly/ once, even on the scenario where we execute the teardown procedure multiple times.--    * The teardown of sub-systems can be built and composed via the @(>>)@  operator, what happens if the @teardownDb@ sub-routine in the previous example throws an exception? Likely other resource teardown sub-routines are going to be affected. This library ensures that errors are isolated from every other resource teardown sub-routines.--    * All teardown sub-routines use a description argument to keep track of what is being cleaned up; By requiring this, we avoid confusion around what is going on when shutting down an application. This library makes this documentation a  /required/ argument when building teardown sub-routines, thus helping trace-ability.--    * You may notice the structure of teardown sub-routines form a tree shape.   This library provides a data structure representation of this tree that allows the developer to report all teardown sub-routines in hierarchy order, with other details around if sub-routines failed (or not).--    * Also, this library keeps track how much time every teardown sub-routine takes, allowing the developer to learn which parts of the teardown procedure are slow and adequately address those on development time (e.g., Faster reload => Faster development feedback loops).--    This tutorial shows some examples on how to use the @Control.Teardown@ API and also the rationale behind the typeclasses offered by the library.--}-module Control.Teardown.Tutorial-  (-    -- * Introduction-    -- $introduction--    -- * The 'Teardown' type-    -- $teardown_type--    -- * The 'IResource' typeclass-    -- $iresource_typeclass--    -- * The 'ITeardown' typeclass-    -- $iteardown_typeclass--    -- * The 'TeardownResult' type-    -- $teardown_result_type--  )-  where--{- $introduction--    The @teardown@ library allows creating cleanup sub-routines for the resources allocated to your application; some of the features it offers are:--    * Idempotent execution of cleanup sub-routines--    * When cleanup sub-routines fail, this library guarantees that it won't stop the cleanup process of other resources--    * On cleanup sub-routine execution, it returns a Tree data structure that  reports: what succeeded, what failed and how much time each of those-      sub-routines took to execute.--    * Functions to compose a Tree of 'Teardown' records--    With this features in place, you can ensure the best cleanup effort when reloading a complex runtime application when doing REPL driven development.---}--{- $teardown_type--    The 'Teardown' type wraps a resource cleanup sub-routine to provides the-    features displayed in the introduction section.--    == How to create a 'Teardown'--    You need to use the 'newTeardown' function to create a 'Teardown' record-    from a cleanup @IO@ sub-routine. An example follows:--    @-initDb :: Logger -> DbConnInfo -> IO (DbConn, Teardown)-initDb logger connInfo = do-  conn <- newConn connInfo-  cleanup <- newTeardown "database connection" (closeConn conn)-  return (conn, cleanup)-    @--    In the previous example, you may notice the 'newTeardown' function receives a 'Text' as its first argument; the purpose of this parameter is to explain what is the resource we want to deallocate. Make sure to make this description as unique as possible, as it will:--    * Help you pinpoint quickly a resource that is flaky at cleanup times-    * Allow you to identify what are the resources that take the longest to clean up; this is essential to help us ensure our development feedback loop is fast when doing REPL driven development.--    The second argument of the 'newTeardown' is an @IO ()@ sub-routine that performs the so-called cleanup procedure; however, the second argument could be other types that implement the 'IResource' typeclass.---}--{- $iresource_typeclass--    If you look up the signature of the 'newTeardown' function, you will discover the second argument may be any type that implements the 'IResource'  typeclass. This typeclass allows us to define which types represent a cleanup sub-routines. Note this __is not__ a public typeclass. Following are some of its instances.--    == @IO ()@--    This instance is the one that has been shown so far in this example.--    == @[Teardown]@--    This typeclass instance is used when creating the 'Teardown' of a resource that creates many other sub-resources that return a 'Teardown' record on their own.--    @-> initApp :: Logger -> DbConnInfo -> ServerInfo -> IO (Server, Teardown))-> initApp logger connInfo serverInfo = do->   (conn, teardownDb) <- initDb logger connInfo->   (server, teardownSocket) <- initTcpServer logger serverInfo conn->   -- do something with connInfo and serverInfo ...->   appTeardown <- newTeardown "application" [teardownDb, teardownSocket]->   return (server, appTeardown)-    @--    == @[(Text, IO ())]@--    This typeclass instance is useful when creating a 'Teardown' of an operation which  allocates more than one resource that needs to be torn down--    @-> initWorkerThread :: IO (Worker, Teardown)-> initWorkerThread = do->   workerQueue <- newTBQueue 100->   workerAsync <- async $ workerLoop workerQueue->   workerTeardown <- newTeardown "worker" [("queue", closeTBQueue workerQueue)->                                          ,("async", cancel workerAsync)]->   return $ (Worker workerQueue workerAsync, workerTeardown)-    @--    This typeclass instances will cover most of the use cases for building cleanup sub-routines.--}--{- $iteardown_typeclass--    Once you build a 'Teardown' record, the next thing you can do with it besides composing it with other 'Teardown's is to execute its cleanup sub-routine.--    To do this, we use the 'teardown' function, which has the following type signature:--    @-teardown :: ITeardown teardown => teardown -> IO TeardownResult-    @--    'teardown' returns a 'TeardownResult' record which is a tree-like data structure that contains detailed information on what teardown sub-routines failed (or not) and how much time they took to perform on the resource tree you built using 'newTeardown'.--    Naturally, the 'Teardown' type implements the 'ITeardown' typeclass, Is important to note, this typeclass is a public one, meaning, you are free to extend it with your types. It is __highly__ recommended. However, you implement this typeclass on types that wrap a 'Teardown' record, otherwise, the idempotence guarantees of sub-routines cannot be secured by the library.---}--{- $teardown_result_type--    As stated on the [ITeardown typeclass](#g:4) section, the 'TeardownResult' record reports the execution of a 'teardown' call. This library provides a few functions that get interesting information out of this record:--    * 'renderTeardownReport' -- returns a 'Doc' that represents the Tree of resources with their outcome and performance time, you can use 'print' to print the report on the terminal. Following example output:--    @-`- ✘  Application (0.000006s)-   |`- ✓ database connection (0.000002s)-   |`- ✘ tcp server (0.000002s)-         FatalError: FatalError {msg = "Some TCP Error Message"}-   @--    * 'toredownCount' -- returns the number of cleanup sub-routines executed.--    * 'failedToredownCount' -- returns the number of cleanup sub-routines that failed with an exception--    * 'didTeardownFail' -- returns a boolean that indicates if any cleanup  sub-routine failed with an exception--    This library exports all record constructors of 'TeardownResult' so you may traverse it in any way you find useful.--}

@@ -1,118 +1,88 @@--- This file has been generated from package.yaml by hpack version 0.17.0.------ see: https://github.com/sol/hpack--name:           teardown-version:        0.3.0.0-synopsis:       Build composable components for your application with clear teardown semantics-description:    The teardown library allows you to reliably deallocate resources-                created when initializing your application. It provides:-                .-                - A ComponentM monad that allows you to build and compose resources with-                  cleanup semantics-                .-                - An API that composes IO cleanup sub-routines safely-                .-                Check Control.Teardown.Tutorial for more information.-category:       System-stability:      alpha (experimental)-homepage:       https://github.com/roman/Haskell-teardown#readme-bug-reports:    https://github.com/roman/Haskell-teardown/issues-author:         Roman Gonzalez-maintainer:     romanandreg@gmail.com-copyright:      © 2017 Roman Gonzalez-license:        MIT-license-file:   LICENSE-tested-with:    GHC==8.0.1 GHC==8.0.2 GHC==8.2.1-build-type:     Simple-cabal-version:  >= 1.10-+name: teardown+version: 0.4.0.0+cabal-version: >=1.10+build-type: Simple+license: MIT+license-file: LICENSE+copyright: © 2017, 2018 Roman Gonzalez+maintainer: open-source@roman-gonzalez.info+stability: alpha (experimental)+homepage: https://github.com/roman/Haskell-teardown#readme+bug-reports: https://github.com/roman/Haskell-teardown/issues+synopsis: Build composable components for your application with clear teardown semantics+description:+    The teardown library allows you to reliably execute cleanup sub-routines for+    allocated resources when a program is initialized; it:+    .+    * Ensures that teardown sub-routines are executed /exactly/ once, even on the+    scenario where cleanup is invoked multiple times+    .+    * Ensures that if errors occur on the execution of one teardown, the error+    does not propagate to other sub-routines; effectively keeping them isolated.+    .+    * Requires every sub-routine to be documented at creation time; thus helping+    tracing your application structure.+    .+    * Allows tracing the teardown of your application, how is structured, how much+    time it takes to execute, and what component (if any) failed to finalize.+category: System+author: Roman Gonzalez+tested-with: GHC ==8.0.1 GHC ==8.0.2 GHC ==8.2.1 extra-source-files:     CHANGELOG.md     README.md  source-repository head-  type: git-  location: https://github.com/roman/Haskell-teardown+    type: git+    location: https://github.com/roman/Haskell-teardown  library-  hs-source-dirs:-      src-  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates-  build-depends:-      base >=4.8 && <5-    , protolude-    , safe-exceptions-    , text-    , time-    , ansi-wl-pprint-    , exceptions-    , deepseq-  exposed-modules:-      Control.Teardown-      Control.Teardown.Tutorial-      Control.Monad.Component-  other-modules:-      Control.Teardown.Internal.Types-      Control.Teardown.Internal.Core-      Control.Teardown.Internal.Printer-      Control.Monad.Component.Internal.Types-      Control.Monad.Component.Internal.Core-  default-language: Haskell2010--test-suite teardown-doctest-  type: exitcode-stdio-1.0-  main-is: DocTest.hs-  hs-source-dirs:-      test/doctest-  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N-  build-depends:-      base >=4.8 && <5-    , protolude-    , safe-exceptions-    , text-    , time-    , doctest-    , Glob-    , QuickCheck-    , teardown-  default-language: Haskell2010+    exposed-modules:+        Control.Teardown+    build-depends:+        ansi-wl-pprint >=0.6.7.3,+        base >=4.8 && <5,+        rio >=0.0.0.0,+        typed-process >=0.1.0.0,+        unliftio >=0.2.4.0+    default-language: Haskell2010+    hs-source-dirs: src+    other-modules:+        Control.Teardown.Internal.Types+        Control.Teardown.Internal.Core+        Control.Teardown.Internal.Printer+    ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -test-suite teardown-test-  type: exitcode-stdio-1.0-  main-is: TestSuite.hs-  hs-source-dirs:-      test/tasty-  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N-  build-depends:-      base >=4.8 && <5-    , protolude-    , safe-exceptions-    , text-    , time-    , tasty-    , tasty-hunit-    , tasty-hspec-    , tasty-smallcheck-    , tasty-rerun-    , teardown-  other-modules:-      ComponentTest-      TeardownTest-  default-language: Haskell2010+test-suite  teardown-test+    type: exitcode-stdio-1.0+    main-is: TestSuite.hs+    build-depends:+        base >=4.8 && <5,+        rio >=0.0.0.0,+        tasty >=0.11,+        tasty-hunit >=0.9.2,+        teardown -any,+        typed-process >=0.1.0.0,+        unliftio >=0.2.4.0+    default-language: Haskell2010+    hs-source-dirs: test/tasty+    other-modules:+        TeardownTest+        Paths_teardown+    ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N -benchmark teardown-benchmark-  type: exitcode-stdio-1.0-  main-is: Main.hs-  hs-source-dirs:-      benchmark-  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N-  build-depends:-      base >=4.8 && <5-    , protolude-    , safe-exceptions-    , text-    , time-    , criterion >=1.1 && <1.3-    , teardown-  default-language: Haskell2010+benchmark  teardown-benchmark+    type: exitcode-stdio-1.0+    main-is: Main.hs+    build-depends:+        base >=4.8 && <5,+        criterion >=1.1,+        rio >=0.0.0.0,+        teardown -any,+        typed-process >=0.1.0.0,+        unliftio >=0.2.4.0+    default-language: Haskell2010+    hs-source-dirs: benchmark+    other-modules:+        Paths_teardown+    ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N

@@ -1,7 +0,0 @@-module Main where--import System.FilePath.Glob-import Test.DocTest--main :: IO ()-main = glob "src/**/*.hs" >>= doctest

@@ -1,188 +0,0 @@-{-# LANGUAGE NoImplicitPrelude   #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-module ComponentTest where--import Protolude--import Test.Tasty       (TestTree, testGroup)-import Test.Tasty.HUnit--import Control.Monad.Component-import Data.IORef              (modifyIORef, newIORef, readIORef)---tests :: TestTree-tests =-  testGroup "component monad"-  [-    testCase "execute aggregation of components' teardown action works" $ do-      callCountRef <- newIORef (0 :: Int)--      let-        componentOne =-          buildComponentWithCleanup $ do-            return ((), ("one", modifyIORef callCountRef succ))--        componentTwo =-          buildComponentWithTeardown $ do-            t <- newTeardown "two" (modifyIORef callCountRef succ)-            return ((), t)--        componentThree =-          buildComponent $ return ()--        componentAction = do-          componentOne-          componentTwo-          componentThree--      result <- runComponentM "test application" componentAction-      void $ teardown result-      callCount <- readIORef callCountRef-      assertEqual "teardown action got called more than once"-                  2 callCount--  , testCase "component construction failure tears down previous components" $ do-      callCountRef <- newIORef (0 :: Int)--      let-        componentOne =-          buildComponentWithCleanup $ do-            return ((), ("one", modifyIORef callCountRef succ))--        componentTwo =-          buildComponent $ throwIO (ErrorCall "failing hard")--        componentThree =-          buildComponentWithTeardown $ do-            t <- newTeardown "three" (modifyIORef callCountRef succ)-            return ((), t)--        componentAction = do-          componentOne-          void componentTwo-          componentThree--      result <- try $ runComponentM "test application" componentAction-      case result of-        Left (ComponentStartupFailure [err]) -> do-          callCount <- readIORef callCountRef-          assertEqual "expected introduced error, got different one"-                      (Just $ ErrorCall "failing hard")-                      (fromException err)-          assertEqual "teardown action got called more than once" 1 callCount--        Left (err :: ComponentError) -> do-          assertFailure $ "expected ComponentStartupFailure exception, got instead: " <> show err--        Right _ ->-          assertFailure "expected error, but did not happen"--  , testCase "component construction multiple failure reported when using Applicative" $ do-      callCountRef <- newIORef (0 :: Int)--      let-        componentOne =-          buildComponentWithCleanup $ do-            return ((), ("one", modifyIORef callCountRef succ))--        componentTwo =-          buildComponent $ throwIO (ErrorCall "failing two")--        componentThree =-          buildComponent $ throwIO (ErrorCall "failing three")--        componentAction =-          componentOne-          *> componentTwo-          *> componentThree--      result <- try $ runComponentM "test application" componentAction-      case result of-        Left (ComponentStartupFailure [errTwo, errThree]) -> do-          callCount <- readIORef callCountRef-          assertEqual "expected introduced error, got different one"-                      (Just $ ErrorCall "failing two")-                      (fromException errTwo)-          assertEqual "expected introduced error, got different one"-                      (Just $ ErrorCall "failing three")-                      (fromException errThree)-          assertEqual "teardown action got called more than once" 1 callCount--        Left (err :: ComponentError) -> do-          assertFailure $ "expected ComponentStartupFailure exception, got instead: " <> show err--        Right _ ->-          assertFailure "expected error, but did not happen"--  , testCase "component construction allows MonadThrow calls" $ do-      callCountRef <- newIORef (0 :: Int)--      let-        componentOne =-          buildComponentWithCleanup $ do-            return ((), ("one", modifyIORef callCountRef succ))--        componentTwo =-          buildComponentWithCleanup $ do-            return ((), ("two", modifyIORef callCountRef succ))--        componentAction = do-          componentOne-          void $ throwM (ErrorCall "failing via MonadThrow")-          componentTwo--      result <- try $ runComponentM "test application" componentAction-      case result of-        Left (ComponentStartupFailure [err]) -> 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 :: ComponentError) -> do-          assertFailure $ "expected ComponentStartupFailure exception, got instead: " <> show err--        Right _ ->-          assertFailure "expected error, but did not happen"--  , testCase "component construction allows fail calls" $ do-      callCountRef <- newIORef (0 :: Int)--      let-        componentOne =-          buildComponentWithCleanup $ do-            return ((), ("one", modifyIORef callCountRef succ))--        componentTwo =-          buildComponentWithCleanup $ do-            return ((), ("two", modifyIORef callCountRef succ))--        componentAction = do-          componentOne-          void $ fail "failing via fail"-          componentTwo--      result <- try $ runComponentM "test application" componentAction-      case result of-        Left (ComponentStartupFailure [err]) -> do-          callCount <- readIORef callCountRef-          assertEqual ("expected introduced error, got different one: " <> show err)-                      "failing via fail"-                      (maybe "" (\res ->-                                   case res of-                                     ComponentFailure errMsg ->-                                       errMsg-                                     _ ->-                                       "FAIL - Invalid ComponentException received")-                                (fromException err))-          assertEqual "teardown action got called more than once" 1 callCount--        Left (err :: ComponentError) -> do-          assertFailure $ "expected ComponentStartupFailure exception, got instead: " <> show err--        Right _ ->-          assertFailure "expected error, but did not happen"-  ]

@@ -2,119 +2,123 @@ {-# LANGUAGE OverloadedStrings #-} module TeardownTest where -import Protolude--import Test.Tasty       (TestTree, testGroup)-import Test.Tasty.HUnit+import RIO -import Control.Teardown-import Data.IORef       (atomicModifyIORef, modifyIORef, newIORef, readIORef)+import           Control.Monad    (replicateM)+import qualified Control.Teardown as SUT+import           Test.Tasty       (TestTree, testGroup)+import           Test.Tasty.HUnit   tests :: TestTree-tests =-  testGroup "teardown"-  [-    testCase "idempotent execution of teardown action" $ do-      callCountRef <- newIORef (0 :: Int)-      teardownAction <- newTeardown "test cleanup" $-        atomicModifyIORef callCountRef (\a -> (succ a, ()))--      replicateM_ 10 (teardown teardownAction)-      callCount <- readIORef callCountRef-      assertEqual "teardown action got called more than once"-                  1 callCount+tests = testGroup+  "teardown"+  [ testCase "idempotent execution of teardown action" $ do+    callCountRef   <- newIORef (0 :: Int)+    teardownAction <- SUT.newTeardown+      "test cleanup"+      (atomicModifyIORef callCountRef (\a -> (a + 1, ())) :: IO ()) +    replicateM_ 10 (SUT.runTeardown teardownAction)+    callCount <- readIORef callCountRef+    assertEqual "teardown action got called more than once" 1 callCount   , testCase "failing teardown action does not stop execution" $ do-      teardownAction <- newTeardown "failing teardown"-        (panic "failing teardown" :: IO ())--      result <- teardown teardownAction-      replicateM_ 9 (teardown teardownAction)+    teardownAction <- SUT.newTeardown "failing teardown"+                                      (error "failing teardown" :: IO ()) -      assertBool "result should report an error"-                 (didTeardownFail result)+    result <- SUT.runTeardown teardownAction+    replicateM_ 9                               (SUT.runTeardown teardownAction) +    assertBool  "result should report an error" (SUT.didTeardownFail result)   , testCase "thread safe idempotent execution of teardown action" $ do-      callCountRef <- newIORef (0 :: Int)-      teardownAction <- newTeardown "test cleanup" $-        atomicModifyIORef callCountRef (\a -> (succ a, ()))--      asyncList <--        replicateM 10 (async-                        -- each async executes teardown 3 times-                        $ replicateM_ 3-                        $ void $ teardown teardownAction)+    callCountRef   <- newIORef (0 :: Int)+    teardownAction <- SUT.newTeardown+      "test cleanup"+      (atomicModifyIORef callCountRef (\a -> (a + 1, ())) :: IO ()) -      mapM_ wait asyncList-      callCount <- readIORef callCountRef-      assertEqual "teardown action must not be called more than once"-                  1 callCount+    asyncList <- replicateM+      10+      (async+                      -- each async executes teardown 3 times+             $ replicateM_ 3 $ SUT.runTeardown_ teardownAction) +    mapM_ wait asyncList+    callCount <- readIORef callCountRef+    assertEqual "teardown action must not be called more than once" 1 callCount   , testCase "teardown tree keeps idempotent guarantees around execution" $ do-      callCountRefs <- replicateM 10 $ newIORef (0 :: Int)--      teardownAction <--        newTeardown "bigger system" $-          forM callCountRefs $ \callCountRef ->-            newTeardown "test cleanup"-                        (atomicModifyIORef callCountRef (\a -> (succ a, ())))--      replicateM_ 10 (teardown teardownAction)+    callCountRefs  <- replicateM 10 $ newIORef (0 :: Int) -      countRefs <- mapM readIORef callCountRefs-      assertEqual "teardown action must not be called more than once"-                  (replicate 10 1)-                  countRefs+    teardownAction <-+      SUT.newTeardown "bigger system"+      $ forM callCountRefs+      $ \callCountRef -> SUT.newTeardown+          "test cleanup"+          (atomicModifyIORef callCountRef (\a -> (a + 1, ())) :: IO ()) -  , testCase "teardown action that returns Teardown list returns correct count" $ do-      failedTeardownActions <--        replicateM 5 (newTeardown "test cleanup with failures" (panic "nope" :: IO ()))+    replicateM_ 10 (SUT.runTeardown_ teardownAction) -      teardownActions <--        replicateM 5 (newTeardown "test cleanup" (return () :: IO ()))+    countRefs <- mapM readIORef callCountRefs+    assertEqual "teardown action must not be called more than once"+                (replicate 10 1)+                countRefs+  , testCase "teardown action that returns Teardown list returns correct count"+    $ do+        failedTeardownActions <- replicateM+          5+          (SUT.newTeardown "test cleanup with failures" (error "nope" :: IO ())) -      teardownAction <--        newTeardown "bigger system"-          (return (failedTeardownActions <> teardownActions) :: IO [Teardown])+        teardownActions <- replicateM+          5+          (SUT.newTeardown "test cleanup" (return () :: IO ())) -      toredownResult <- teardown teardownAction-      replicateM_ 9 (teardown teardownAction)+        teardownAction <- SUT.newTeardown+          "bigger system"+          (return (failedTeardownActions <> teardownActions) :: IO+              [SUT.Teardown]+          ) -      assertEqual "teardown action count must be correct"-                  10 (toredownCount toredownResult)+        toredownResult <- SUT.runTeardown teardownAction+        replicateM_ 9 (SUT.runTeardown teardownAction) -      assertEqual "failed teardown action must be correct"-                  5 (failedToredownCount toredownResult)+        assertEqual "teardown action count must be correct"+                    10+                    (SUT.toredownCount toredownResult) -  , testCase "teardown with list of description and actions executes correctly" $ do-      callCountRef <- newIORef (0 :: Int)-      teardownAction <--          newTeardown "bigger-system"-              [-                ("1" :: Text, modifyIORef callCountRef (+1))-              , ("2", modifyIORef callCountRef (+1))-              , ("3", modifyIORef callCountRef (+1))-              , ("4", modifyIORef callCountRef (+1))-              , ("5", modifyIORef callCountRef (+1))-              , ("6", panic "nope")-              , ("7", panic "nope")-              , ("8", panic "nope")-              , ("9", panic "nope")-              ]+        assertEqual "failed teardown action must be correct"+                    5+                    (SUT.failedToredownCount toredownResult)+  , testCase "teardown with list of description and actions executes correctly"+    $ do+        callCountRef   <- newIORef (0 :: Int)+        teardownAction <- SUT.newTeardown+          "bigger-system"+          [ ("1" :: Text, modifyIORef callCountRef (+ 1) :: IO ())+          , ("2"        , modifyIORef callCountRef (+ 1))+          , ("3"        , modifyIORef callCountRef (+ 1))+          , ("4"        , modifyIORef callCountRef (+ 1))+          , ("5"        , modifyIORef callCountRef (+ 1))+          , ("6"        , error "nope")+          , ("7"        , error "nope")+          , ("8"        , error "nope")+          , ("9"        , error "nope")+          ]  -      -- Execute multiple times to assert idempotency-      toredownResult <- teardown teardownAction-      replicateM_ 9 (teardown teardownAction)+        -- Execute multiple times to assert idempotency+        toredownResult <- SUT.runTeardown teardownAction+        replicateM_ 9 (SUT.runTeardown teardownAction) -      assertEqual "teardown action count must be correct"-                  9 (toredownCount toredownResult)+        assertEqual "teardown action count must be correct"+                    9+                    (SUT.toredownCount toredownResult) -      assertEqual "failed teardown must be correct"-                  4 (failedToredownCount toredownResult)+        assertEqual "failed teardown must be correct"+                    4+                    (SUT.failedToredownCount toredownResult) -      callCount <- readIORef callCountRef-      assertEqual "side-effects were executed despite errors on other teardown operations"-                  5 callCount+        callCount <- readIORef callCountRef+        assertEqual+          "side-effects were executed despite errors on other teardown operations"+          5+          callCount   ]

@@ -2,21 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Protolude+import RIO -import Test.Tasty                   (defaultMainWithIngredients, testGroup)-import Test.Tasty.Ingredients.Rerun (rerunningTests)-import Test.Tasty.Runners           (consoleTestReporter, listingTests)+import Test.Tasty         (defaultMainWithIngredients, testGroup)+import Test.Tasty.Runners (consoleTestReporter, listingTests) -import qualified ComponentTest as Component-import qualified TeardownTest  as Teardown+import qualified TeardownTest as Teardown  main :: IO ()-main =-  defaultMainWithIngredients-    [ rerunningTests [listingTests, consoleTestReporter] ]-    (testGroup "teardown library"-      [ Teardown.tests-      , Component.tests-      ]-    )+main = defaultMainWithIngredients+  [listingTests, consoleTestReporter]+  (testGroup "teardown library" [Teardown.tests])