diff --git a/Changes.md b/Changes.md --- a/Changes.md +++ b/Changes.md @@ -1,3 +1,7 @@ +* 0.0.2 + - Update async to 2.2. This version of async changed the exceptions thrown, see + https://hackage.haskell.org/package/async-2.2/changelog for more details. + * 0.0.1 - Initial release and cleanup from ambiata/twine - Rename to entwine from twine, due to existing project called twine. diff --git a/entwine.cabal b/entwine.cabal --- a/entwine.cabal +++ b/entwine.cabal @@ -1,5 +1,5 @@ name: entwine -version: 0.0.1 +version: 0.0.2 license: BSD3 license-file: LICENSE author: Ambiata @@ -13,7 +13,7 @@ build-type: Simple description: entwine - Concurrency tools -tested-with: GHC == 8.0.2, GHC == 8.2.2 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4 extra-source-files: README.md Changes.md @@ -25,7 +25,7 @@ library build-depends: base >= 3 && < 5 - , async >= 2.0 && < 2.2 + , async == 2.2.* , containers >= 0.5 && < 0.7 , exceptions >= 0.6 && < 0.9 , monad-loops == 0.4.* @@ -69,10 +69,21 @@ hs-source-dirs: test + other-modules: Test.Disorder + Test.Entwine.Async + Test.Entwine.Data.Duration + Test.Entwine.Data.Finalizer + Test.Entwine.Data.Gate + Test.Entwine.Data.Parallel + Test.Entwine.Data.Pin + Test.Entwine.Data.Queue + Test.Entwine.Parallel + + build-depends: base >= 3 && < 5 , entwine - , async >= 2.0 && < 2.3 + , async == 2.2.* , directory >= 1.2 && < 1.4 , exceptions >= 0.6 && < 0.9 , process >= 1.2 && < 1.7 @@ -83,6 +94,7 @@ , QuickCheck == 2.10.* , quickcheck-instances == 0.3.* + test-suite test-io type: exitcode-stdio-1.0 @@ -93,10 +105,15 @@ hs-source-dirs: test + other-modules: Test.Disorder + Test.IO.Entwine.Guard + Test.IO.Entwine.Loop + Test.IO.Entwine.Snooze + build-depends: base >= 3 && < 5 , entwine - , async >= 2.0 && < 2.3 + , async == 2.2.* , directory >= 1.2 && < 1.4 , exceptions , process >= 1.2 && < 1.7 diff --git a/src/Entwine/Async.hs b/src/Entwine/Async.hs --- a/src/Entwine/Async.hs +++ b/src/Entwine/Async.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} module Entwine.Async ( AsyncTimeout (..) , renderAsyncTimeout @@ -10,10 +11,9 @@ import Control.Concurrent.Async (Async, waitSTM, waitEither) -import Control.Concurrent.Async (async, cancel, wait) +import Control.Concurrent.Async (async, cancel, wait, AsyncCancelled) import Control.Concurrent.STM (atomically, orElse, retry) -import Control.Exception.Base (AsyncException (..)) -import Control.Monad.Catch (catch, throwM) +import Control.Monad.Catch (catches, throwM, Handler(..)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Either @@ -51,18 +51,10 @@ liftIO $ writeIORef r True liftIO $ cancel a (liftIO $ wait a) - `catch` - (\(ae :: AsyncException) -> - case ae of - ThreadKilled -> do - liftIO (readIORef r) >>= - bool (liftIO $ throwM ae) (left $ AsyncTimeout d) - StackOverflow -> - liftIO $ throwM ae - HeapOverflow -> - liftIO $ throwM ae - UserInterrupt -> - liftIO $ throwM ae) + `catches` [ Handler (\ (ax :: AsyncCancelled) -> do + liftIO (readIORef r) >>= + bool (liftIO $ throwM ax) (left $ AsyncTimeout d) + )] waitEitherBoth :: Async a -> Async b -> Async c -> IO (Either a (b, c)) waitEitherBoth a b c = diff --git a/test/Test/Disorder.hs b/test/Test/Disorder.hs new file mode 100644 --- /dev/null +++ b/test/Test/Disorder.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Disorder ( + testIO + , withCPUTime + , disorderMain + , disorderCliMain + ) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) + +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import System.Directory +import System.Process +import System.Exit +import System.IO +import System.CPUTime (getCPUTime) + +testIO :: forall a. (Testable a) => IO a -> Property +testIO mx = monadicIO $ do + p <- (run mx) + stop p :: PropertyM IO a + +-- | Perform an action and return the CPU time it takes, in picoseconds +-- (actual precision varies with implementation). +withCPUTime :: MonadIO m => m a -> m (Integer, a) +withCPUTime a = do + t1 <- liftIO getCPUTime + r <- a + t2 <- liftIO getCPUTime + return (t2 - t1, r) + +disorderMain :: [IO Bool] -> IO () +disorderMain tests = + sanity >> sequence tests >>= \rs -> unless (and rs) exitFailure + +disorderCliMain :: [String] -> IO () +disorderCliMain arguments = + let ignore p = ".." == p || "." == p || "core" == p + exec t = callProcess ("test/cli/" ++ t ++ "/run") arguments + in sanity >> filter (not . ignore) <$> getDirectoryContents "test/cli/" >>= mapM_ exec + +sanity :: IO () +sanity = + hSetBuffering stdout LineBuffering >> hSetBuffering stderr LineBuffering diff --git a/test/Test/Entwine/Async.hs b/test/Test/Entwine/Async.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entwine/Async.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Entwine.Async where + +import Control.Concurrent.Async (async, wait, cancel) +import Control.Monad.Catch (catchAll) +import Control.Monad.Trans.Either + +import Test.Disorder (testIO) + +import Entwine.P + +import System.IO + +import Test.QuickCheck + +import Entwine.Async +import Entwine.Data +import Entwine.Snooze (snooze) + +prop_wait_no_timeout = testIO $ do + a <- async . snooze $ microseconds 5 + e <- runEitherT $ waitWithTimeout a (microseconds 10) + pure $ e === Right () + +prop_cancel_outside = testIO $ do + a <- async $ (snooze (milliseconds 20) >> pure True) + e <- async $ runEitherT $ waitWithTimeout a (milliseconds 5) + cancel a + r <- wait e `catchAll` (\_ -> pure . Right $ False) + pure $ r === Right False + +prop_wait_timeout = testIO $ do + a <- async $ (snooze $ milliseconds 20) + e <- runEitherT $ waitWithTimeout a (milliseconds 5) + pure $ e === Left (AsyncTimeout (milliseconds 5)) + +return [] +tests :: IO Bool +tests = $forAllProperties $ quickCheckWithResult (stdArgs { maxSuccess = 10 }) diff --git a/test/Test/Entwine/Data/Duration.hs b/test/Test/Entwine/Data/Duration.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entwine/Data/Duration.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Entwine.Data.Duration where + +import Entwine.P + +import System.IO + +import Test.QuickCheck + +import Entwine.Data.Duration + +-- +-- Symmetric conversions +-- + +prop_microseconds n = + toMicroseconds (microseconds n) === n + +prop_milliseconds n = + toMilliseconds (milliseconds n) === n + +prop_seconds n = + toSeconds (seconds n) === n + +prop_minutes n = + toMinutes (minutes n) === n + +prop_hours n = + toHours (hours n) === n + +-- +-- Scaling +-- + +prop_microseconds_scale n = + toMicroseconds (microseconds n) === n + +prop_milliseconds_scale n = + toMicroseconds (milliseconds n) === (n * 1000) + +prop_seconds_scale n = + toMicroseconds (seconds n) === (n * 1000 * 1000) + +prop_minutes_scale n = + toMicroseconds (minutes n) === (n * 60 * 1000 * 1000) + +prop_hours_scale n = + toMicroseconds (hours n) === (n * 60 * 60 * 1000 * 1000) + +-- +-- Sanity checks +-- + +prop_sanity = conjoin [ + hours 1 === minutes 60 + , minutes 1 === seconds 60 + , seconds 1 === milliseconds 1000 + , milliseconds 1 === microseconds 1000 + + ] + +return [] +tests :: IO Bool +tests = $quickCheckAll diff --git a/test/Test/Entwine/Data/Finalizer.hs b/test/Test/Entwine/Data/Finalizer.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entwine/Data/Finalizer.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Entwine.Data.Finalizer where + +import Test.Disorder (testIO) + +import Entwine.P + +import System.IO + +import Test.QuickCheck + +import Entwine.Data.Finalizer +import Entwine.Data.Pin + + +prop_simple = once . testIO $ do + p <- newPin + let f = Finalizer $ pullPin p + finalize f + checkPin p + +prop_monoid = once . testIO $ do + p1 <- newPin + p2 <- newPin + let f = Finalizer (pullPin p1) <> Finalizer (pullPin p2) + finalize f + (&&) <$> checkPin p1 <*> checkPin p2 + + +return [] +tests :: IO Bool +tests = $quickCheckAll diff --git a/test/Test/Entwine/Data/Gate.hs b/test/Test/Entwine/Data/Gate.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entwine/Data/Gate.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Entwine.Data.Gate where + +import Test.Disorder (testIO) + +import Entwine.P + +import Test.QuickCheck + +import Entwine.Data.Gate + +-- +-- A new gate should isOpen +-- + +prop_isOpen = once . testIO $ + newGate >>= + isOpen >>= + pure . (===) True + + +-- +-- A gate that has been closed should not be open +-- + +prop_close = once . testIO $ + newGate >>= \c -> + close c >> + isOpen c >>= + pure . (===) False + + +-- +-- A gate can be closed multiple times +-- + +prop_close_multiple = once . testIO $ + newGate >>= \c -> + close c >> close c >> pure True + +return [] +tests = $quickCheckAll diff --git a/test/Test/Entwine/Data/Parallel.hs b/test/Test/Entwine/Data/Parallel.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entwine/Data/Parallel.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Entwine.Data.Parallel where + +import Test.Disorder (testIO) + +import Entwine.P + +import System.IO + +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Entwine.Data.Parallel + +prop_short_circuit = testIO $ do + r <- newResult (Right () :: Either Text ()) + _ <- addResult r (Left "fail") + _ <- addResult r (Right ()) + z <- getResult r + pure $ z === (Left "fail") + +prop_read (a :: Int) = testIO $ do + r <- newResult a + z <- getResult r + pure $ z === a + +prop_read_read (a :: Int) = testIO $ do + r <- newResult a + _ <- getResult r + z <- getResult r + pure $ z === a + +return [] +tests :: IO Bool +tests = $quickCheckAll diff --git a/test/Test/Entwine/Data/Pin.hs b/test/Test/Entwine/Data/Pin.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entwine/Data/Pin.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Entwine.Data.Pin where + +import Control.Concurrent.Async (async, waitBoth) + +import Test.Disorder (testIO) + +import Entwine.P + +import Test.QuickCheck (quickCheckAll, once, (===)) + +import Entwine.Data.Pin + + +-- +-- We are really just testing that our restricted use of MVar +-- is safe. The point of wrapping it up is preventing dead/live +-- locks, and generally make it more pleasant and less error- +-- prone +-- + + +-- +-- A new pin should not be pulled +-- + +prop_new = once . testIO $ + newPin >>= checkPin >>= pure . (===) False + + +-- +-- A pulled pin should be pulled +-- + +prop_pull = once . testIO $ + newPin >>= \p -> pullPin p >> checkPin p >>= pure . (===) True + + +-- +-- A pin can be pulled multiple times without blocking +-- + +prop_pull_pull = once . testIO $ + newPin >>= \p -> pullPin p >> pullPin p >> checkPin p >>= pure . (===) True + +-- +-- A pin can be pulled without blocking +-- + +prop_wait = once . testIO $ + newPin >>= \p -> pullPin p >> waitForPin p >> pure True + + +-- +-- Multiple things can be blocked on a pin +-- +prop_multiple = once . testIO $ + newPin >>= \p -> do + x <- async $ waitForPin p + y <- async $ waitForPin p + pullPin p + r <- waitBoth x y + pure $ r === ((), ()) + +-- +-- Multiple things can be blocked on a pin +-- +prop_multiple_inline = once . testIO $ + newPin >>= \p -> + pullPin p >> waitForPin p >> waitForPin p >> pure True + + +return [] +tests = $quickCheckAll diff --git a/test/Test/Entwine/Data/Queue.hs b/test/Test/Entwine/Data/Queue.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entwine/Data/Queue.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Entwine.Data.Queue where + +import Entwine.P + +import System.IO + +import Test.Disorder +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Entwine.Data.Queue + +prop_read_write (a :: Int) = testIO $ do + q <- newQueue 1 + writeQueue q a + r <- readQueue q + pure $ r === a + +prop_empty = testIO $ do + q <- newQueue 1 + e <- isQueueEmpty q + pure $ e === True + +prop_try_read_non_blocking = testIO $ do + q <- newQueue 1 + m <- tryReadQueue q + pure $ m === (Nothing :: Maybe Int) + +return [] +tests :: IO Bool +tests = $quickCheckAll diff --git a/test/Test/Entwine/Parallel.hs b/test/Test/Entwine/Parallel.hs new file mode 100644 --- /dev/null +++ b/test/Test/Entwine/Parallel.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Entwine.Parallel where + +import Control.Concurrent.MVar +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Either + +import Test.Disorder (testIO) + +import Entwine.P + +import System.IO +import System.IO.Error + +import Test.QuickCheck + +import Entwine.Data +import Entwine.Parallel + +data Fail = + IFailed + +prop_consume = forAll (choose (1, 10 :: Int)) $ \n -> testIO $ do + r <- newMVar ([] :: [Int]) + + let pro = \q -> forM_ [1..n] (writeQueue q) + + work :: Int -> EitherT Fail IO () + work i = + liftIO $ modifyMVar_ r (\l -> pure $ i : l) + + _ <- runEitherT $ consume_ pro 1 work + + g <- readMVar r + + pure $ length g === n + +prop_worker_fail = forAll (choose (1, 1000 :: Int)) $ \n -> testIO $ do + let pro = \q -> forM_ [1..n] (writeQueue q) + work = const $ left IFailed + + r <- runEitherT $ consume_ pro 1 work + z <- pure $ case r of + (Left (WorkerError IFailed)) -> + True + _ -> + False + pure $ z === True + +prop_worker_blow_up_worker = forAll (choose (1, 1000 :: Int)) $ \n -> testIO $ do + let pro = \q -> forM_ [1..n] (writeQueue q) + work = const . throwM . userError $ "what is this?" + + r <- runEitherT $ consume_ pro 1 work + z <- pure $ case r of + (Left (BlowUpError _)) -> + True + _ -> + False + pure $ z === True + +prop_worker_blow_up_producer = testIO $ do + let pro = const . throwM . userError $ "producer" + work = const $ pure () + + r <- runEitherT $ consume_ pro 1 work + z <- pure $ case r of + (Left (BlowUpError _)) -> + True + _ -> + False + pure $ z === True + +prop_empty_producer = testIO $ do + let pro = const $ pure () + work = const $ pure () + + r <- runEitherT $ consume_ pro 1 work + pure $ (isRight r) === True + + +return [] +tests :: IO Bool +tests = $quickCheckAll diff --git a/test/Test/IO/Entwine/Guard.hs b/test/Test/IO/Entwine/Guard.hs new file mode 100644 --- /dev/null +++ b/test/Test/IO/Entwine/Guard.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.IO.Entwine.Guard where + +import Control.Concurrent +import Control.Monad.Catch +import Control.Monad.Trans.Either + +import Test.Disorder + +import Entwine.P + +import System.IO +import System.IO.Error + +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Entwine.Guard + +data HResult = + HExplosion | HError Text | HGraceful deriving (Eq, Show) + +handler v = TerminationHandler { + onExplosion = const $ putMVar v HExplosion >> pure Die + , onError = \t -> putMVar v (HError t) >> pure Die + , onGraceful = putMVar v HGraceful >> pure Die + } + +prop_guard_graceful = + testIO $ do + v <- newEmptyMVar + withThread v (pure ()) $ do + r <- takeMVar v + pure $ r === HGraceful + +prop_guard_error t = + testIO $ do + v <- newEmptyMVar + withThread v (left t) $ do + r <- takeMVar v + pure $ r === HError t + +prop_guard_explosion = + testIO $ do + v <- newEmptyMVar + withThread v (throwM $ userError "explodez") $ do + r <- takeMVar v + pure $ r === HExplosion + +withThread :: MVar HResult -> EitherT Text IO () -> IO a -> IO a +withThread v action = + bracket (forkIO $ guarded (handler v) action) killThread . const + +return [] +tests :: IO Bool +tests = $forAllProperties $ quickCheckWithResult (stdArgs { maxSuccess = 3 }) diff --git a/test/Test/IO/Entwine/Loop.hs b/test/Test/IO/Entwine/Loop.hs new file mode 100644 --- /dev/null +++ b/test/Test/IO/Entwine/Loop.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.IO.Entwine.Loop where + +import Control.Concurrent.Async (async) +import Control.Monad.Trans.Either (runEitherT) + +import Test.Disorder + +import Entwine.P + +import Test.QuickCheck + +import Entwine.Async (waitWithTimeout) +import Entwine.Data.Gate +import Entwine.Data.Duration (milliseconds, seconds) +import Entwine.Loop + +prop_loop = testIO $ do + g <- newGate + x <- async $ loop (milliseconds 1) g (pure ()) >> pure True + close g + r <- runEitherT $ waitWithTimeout x (seconds 1) + pure $ r === Right True + +return [] +tests = $quickCheckAll diff --git a/test/Test/IO/Entwine/Snooze.hs b/test/Test/IO/Entwine/Snooze.hs new file mode 100644 --- /dev/null +++ b/test/Test/IO/Entwine/Snooze.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.IO.Entwine.Snooze where + +import Data.Time + +import Test.Disorder + +import Entwine.P + +import System.IO + +import Test.QuickCheck + +import Entwine.Snooze + + +prop_snooze = forAll (choose (1, 3)) $ \n -> testIO $ do + s <- getCurrentTime + snooze . seconds $ n + e <- getCurrentTime + let elapsed = diffUTCTime e s + let expected = (fromInteger . toInteger) n + pure . counterexample ("Elapsed: " <> show elapsed <> " , Snooze: " <> show expected) $ + elapsed >= expected && elapsed < expected + 1 + + +return [] +tests :: IO Bool +tests = $forAllProperties $ quickCheckWithResult (stdArgs { maxSuccess = 3 })