diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +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.1 + +* First release of teardown library diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2017, TODO: + +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,7 @@ +# teardow + +`teardown` allows the creation of composable, idempotent and transparent +application cleanup sub-routines. + +For more information about `teardown` API and how to use it, see +the [`teardown` homepage](https://github.com/roman/Haskell-teardown). 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/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Criterion +import Criterion.Main + +import Lib (inc) + +main :: IO () +main = defaultMain [bench "inc 41" (whnf inc (41 :: Int))] diff --git a/src/Control/Teardown.hs b/src/Control/Teardown.hs new file mode 100644 --- /dev/null +++ b/src/Control/Teardown.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Control.Teardown ( module X ) where + +import Control.Teardown.Internal.Core as X + ( ITeardown (..) + , Teardown + , TeardownResult (..) + , concatTeardown + , didTeardownFail + , emptyTeardown + , failedToredownCount + , newDynTeardown + , newTeardown + , toredownCount + ) +import Control.Teardown.Internal.Printer as X (renderTeardownReport) diff --git a/src/Control/Teardown/Internal/Core.hs b/src/Control/Teardown/Internal/Core.hs new file mode 100644 --- /dev/null +++ b/src/Control/Teardown/Internal/Core.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Control.Teardown.Internal.Core where + +import Protolude hiding (first) + +import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) + +import Data.IORef (atomicModifyIORef, newIORef, readIORef, writeIORef) + +-------------------------------------------------------------------------------- + +type Description = Text + +data TeardownResult + = BranchResult + { + resultDescription :: !Description + , resultElapsedTime :: !NominalDiffTime + , resultDidFail :: !Bool + , resultListing :: ![TeardownResult] + } + | LeafResult + { + resultDescription :: !Description + , resultElapsedTime :: !NominalDiffTime + , resultError :: !(Maybe SomeException) + } + | EmptyResult + { + resultDescription :: !Description + } + deriving (Generic, Show) + +newtype Teardown + = Teardown (IO TeardownResult) + deriving (Generic) + +class ITeardown d where + teardown :: d -> IO TeardownResult + +-------------------------------------------------------------------------------- + +trackExecutionTime :: IO a -> IO (NominalDiffTime, a) +trackExecutionTime routine = do + start <- getCurrentTime + result <- routine + end <- getCurrentTime + return (diffUTCTime end start, result) + +emptyTeardownResult :: Description -> TeardownResult +emptyTeardownResult = EmptyResult + +didTeardownFail :: TeardownResult -> Bool +didTeardownFail result = + case result of + LeafResult {} -> + isJust (resultError result) + + BranchResult {} -> + resultDidFail result + + EmptyResult {} -> + False + +newTeardown :: Description -> IO () -> IO Teardown +newTeardown desc disposingAction = do + teardownResultLock <- newIORef False + teardownResultRef <- newIORef Nothing + return $ Teardown $ do + 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) + + writeIORef teardownResultRef (Just disposeResult) + return disposeResult + else + fromMaybe (emptyTeardownResult desc) <$> readIORef teardownResultRef + +concatTeardown :: Description -> [Teardown] -> Teardown +concatTeardown desc teardownChildren = Teardown $ do + teardownResults <- mapM (\(Teardown action) -> action) teardownChildren + + let + elapsed = + sum $ map resultElapsedTime teardownResults + + teardownFailed = + any didTeardownFail teardownResults + + return $ BranchResult desc elapsed teardownFailed teardownResults + +newDynTeardown :: Description -> IO [TeardownResult] -> Teardown +newDynTeardown desc action = Teardown $ do + teardownResults <- action + + let + elapsed = + sum $ map resultElapsedTime teardownResults + + teardownFailed = + any didTeardownFail teardownResults + + return $ BranchResult desc elapsed teardownFailed teardownResults + +emptyTeardown :: Description -> Teardown +emptyTeardown desc = + Teardown (return $ emptyTeardownResult desc) + +-------------------------------------------------------------------------------- + +foldTeardownResult + :: (acc -> Description -> Maybe SomeException -> acc) + -> ([acc] -> Description -> acc) + -> acc + -> TeardownResult + -> acc +foldTeardownResult leafStep branchStep acc disposeResult = + case disposeResult of + EmptyResult desc -> + leafStep acc desc Nothing + + LeafResult desc _ mErr -> + leafStep acc desc mErr + + BranchResult desc _ _ results -> + let + result = + map (foldTeardownResult leafStep branchStep acc) results + in + branchStep result desc + +toredownCount :: TeardownResult -> Int +toredownCount = + foldTeardownResult (\acc _ _ -> acc + 1) + (\results _ -> sum results) + 0 + +failedToredownCount :: TeardownResult -> Int +failedToredownCount = + foldTeardownResult (\acc _ mErr -> acc + maybe 0 (const 1) mErr) + (\results _ -> sum results) + 0 + +-------------------------------------------------------------------------------- + +instance ITeardown Teardown where + teardown (Teardown action) = + action diff --git a/src/Control/Teardown/Internal/Printer.hs b/src/Control/Teardown/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Teardown/Internal/Printer.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Control.Teardown.Internal.Printer where + +import Protolude hiding ((<>)) + +import qualified Data.Text as Text +import Data.Typeable (typeOf) + +import Control.Teardown.Internal.Core +import Data.Monoid ((<>)) +import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) + +treeTrunk :: Int -> Int -> Doc +treeTrunk start level = + hcat (map (\_ -> text " ") [1..start]) <> + hcat (map (\_ -> text " |") [start..pred level]) + +renderTeardownReport :: TeardownResult -> Doc +renderTeardownReport result = + render 0 0 result <> hardline + where + renderError start level (SomeException err) = + let + (fstErrLine:errLines) = + Text.lines (show err) + + 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 + + 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)" + + 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 + + BranchResult desc elapsed didFail results -> + vcat [ "`-" + <+> (if didFail then "✘" else "✓") + <+> text (Text.unpack desc) + <+> text ("(" <> show elapsed <> ")") + , renderTree start level results + ] diff --git a/teardown.cabal b/teardown.cabal new file mode 100644 --- /dev/null +++ b/teardown.cabal @@ -0,0 +1,100 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: teardown +version: 0.0.0.1 +synopsis: Build composable, idempotent & transparent application cleanup sub-routines +description: Please see README.md +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==7.10.3 GHC==8.0.1 GHC==8.0.2 +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/roman/Haskell-teardown + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.8 && <5 + , protolude >=0.1 && <0.2 + , text >=1.2 && <1.3 + , time >=1.5 && <1.7 + , ansi-wl-pprint >=0.6 && <0.7 + exposed-modules: + Control.Teardown + other-modules: + Control.Teardown.Internal.Core + Control.Teardown.Internal.Printer + default-language: Haskell2010 + +test-suite teardown-doctest + type: exitcode-stdio-1.0 + main-is: DocTest.hs + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.8 && <5 + , protolude >=0.1 && <0.2 + , text >=1.2 && <1.3 + , time >=1.5 && <1.7 + , doctest >=0.11 && <0.12 + , Glob >=0.7 && <0.8 + , QuickCheck >=2.8 && <2.10 + , teardown + other-modules: + TestSuite + default-language: Haskell2010 + +test-suite teardown-test + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.8 && <5 + , protolude >=0.1 && <0.2 + , text >=1.2 && <1.3 + , time >=1.5 && <1.7 + , tasty >=0.11 && <0.12 + , tasty-hunit >=0.9 && <0.10 + , tasty-hspec >=1.1 && <1.2 + , tasty-smallcheck >=0.8 && <0.9 + , tasty-rerun >=1.1 && <1.2 + , teardown + other-modules: + DocTest + default-language: Haskell2010 + +benchmark teardown-benchmark + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + benchmark + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.8 && <5 + , protolude >=0.1 && <0.2 + , text >=1.2 && <1.3 + , time >=1.5 && <1.7 + , criterion >=1.1 && <1.2 + , teardown + default-language: Haskell2010 diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,7 @@ +module Main where + +import System.FilePath.Glob +import Test.DocTest + +main :: IO () +main = glob "src/**/*.hs" >>= doctest diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Protolude + +import Test.Tasty (TestTree, defaultMainWithIngredients, testGroup) +import Test.Tasty.HUnit +import Test.Tasty.Ingredients.Rerun (rerunningTests) +import Test.Tasty.Runners (consoleTestReporter, listingTests) + +import Control.Teardown +import Data.IORef (atomicModifyIORef, newIORef, readIORef) + +main :: IO () +main = + defaultMainWithIngredients + [ rerunningTests [listingTests, consoleTestReporter] ] + tests + +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 + + , testCase "failing teardown action does not stop execution" $ do + teardownAction <- newTeardown "failing teardown" $ + panic "failing teardown" + + result <- teardown teardownAction + replicateM_ 9 (teardown teardownAction) + + assertBool "result should report an error" + (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) + + mapM_ wait asyncList + callCount <- readIORef callCountRef + assertEqual "teardown action must not be called more than once" + 1 callCount + + , testCase "concatenated teardown actions keep idempotent guarantees" $ 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 + + replicateM_ 10 (teardown teardownAction) + + countRefs <- mapM readIORef callCountRefs + assertEqual "teardown action must not be called more than once" + (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 + failedTeardownActions <- + replicateM 5 (newTeardown "test cleanup with failures" (panic "nope")) + + teardownActions <- + replicateM 5 (newTeardown "test cleanup" (return ())) + + let + teardownAction = + concatTeardown "bigger system" + (failedTeardownActions <> teardownActions) + + toredownResult <- teardown teardownAction + replicateM_ 9 (teardown teardownAction) + + assertEqual "teardown action count must be correct" + 10 (toredownCount toredownResult) + + assertEqual "failed teardown action must be correct" + 5 (failedToredownCount toredownResult) + + , testCase "dynamic teardown behave similar to vanilla teardown" $ do + callCountRef <- newIORef (0 :: Int) + failedTeardownActions <- + replicateM 5 (newTeardown "test cleanup with failures" (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 + replicateM_ 9 (teardown teardownAction) + + teardownSuccessCount <- readIORef callCountRef + + assertEqual "teardown action count must be correct" + 10 (toredownCount teardownResult) + + assertEqual "teardown action must be idempotent" + 5 teardownSuccessCount + + ]