summaryrefslogtreecommitdiff
path: root/tests/test.hs
blob: c1e2d3e0bc0a42d4dabb5e86cd8a32cbe9718311 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
import Test.Tasty
import Test.Tasty.HUnit
import qualified Control.Immortal as Immortal
import Control.Monad
import Control.Exception
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad.Trans.State
import Control.Monad.IO.Class
import System.Timeout

-- Almost bracket, but we don't want to start a thread inside mask
-- See http://ro-che.info/articles/2014-07-30-bracket.html
withImmortal :: IO () -> IO c -> IO c
withImmortal comp inner = do
  thread <- Immortal.create $ const comp
  inner `finally` Immortal.stop thread

withImmortalThread :: (Immortal.Thread -> IO ()) -> (Immortal.Thread -> IO c) -> IO c
withImmortalThread comp inner = do
  thread <- Immortal.create comp
  inner thread `finally` Immortal.stop thread

main :: IO ()
main = defaultMain $ testGroup "Tests"
  [ testCase "is not killed by an exception" $ do
      tv <- atomically $ newTVar True
      immortal <- Immortal.create $ const $ keepTrue tv

      killThread (Immortal.threadId immortal)
      atomically $ writeTVar tv False
      delay
      v <- atomically $ readTVar tv
      assertBool "Thread died" v

  , testCase "never finishes" $ do
      tv <- atomically $ newTVar False
      withImmortal (keepTrue tv) $
        replicateM_ 10 $ do
          atomically $ writeTVar tv False
          delay
          v <- atomically $ readTVar tv
          assertBool "Thread died" v

  , testCase "can be stopped" $ do
      tv <- atomically $ newTVar True
      immortal <- Immortal.create $ const $ keepTrue tv

      Immortal.stop immortal
      atomically $ writeTVar tv False
      delay
      v <- atomically $ readTVar tv
      assertBool "Thread did not stop" (not v)

  , testCase "state is preserved when there are no exceptions" $ do
      tv <- atomically $ newTVar 0
      pid <- flip evalStateT 0 $ Immortal.create $ const $ countToFive tv
      (do
        delay
        v <- atomically $ readTVar tv
        v @?= 5) `finally` Immortal.stop pid

  , testCase "state is reset when there are exceptions" $ do
      tv <- atomically $ newTVar 0
      let
        computation = do
          countToFive tv
          liftIO delay
          error "bah!"
      pid <- flip evalStateT 0 $ Immortal.create $ const computation
      (do
        threadDelay (5*10^5)
        v <- atomically $ readTVar tv
        v @?= 0)
        `finally` Immortal.stop pid

  , testCase "onFinish detects normal exit" $ do
      tv <- atomically $ newTVar Nothing
      let
        comp =
          Immortal.onFinish
            (\r -> atomically $ writeTVar tv (Just r))
            (liftIO delay)
      withImmortal comp $ do
        threadDelay (2*10^5)
        v <- atomically $ readTVar tv
        case v of
          Just (Right ()) -> return ()
          _ -> assertFailure $ "unexpected result: " ++ show v

  , testCase "onFinish detects abnormal exit" $ do
      tv <- atomically $ newTVar Nothing
      let
        comp =
          Immortal.onFinish
            (\r -> atomically $ writeTVar tv (Just r))
            (do liftIO delay; error "bah!")
      withImmortal comp $ do
        threadDelay (2*10^5)
        v <- atomically $ readTVar tv
        case v of
          Just (Left (fromException -> Just (ErrorCall "bah!"))) -> return ()
          _ -> assertFailure $ "unexpected result: " ++ show v

  , testCase "onUnexpectedFinish fires when thread is immortal" $ do
      tv <- atomically $ newTVar Nothing
      let
        comp thread =
          Immortal.onUnexpectedFinish thread
            (\r -> atomically $ writeTVar tv (Just r))
            (liftIO delay)
      withImmortalThread comp $ \_ -> do
        threadDelay (2*10^5)
        v <- atomically $ readTVar tv
        case v of
          Just (Right ()) -> return ()
          _ -> assertFailure $ "unexpected result: " ++ show v

  , testCase "onUnexpectedFinish does not fire when thread is mortal" $ do
      tv <- atomically $ newTVar Nothing
      let
        comp thread =
          Immortal.onUnexpectedFinish thread
            (\r -> atomically $ writeTVar tv (Just r))
            (do Immortal.mortalize thread; liftIO delay)
      withImmortalThread comp $ \_ -> do
        threadDelay (2*10^5)
        v <- atomically $ readTVar tv
        case v of
          Nothing -> return ()
          _ -> assertFailure $ "unexpected result: " ++ show v

  , testCase "mortalize allows thread to finish" $ do
      tv <- atomically $ newTVar True
      t <- Immortal.create $ const $ keepTrue tv
      Immortal.mortalize t
      atomically $ writeTVar tv False
      delay
      v1 <- atomically $ readTVar tv
      -- thread was waiting for this; v1 should be True
      v1 @?= True
      -- since the thread was mortalized, it shouldn't be restarted
      -- so try the same actions again
      atomically $ writeTVar tv False
      delay
      v2 <- atomically $ readTVar tv
      -- and we now should get False
      v2 @?= False

  , testCase "immortalize cancels mortalize" $ do
      -- this is the copy of the previous test, only after mortalize we
      -- immediately call immortalize
      tv <- atomically $ newTVar True
      t <- Immortal.create $ const $ keepTrue tv
      Immortal.mortalize t
      Immortal.immortalize t
      atomically $ writeTVar tv False
      delay
      v1 <- atomically $ readTVar tv
      v1 @?= True
      atomically $ writeTVar tv False
      delay
      v2 <- atomically $ readTVar tv
      v2 @?= True
      Immortal.stop t

  , testCase "cancelling from within the thread works" $ do
      -- tv1 checks that the thread stopped running
      -- tv2 checks that the exception was thrown
      tv1 <- atomically $ newTVar False
      tv2 <- atomically $ newTVar False
      _ <- Immortal.create $ \thread -> do
        keepTrue tv1
        Immortal.stop thread
        atomically $ writeTVar tv1 True

      delay
      atomically $ writeTVar tv1 False
      delay
      v1 <- atomically $ readTVar tv1
      v2 <- atomically $ readTVar tv2
      v1 @?= False
      v2 @?= False

  , testCase "wait is called after the thread is stopped" $ do
      thread <- Immortal.create $ \_ -> threadDelay maxBound
      _ <- forkIO $ threadDelay (10^4) >> Immortal.stop thread
      result <- timeout (10^5) $ Immortal.wait thread

      result @?= Just ()

  , testCase "wait waits long enough" $ do
      tv <- atomically $ newTVar True
      thread <- Immortal.create $ \t -> do
        delay
        atomically $ writeTVar tv False
        Immortal.stop t
      _ <- Immortal.wait thread

      v <- atomically $ readTVar tv
      v @?= False
  ]

keepTrue :: TVar Bool -> IO ()
keepTrue tv = atomically $ do
  v <- readTVar tv
  check $ not v
  writeTVar tv True

sleep :: IO ()
sleep = threadDelay (60 * 10^6) -- 1 min

delay :: IO ()
delay = threadDelay (10^5) -- 0.1 s

countToFive :: TVar Int -> StateT Int IO ()
countToFive tv = do
  n <- get
  liftIO $ atomically $ writeTVar tv n
  if n == 5
    then liftIO sleep
    else put $! n+1