di-core-1.0.3: test/Main.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Applicative ((<|>))
import Control.Monad (void, (>=>))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Concurrent (myThreadId, threadDelay)
import qualified Control.Exception as Ex (AsyncException(UserInterrupt, ThreadKilled),
asyncExceptionFromException, asyncExceptionToException)
import qualified Control.Exception.Safe as Ex
import Control.Concurrent.STM
(STM, atomically, retry,
TQueue, newTQueueIO, writeTQueue, tryReadTQueue, flushTQueue)
import Data.Foldable (for_, toList)
import Data.Function (fix)
import qualified Data.List as List
import Data.Monoid (Sum(Sum, getSum))
import qualified Data.Time.Clock.System as Time
import qualified Test.Tasty as Tasty
import qualified Test.Tasty.HUnit as HU
import Test.Tasty.HUnit ((@?=), (@=?))
import qualified Test.Tasty.QuickCheck as QC
import qualified Test.Tasty.Runners as Tasty
import qualified Di.Core as Di
--------------------------------------------------------------------------------
main :: IO ()
main = Tasty.defaultMainWithIngredients
[ Tasty.consoleTestReporter
, Tasty.listingTests
] tt
tt :: Tasty.TestTree
tt = Tasty.testGroup "di-core"
[ QC.testProperty "log one" $ do
QC.forAll genLogInt $ \log0 -> do
QC.ioProperty $ do
expect [logMeta log0] $ \di0 -> do
let (l,ps,m) = logMeta log0
Di.log (pushFifo ps di0) l m
, QC.testProperty "log many" $ do
QC.forAll (QC.vectorOf 10 genLogInt) $ \logs0 -> do
QC.ioProperty $ do
expect (map logMeta logs0) $ \di0 -> do
for_ logs0 $ \log_ -> do
let (l,ps,m) = logMeta log_
Di.log (pushFifo ps di0) l m
, HU.testCase "push" $ do
let x = [(0,[],0), (0,[0],0), (0,[1],0), (0,[1,2],0),
(0,[1,2],0), (0,[1,2,3],0), (0,[1,2,3],0), (0,[],0)]
expect x $ \di0 -> do
Di.log di0 0 0
-- Identity
Di.log (Di.push 0 di0) 0 0
-- Composition
Di.log (Di.push 1 di0) 0 0
Di.log ((Di.push 2 . Di.push 1) di0) 0 0
Di.log (pushFifo [1,2] di0) 0 0
Di.log ((Di.push 3 . Di.push 2 . Di.push 1) di0) 0 0
Di.log (pushFifo [1,2,3] di0) 0 0
-- Checking that di0 still works
Di.log di0 0 0
, HU.testCase "contralevel" $ do
let x = [("1",[],0), ("1",[],0), ("1",[],0),
("2",[],0), ("2",[],0), ("1",[],0)]
n = 1 :: Int
expect (x :: [(String, [Int], Int)]) $ \di0 -> do
Di.log di0 "1" 0
-- Identity
Di.log (Di.contralevel id di0) "1" 0
-- Composition
Di.log (Di.contralevel show di0) n 0
Di.log ((Di.contralevel succ . Di.contralevel show) di0) n 0
Di.log (Di.contralevel (show . succ) di0) n 0
-- Checking that di0 still works
Di.log di0 "1" 0
, HU.testCase "contrapath" $ do
let x = [(0,[],0), (0,["1"],0), (0,["1"],0), (0,["1"],0),
(0,["2"],0), (0,["2"],0), (0,[],0)]
n = 1 :: Int
expect x $ \di0 -> do
Di.log di0 0 0
Di.log (Di.push "1" di0) 0 0
-- Identity
Di.log (Di.push "1" (Di.contrapath id di0)) 0 0
-- Composition
Di.log (Di.push n (Di.contrapath show di0)) 0 0
Di.log (Di.push n (Di.contrapath (show . succ) di0)) 0 0
Di.log (Di.push n ((Di.contrapath succ . Di.contrapath show) di0)) 0 0
-- Checking that di0 still works
Di.log di0 0 0
, HU.testCase "contramsg" $ do
let x = [(0,[],"1"), (0,[],"1"), (0,[],"1"),
(0,[],"2"), (0,[],"2"), (0,[],"1")]
n = 1 :: Int
expect (x :: [(Int,[Int],String)]) $ \di0 -> do
Di.log di0 0 "1"
-- Identity
Di.log (Di.contramsg id di0) 0 "1"
-- Composition
Di.log (Di.contramsg show di0) 0 n
Di.log ((Di.contramsg succ . Di.contramsg show) di0) 0 n
Di.log (Di.contramsg (show . succ) di0) 0 n
-- Checking that di0 still works
Di.log di0 0 "1"
, HU.testCase "filter" $ do
let x = [(1,[],"a"), (1,[],"b2"), (1,[],"b4"), (1,[],"b6"),
(4,[1],"b8"), (4,[1,2],"b10"), (1,[],"c"),
(3,[],"g"), (3,[],"j"), (3,[],"m"), (1,[],"n")]
expect (x :: [(Int,[Int],String)]) $ \di0 -> do
Di.log di0 1 "a"
-- Predicates
Di.log (Di.filter (\l ps m -> l /= 1) di0) 1 "b1"
Di.log (Di.filter (\l ps m -> l == 1) di0) 1 "b2"
Di.log (Di.filter (\l ps m -> m /= "b3") di0) 1 "b3"
Di.log (Di.filter (\l ps m -> m == "b4") di0) 1 "b4"
Di.log (Di.filter (\l ps m -> ps /= []) di0) 1 "b5"
Di.log (Di.filter (\l ps m -> ps == []) di0) 1 "b6"
Di.log (Di.push 1 (Di.filter (\l ps m -> ps /= [1]) di0)) 4 "b7"
Di.log (Di.push 1 (Di.filter (\l ps m -> ps == [1]) di0)) 4 "b8"
Di.log (Di.push 2 (Di.push 1 (Di.filter (\l ps m -> ps /= [1,2]) di0))) 4 "b9"
Di.log (Di.push 2 (Di.push 1 (Di.filter (\l ps m -> ps == [1,2]) di0))) 4 "b10"
-- Identity
Di.log (Di.filter (\_ _ _ -> True) di0) 1 "c"
-- Composition
Di.log ((Di.filter (\l _ _ -> l /= 1) . Di.filter (\l _ _ -> l /= 2)) di0) 1 "e"
Di.log ((Di.filter (\l _ _ -> l /= 1) . Di.filter (\l _ _ -> l /= 2)) di0) 2 "f"
Di.log ((Di.filter (\l _ _ -> l /= 1) . Di.filter (\l _ _ -> l /= 2)) di0) 3 "g"
Di.log (Di.filter (\l _ _ -> l /= 1 && l /= 2) di0) 1 "h"
Di.log (Di.filter (\l _ _ -> l /= 1 && l /= 2) di0) 2 "i"
Di.log (Di.filter (\l _ _ -> l /= 1 && l /= 2) di0) 3 "j"
-- Conmutativity (c.f., "e" "f" "g")
Di.log ((Di.filter (\l _ _ -> l /= 2) . Di.filter (\l _ _ -> l /= 1)) di0) 1 "k"
Di.log ((Di.filter (\l _ _ -> l /= 2) . Di.filter (\l _ _ -> l /= 1)) di0) 2 "l"
Di.log ((Di.filter (\l _ _ -> l /= 2) . Di.filter (\l _ _ -> l /= 1)) di0) 3 "m"
-- Checking that di0 still works
Di.log di0 1 "n"
, HU.testCase "STM" $ do
let x = [(2,[],"b"), (3,[],"c")] :: [(Int,[Int],String)]
n = 1 :: Int
(logs, a) <- withInMemoryDi $ \di0 -> do
atomically $
(Di.log' id di0 1 "a" >> retry) <|>
(Di.log' id di0 2 "b" >> Di.log' id di0 3 "c")
-- Check that 'retry' prevents logs from being commited.
x @=? map logMeta logs
-- Check that the timestamps are not all the same.
2 @=? List.length (List.nub (List.sort (map Di.log_time logs)))
, HU.testCase "onExceptions: sync logging" $ do
let x = [(0::Int, ([] :: [Int]),"foo")]
expect x $ \di0 -> do
let di1 = Di.onException
(Ex.fromException >=> \(MyError x) -> Just (0, [], x)) di0
Ex.try (Di.throw di1 (MyError "foo")) >>= \case
Left (MyError "foo") -> pure ()
Right () -> error "got ()"
, HU.testCase "onExceptions: async(ish) logging" $ do
-- We would use throwTo ideally, but that would skip logging. This mostly
-- checks that a SomeAsyncException wrapper doesn't change things.
let x = [(0::Int, ([] :: [Int]),"foo")]
expect x $ \di0 -> do
let di1 = Di.onException
(Ex.asyncExceptionFromException
>=> \(MyError x) -> Just (0, [], x)) di0
me <- myThreadId
Ex.tryAsync (Di.throw di1 (Ex.asyncExceptionToException (MyError "foo")))
>>= \case Left se | Ex.asyncExceptionFromException se
== Just (MyError "foo") -> pure ()
| otherwise -> error ("got " ++ show se)
Right () -> error "got ()"
, HU.testCase "Exceptions: Sync in commit" $ do
let m = Di.new (const throwSyncException)
(\(di :: Di.Di () () ()) -> do
-- This delay here is to ensure the body has time
-- to receive the exception from the commit.
threadDelay 100000)
Ex.tryAny m >>= \case
Right () -> pure ()
x -> fail ("Got " ++ show x)
, HU.testCase "Exceptions: Sync in body" $ do
let m = Di.new (const (pure ()))
(const throwSyncException)
Ex.tryAny m >>= \case
Left se | Ex.fromException se == Just (userError "foo") -> pure ()
x -> fail ("Got " ++ show x)
, HU.testCase "Exceptions: Async in commit" $ do
let m = Di.new (const throwAsyncException)
(\(di :: Di.Di () () ()) -> do
Di.log di () ()
-- This delay here is to ensure the body has time
-- to receive the exception from the commit.
threadDelay 100000)
Ex.tryAsync m >>= \case
Left (se :: Ex.SomeException) ->
case Ex.asyncExceptionFromException se of
Just (Di.ExceptionInLoggingWorker se')
| Ex.asyncExceptionFromException se'
== Just (userError "bar") -> pure ()
x -> fail ("Got " ++ show x)
x -> fail ("Got " ++ show x)
, HU.testCase "Exceptions: Async in body" $ do
let m = Di.new (const (pure ()))
(const throwAsyncException)
Ex.tryAsync m >>= \case
Left (se :: Ex.SomeException)
| Ex.asyncExceptionFromException se
== Just (userError "bar") -> pure ()
x -> fail ("Got " ++ show x)
]
throwSyncException :: Ex.MonadThrow m => m ()
throwSyncException = Ex.throwM (userError "foo")
throwAsyncException :: MonadIO m => m ()
throwAsyncException = liftIO $ do
me <- myThreadId
Ex.throwTo me (Ex.asyncExceptionToException (userError "bar"))
--------------------------------------------------------------------------------
withInMemoryDi
:: (MonadIO m, Ex.MonadMask m)
=> (Di.Di level path msg -> m a)
-> m ([Di.Log level path msg], a)
withInMemoryDi k = do
tq <- liftIO newTQueueIO
a <- Di.new (atomically . writeTQueue tq) k
logs <- liftIO (atomically (flushTQueue tq))
pure (logs, a)
expect
:: (MonadIO m, Ex.MonadMask m,
Eq level, Eq path, Eq msg,
Show level, Show path, Show msg)
=> [(level, [path], msg)]
-- ^ Each of the elements matches 'logMeta'.
-> (Di.Di level path msg -> m a)
-> m a
expect metas0 k = do
(logs1, a) <- withInMemoryDi k
liftIO (metas0 @=? map logMeta logs1)
pure a
-- | Repeatedly run 'Di.push' on the given paths.
pushFifo
:: [path]
-- ^ Paths are in FIFO order. That is, the leftmost @path@ is the
-- root path.
-> Di.Di level path msg
-> Di.Di level path msg
pushFifo [] = id
pushFifo (p:ps) = pushFifo ps . Di.push p
logMeta
:: Di.Log level path msg
-> (level, [path], msg)
-- ^ Paths are in FIFO order. That is, the leftmost @path@ is the
-- root path.
logMeta x = (Di.log_level x , toList (Di.log_path x) , Di.log_message x)
genLogInt :: QC.Gen (Di.Log Int Int Int)
genLogInt = Di.Log <$> QC.arbitrary <*> QC.arbitrary
<*> QC.arbitrary <*> QC.arbitrary
instance QC.Arbitrary Time.SystemTime where
arbitrary = do
a <- QC.choose (0, 253402300799) -- up to 4 digit years
b <- QC.choose (0, 1000000000)
pure (Time.MkSystemTime a b)
data MyError = MyError !String deriving (Eq, Show)
instance Ex.Exception MyError