diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,17 @@ [1]: http://semver.org/spec/v2.0.0.html [2]: https://github.com/roman/Haskell-teardown/libraries/teardown/CHANGELOG.md +## v0.1.0.0 + +> BREAKING CHANGES + +* Relax Glob dependency bounds +* Add `IResource` typeclass and make `newTeardown` part of it +* Remove `concatTeardown` and `newDynTeardown` functions in favor of + overloades of `IResource` +* Update TestSuite +* Update Example + ## v0.0.0.2 * Add haddock documentation to modules diff --git a/src/Control/Teardown.hs b/src/Control/Teardown.hs --- a/src/Control/Teardown.hs +++ b/src/Control/Teardown.hs @@ -12,39 +12,31 @@ sub-routines -} module Control.Teardown - ( ITeardown + ( + -- * Typeclasses for extending teardown functionality + ITeardown + , IResource + -- * Cleanup main type and function , Teardown + , TeardownResult (..) , teardown -- * Functions to create a 'Teardown' record , emptyTeardown , newTeardown - , newDynTeardown - , concatTeardown -- * Functions to deal with results from 'teardown' call - , TeardownResult (..) , didTeardownFail , failedToredownCount , toredownCount , renderTeardownReport ) where -import Control.Teardown.Internal.Core - ( ITeardown - , Teardown - , teardown - - , emptyTeardown - , newTeardown - , newDynTeardown - , concatTeardown +import Control.Teardown.Internal.Types + (IResource (..), ITeardown (..), Teardown, TeardownResult (..)) - , TeardownResult (..) - , didTeardownFail - , failedToredownCount - , toredownCount - ) +import Control.Teardown.Internal.Core + (didTeardownFail, emptyTeardown, failedToredownCount, toredownCount) import Control.Teardown.Internal.Printer (renderTeardownReport) diff --git a/src/Control/Teardown/Internal/Core.hs b/src/Control/Teardown/Internal/Core.hs --- a/src/Control/Teardown/Internal/Core.hs +++ b/src/Control/Teardown/Internal/Core.hs @@ -1,60 +1,15 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Control.Teardown.Internal.Core where import Protolude hiding (first) +import Data.IORef (atomicModifyIORef, newIORef, readIORef, writeIORef) import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) -import Data.IORef (atomicModifyIORef, newIORef, readIORef, writeIORef) - --------------------------------------------------------------------------------- - -type Description = Text - --- | Result from a 'Teardown' sub-routine -data TeardownResult - -- | Result is composed by multiple teardown sub-routines - = BranchResult - { - -- | Text description of parent teardown spec - resultDescription :: !Description - -- | Sum of elapsed time on sub-routines execution - , resultElapsedTime :: !NominalDiffTime - -- | Tells if any sub-routines failed - , resultDidFail :: !Bool - -- | Results of inner sub-routines - , resultListing :: ![TeardownResult] - } - -- | Result represents a single teardown sub-routine - | LeafResult - { - -- | Text description of sub-routine - resultDescription :: !Description - -- | Elapsed time on sub-routine execution - , resultElapsedTime :: !NominalDiffTime - -- | Exception from sub-routine - , resultError :: !(Maybe SomeException) - } - -- | Represents a stub cleanup operation (for lifting pure values) - | EmptyResult - { - -- | Text description of faked sub-routine - resultDescription :: !Description - } - deriving (Generic, Show) - --- | Sub-routine that performs a resource cleanup operation -newtype Teardown - = Teardown (IO TeardownResult) - deriving (Generic) - --- | A record that __is__ or __contains__ a 'Teardown' sub-routine should --- instantiate this typeclass -class ITeardown d where - -- | Executes teardown sub-routine returning a "TeardownResult" - teardown :: d -> IO TeardownResult +import Control.Teardown.Internal.Types -------------------------------------------------------------------------------- @@ -85,8 +40,8 @@ -- side-effects from this action are guaranteed to be executed only once, and -- also it is guaranteed to be thread-safe in the scenario of multiple threads -- executing the same teardown procedure. -newTeardown :: Description -> IO () -> IO Teardown -newTeardown desc disposingAction = do +newTeardownIO :: Description -> IO () -> IO Teardown +newTeardownIO desc disposingAction = do teardownResultLock <- newIORef False teardownResultRef <- newIORef Nothing return $ Teardown $ do @@ -194,3 +149,17 @@ instance ITeardown Teardown where teardown (Teardown action) = action + +instance IResource (IO ()) where + newTeardown = + newTeardownIO + +instance IResource [(Text, IO ())] where + newTeardown desc actionList = do + teardownList <- mapM (uncurry newTeardown) actionList + return $ concatTeardown desc teardownList + +instance IResource (IO [Teardown]) where + newTeardown desc getTeardownList = do + teardownList <- getTeardownList + return $ concatTeardown desc teardownList diff --git a/src/Control/Teardown/Internal/Printer.hs b/src/Control/Teardown/Internal/Printer.hs --- a/src/Control/Teardown/Internal/Printer.hs +++ b/src/Control/Teardown/Internal/Printer.hs @@ -7,9 +7,10 @@ import qualified Data.Text as Text import Data.Typeable (typeOf) -import Control.Teardown.Internal.Core -import Data.Monoid ((<>)) -import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) +import Data.Monoid ((<>)) +import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) + +import Control.Teardown.Internal.Types treeTrunk :: Int -> Int -> Doc treeTrunk start level = diff --git a/src/Control/Teardown/Internal/Types.hs b/src/Control/Teardown/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Teardown/Internal/Types.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Control.Teardown.Internal.Types where + +import Protolude + +import Data.Time.Clock (NominalDiffTime) + +#if MIN_VERSION_base(4,9,0) +import GHC.Generics (Generic) +#endif + +-------------------------------------------------------------------------------- + +type Description = Text + +-- | Result from a 'Teardown' sub-routine +data TeardownResult + -- | Result is composed by multiple teardown sub-routines + = BranchResult + { + -- | Text description of parent teardown spec + resultDescription :: !Description + -- | Sum of elapsed time on sub-routines execution + , resultElapsedTime :: !NominalDiffTime + -- | Tells if any sub-routines failed + , resultDidFail :: !Bool + -- | Results of inner sub-routines + , resultListing :: ![TeardownResult] + } + -- | Result represents a single teardown sub-routine + | LeafResult + { + -- | Text description of sub-routine + resultDescription :: !Description + -- | Elapsed time on sub-routine execution + , resultElapsedTime :: !NominalDiffTime + -- | Exception from sub-routine + , resultError :: !(Maybe SomeException) + } + -- | Represents a stub cleanup operation (for lifting pure values) + | EmptyResult + { + -- | Text description of faked sub-routine + resultDescription :: !Description + } + deriving (Generic, Show) + +-- | Sub-routine that performs a resource cleanup operation +newtype Teardown + = Teardown (IO TeardownResult) + deriving (Generic) + +-- | A record that __is__ or __contains__ a 'Teardown' sub-routine should +-- instantiate this typeclass +class ITeardown teardown where + -- | Executes teardown sub-routine returning a "TeardownResult" + teardown :: teardown -> IO TeardownResult + +-- | A resource or sub-routine that can be transformed into a 'Teardown' +-- operation +class IResource resource where + newTeardown :: Text -> resource -> IO Teardown diff --git a/teardown.cabal b/teardown.cabal --- a/teardown.cabal +++ b/teardown.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: teardown -version: 0.0.0.2 +version: 0.1.0.0 synopsis: Build composable, idempotent & transparent application cleanup sub-routines description: Please see README.md category: System @@ -40,6 +40,7 @@ exposed-modules: Control.Teardown other-modules: + Control.Teardown.Internal.Types Control.Teardown.Internal.Core Control.Teardown.Internal.Printer default-language: Haskell2010 @@ -56,7 +57,7 @@ , text >=1.2 && <1.3 , time >=1.5 && <1.7 , doctest >=0.11 && <0.12 - , Glob >=0.7 && <0.8 + , Glob >=0.7 && <0.9 , QuickCheck >=2.8 && <2.10 , teardown other-modules: diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -10,7 +10,7 @@ import Test.Tasty.Runners (consoleTestReporter, listingTests) import Control.Teardown -import Data.IORef (atomicModifyIORef, newIORef, readIORef) +import Data.IORef (atomicModifyIORef, modifyIORef, newIORef, readIORef) main :: IO () main = @@ -33,8 +33,8 @@ 1 callCount , testCase "failing teardown action does not stop execution" $ do - teardownAction <- newTeardown "failing teardown" $ - panic "failing teardown" + teardownAction <- newTeardown "failing teardown" + (panic "failing teardown" :: IO ()) result <- teardown teardownAction replicateM_ 9 (teardown teardownAction) @@ -58,15 +58,14 @@ assertEqual "teardown action must not be called more than once" 1 callCount - , testCase "concatenated teardown actions keep idempotent guarantees" $ do + , testCase "teardown tree keeps idempotent guarantees around execution" $ do callCountRefs <- replicateM 10 $ newIORef (0 :: Int) - teardownActions <- forM callCountRefs $ \callCountRef -> - newTeardown "test cleanup" - (atomicModifyIORef callCountRef (\a -> (succ a, ()))) - let - teardownAction = - concatTeardown "bigger system" teardownActions + teardownAction <- + newTeardown "bigger system" $ + forM callCountRefs $ \callCountRef -> + newTeardown "test cleanup" + (atomicModifyIORef callCountRef (\a -> (succ a, ()))) replicateM_ 10 (teardown teardownAction) @@ -75,31 +74,16 @@ (replicate 10 1) countRefs - , testCase "concatenated teardown actions return correct count" $ do - teardownActions <- - replicateM 10 (newTeardown "test cleanup" (return ())) - - let - teardownAction = - concatTeardown "bigger system" teardownActions - - toredownResult <- teardown teardownAction - replicateM_ 9 (teardown teardownAction) - - assertEqual "teardown action must not be called more than once" - 10 (toredownCount toredownResult) - - , testCase "concatenated failed teardown actions return correct count" $ do + , testCase "teardown action that returns Teardown list returns correct count" $ do failedTeardownActions <- - replicateM 5 (newTeardown "test cleanup with failures" (panic "nope")) + replicateM 5 (newTeardown "test cleanup with failures" (panic "nope" :: IO ())) teardownActions <- - replicateM 5 (newTeardown "test cleanup" (return ())) + replicateM 5 (newTeardown "test cleanup" (return () :: IO ())) - let - teardownAction = - concatTeardown "bigger system" - (failedTeardownActions <> teardownActions) + teardownAction <- + newTeardown "bigger system" + (return (failedTeardownActions <> teardownActions) :: IO [Teardown]) toredownResult <- teardown teardownAction replicateM_ 9 (teardown teardownAction) @@ -110,29 +94,34 @@ assertEqual "failed teardown action must be correct" 5 (failedToredownCount toredownResult) - , testCase "dynamic teardown behave similar to vanilla teardown" $ do + , testCase "teardown with list of description and actions executes correctly" $ do callCountRef <- newIORef (0 :: Int) - failedTeardownActions <- - replicateM 5 (newTeardown "test cleanup with failures" (panic "nope")) + 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") + ] - teardownActions <- - replicateM 5 (newTeardown "test cleanup" - (atomicModifyIORef callCountRef (\a -> (succ a, ())))) - let - teardownAction = - newDynTeardown "bigger system" $ - mapM teardown (failedTeardownActions <> teardownActions) - - teardownResult <- teardown teardownAction + -- Execute multiple times to assert idempotency + toredownResult <- teardown teardownAction replicateM_ 9 (teardown teardownAction) - teardownSuccessCount <- readIORef callCountRef - assertEqual "teardown action count must be correct" - 10 (toredownCount teardownResult) + 9 (toredownCount toredownResult) - assertEqual "teardown action must be idempotent" - 5 teardownSuccessCount + assertEqual "failed teardown must be correct" + 4 (failedToredownCount toredownResult) + callCount <- readIORef callCountRef + assertEqual "side-effects were executed despite errors on other teardown operations" + 5 callCount ]