f8533f0 · distributed-process

git.iko.soy/distributed-process

fiddle around with the lack of a MonadFail in the stack...

commitf8533f0b14cd01a7702b8d8f03276d813c9c4727 authorTim Watson <watson.timothy@gmail.com> dateSat 10 Nov 2018, 18:07 (8 years ago) parent082d5b5

5 files changed+106−52

compare with master

unifiedsplit

distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs+61−30 distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs+11−7 distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs+23−11 src/Control/Distributed/Process/Internal/Primitives.hs+4−2 src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs+7−2

distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs+61−30

@@ -169,8 +169,11 @@ testUnclosure TestTransport{..} rtable = do

169169 node <- newLocalNode testTransport rtable

170170 done <- newEmptyMVar

171171 forkProcess node $ do

172− 120 <- join . unClosure $ factorialClosure 5

172+ i <- join . unClosure $ factorialClosure 5

173173 liftIO $ putMVar done ()

174+ if i == 720

175+ then return ()

176+ else error "Something went horribly wrong"

174177 takeMVar done

175178

176179testBind :: TestTransport -> RemoteTable -> Assertion

@@ -180,8 +183,11 @@ testBind TestTransport{..} rtable = do

180183 runProcess node $ do

181184 us <- getSelfPid

182185 join . unClosure $ sendFac 6 us

183− (720 :: Int) <- expect

186+ (i :: Int) <- expect

184187 liftIO $ putMVar done ()

188+ if i == 720

189+ then return ()

190+ else error "Something went horribly wrong"

185191 takeMVar done

186192

187193testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

@@ -194,7 +200,7 @@ testSendPureClosure TestTransport{..} rtable = do

194200 addr <- forkProcess node $ do

195201 cl <- expect

196202 fn <- unClosure cl :: Process (Int -> Int)

197− 13 <- return $ fn 6

203+ (_ :: Int) <- return $ fn 6

198204 liftIO $ putMVar serverDone ()

199205 putMVar serverAddr addr

200206

@@ -218,8 +224,11 @@ testSendIOClosure TestTransport{..} rtable = do

218224 liftIO $ do

219225 someMVar <- newEmptyMVar

220226 io someMVar

221− 5 <- readMVar someMVar

227+ i <- readMVar someMVar

222228 putMVar serverDone ()

229+ if i == 5

230+ then return ()

231+ else error "Something went horribly wrong"

223232 putMVar serverAddr addr

224233

225234 forkIO $ do

@@ -248,8 +257,10 @@ testSendProcClosure TestTransport{..} rtable = do

248257 runProcess node $ do

249258 pid <- getSelfPid

250259 send theirAddr (cpSend $(mkStatic 'sdictInt) pid)

251− 5 <- expect :: Process Int

252− liftIO $ putMVar clientDone ()

260+ i <- expect :: Process Int

261+ if i == 5

262+ then liftIO $ putMVar clientDone ()

263+ else error "Something went horribly wrong"

253264

254265 takeMVar clientDone

255266

@@ -269,8 +280,9 @@ testSpawn TestTransport{..} rtable = do

269280 pid <- getSelfPid

270281 pid' <- spawn nid (sendPidClosure pid)

271282 pid'' <- expect

272− True <- return $ pid' == pid''

273− liftIO $ putMVar clientDone ()

283+ if pid' == pid''

284+ then liftIO $ putMVar clientDone ()

285+ else error "Something went horribly wrong"

274286

275287 takeMVar clientDone

276288

@@ -294,8 +306,9 @@ testSpawnRace TestTransport{..} rtable = do

294306 spawnLocal $ spawn (localNodeId node2) (sendPidClosure pid) >>= send pid

295307 pid' <- expect :: Process ProcessId

296308 pid'' <- expect :: Process ProcessId

297− True <- return $ pid' == pid''

298− return ()

309+ if pid' == pid''

310+ then return ()

311+ else error "Something went horribly wrong"

299312

300313 where

301314

@@ -332,8 +345,10 @@ testCall TestTransport{..} rtable = do

332345 node <- newLocalNode testTransport rtable

333346 nid <- readMVar serverNodeAddr

334347 runProcess node $ do

335− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)

336− liftIO $ putMVar clientDone ()

348+ (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)

349+ if a == 120

350+ then liftIO $ putMVar clientDone ()

351+ else error "something went horribly wrong"

337352

338353 takeMVar clientDone

339354

@@ -350,8 +365,10 @@ testCallBind TestTransport{..} rtable = do

350365 node <- newLocalNode testTransport rtable

351366 nid <- readMVar serverNodeAddr

352367 runProcess node $ do

353− (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)

354− liftIO $ putMVar clientDone ()

368+ (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)

369+ if a == 120

370+ then liftIO $ putMVar clientDone ()

371+ else error "Something went horribly wrong"

355372

356373 takeMVar clientDone

357374

@@ -362,9 +379,11 @@ testSeq TestTransport{..} rtable = do

362379 runProcess node $ do

363380 us <- getSelfPid

364381 join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us

365− 120 :: Int <- expect

366− 720 :: Int <- expect

367− liftIO $ putMVar done ()

382+ a :: Int <- expect

383+ b :: Int <- expect

384+ if a == 120 && b == 720

385+ then liftIO $ putMVar done ()

386+ else error "Something went horribly wrong"

368387 takeMVar done

369388

370389-- Test 'spawnSupervised'

@@ -407,12 +426,15 @@ testSpawnSupervised TestTransport{..} rtable = do

407426 liftIO $ putMVar linkUp ()

408427 -- because monitor message was sent before message to process

409428 -- we hope that it will be processed before

410− ProcessMonitorNotification ref' pid' (DiedException e) <- expect

411− True <- return $ ref' == ref

412− && pid' == child

413− && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))

414− liftIO $ putMVar thirdProcessDone ()

415−

429+ res <- expect

430+ case res of

431+ (ProcessMonitorNotification ref' pid' (DiedException e)) ->

432+ if (ref' == ref && pid' == child &&

433+ e == show (ProcessLinkException super

434+ (DiedException (show supervisorDeath))))

435+ then liftIO $ putMVar thirdProcessDone ()

436+ else error "Something went horribly wrong"

437+ _ -> error "Something went horribly wrong"

416438 takeMVar thirdProcessDone

417439 where

418440 supervisorDeath :: IOException

@@ -426,8 +448,10 @@ testSpawnInvalid TestTransport{..} rtable = do

426448 (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)

427449 ProcessMonitorNotification ref' pid' _reason <- expect

428450 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure

429− True <- return $ ref' == ref && pid == pid'

430− liftIO $ putMVar done ()

451+ res <- return $ ref' == ref && pid == pid'

452+ if res == True

453+ then liftIO $ putMVar done ()

454+ else error "Something went horribly wrong"

431455 takeMVar done

432456

433457testClosureExpect :: TestTransport -> RemoteTable -> Assertion

@@ -439,8 +463,10 @@ testClosureExpect TestTransport{..} rtable = do

439463 us <- getSelfPid

440464 them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us

441465 send them (1234 :: Int)

442− (1234 :: Int) <- expect

443− liftIO $ putMVar done ()

466+ (res :: Int) <- expect

467+ if res == 1234

468+ then liftIO $ putMVar done ()

469+ else error "Something went horribly wrong"

444470 takeMVar done

445471

446472testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

@@ -465,8 +491,10 @@ testTDict TestTransport{..} rtable = do

465491 done <- newEmptyMVar

466492 [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable

467493 forkProcess node1 $ do

468− True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))

469− liftIO $ putMVar done ()

494+ res <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))

495+ if res == True

496+ then liftIO $ putMVar done ()

497+ else error "Something went horribly wrong..."

470498 takeMVar done

471499

472500testFib :: TestTransport -> RemoteTable -> Assertion

@@ -503,9 +531,12 @@ testSpawnReconnect testtrans@TestTransport{..} rtable = do

503531 liftIO $ threadDelay 100000

504532

505533 count <- liftIO $ takeMVar iv

506− True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'

534+ res <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'

507535

508536 liftIO $ putMVar done ()

537+ if res /= True

538+ then error "Something went horribly wrong"

539+ else return ()

509540

510541 takeMVar done

511542

distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs+11−7

@@ -29,7 +29,7 @@ import Test.Framework.Providers.HUnit (testCase)

2929

3030testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()

3131testLocalDeadProcessInfo result = do

32− pid <- spawnLocal $ do "finish" <- expect; return ()

32+ pid <- spawnLocal $ do (_ :: String) <- expect; return ()

3333 mref <- monitor pid

3434 send pid "finish"

3535 _ <- receiveWait [

@@ -52,8 +52,10 @@ testLocalLiveProcessInfo result = do

5252 link self

5353 mRef <- monitor self

5454 stash mon mRef

55− "die" <- expect

56− return ()

55+ res <- expect

56+ case res of

57+ "die" -> return ()

58+ _ -> die $ "unexpected message received: " ++ res

5759

5860 monRef <- liftIO $ takeMVar mon

5961

@@ -84,9 +86,9 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do

8486 -- our send op shouldn't overtake link or monitor requests AFAICT

8587 -- so a little table tennis should get us synchronised properly

8688 send serverPid (self, "ping")

87− "pong" <- expect

89+ pong <- expect

8890 pInfo <- getProcessInfo serverPid

89− stash result $ pInfo /= Nothing

91+ stash result $ pong == "pong" && pInfo /= Nothing

9092 where

9193 launchRemote :: MVar ProcessId -> IO ()

9294 launchRemote locMV = do

@@ -97,8 +99,10 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do

9799 _ <- receiveWait [

98100 match (\(pid, "ping") -> send pid "pong")

99101 ]

100− "stop" <- expect

101− return ()

102+ res <- expect

103+ case res of

104+ "stop" -> return ()

105+ _ -> die $ "unexpected message received: " ++ res

102106 return ()

103107

104108 withActiveRemote :: LocalNode

distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs+23−11

@@ -125,9 +125,11 @@ testTraceSending result = do

125125 (\ev ->

126126 case ev of

127127 (MxSent to from msg) -> do

128− (Just s) <- unwrapMessage msg :: Process (Maybe String)

129− stash res (to == pid && from == self && s == "hello there")

130− stash res (to == pid && from == self)

128+ mS <- unwrapMessage msg :: Process (Maybe String)

129+ case mS of

130+ (Just s) -> do stash res (to == pid && from == self && s == "hello there")

131+ stash res (to == pid && from == self)

132+ _ -> die "failed state invariant, message type unmatched..."

131133 _ ->

132134 return ()) $ do

133135 send pid "hello there"

@@ -246,12 +248,8 @@ testRemoteTraceRelay TestTransport{..} result =

246248 -- Here we set up that relay, and then wait for a signal

247249 -- that the tracer (on node1) has seen the expected

248250 -- MxSpawned message, at which point we're finished

249− (Just log') <- whereis "logger"

250− pid <- liftIO $ forkProcess node2 $ do

251− logRelay <- spawnLocal $ relay log'

252− reregister "logger" logRelay

253− getSelfNode >>= stash mvNid >> (expect :: Process ())

254251

252+ pid <- splinchLogger node2 mvNid

255253 nid <- liftIO $ takeMVar mvNid

256254 mref <- monitor pid

257255 observedPid <- liftIO $ newEmptyMVar

@@ -291,6 +289,17 @@ testRemoteTraceRelay TestTransport{..} result =

291289 -- and just to be polite...

292290 liftIO $ closeLocalNode node2

293291

292+ where

293+ splinchLogger n2 mv = do

294+ mLog <- whereis "logger"

295+ case mLog of

296+ Nothing -> die "no logger registered"

297+ Just log' -> do liftIO $ forkProcess n2 $ do

298+ logRelay <- spawnLocal $ relay log'

299+ reregister "logger" logRelay

300+ getSelfNode >>= stash mv >> (expect :: Process ())

301+

302+

294303-- | Sets the value of an environment variable while executing the given IO

295304-- computation and restores the preceeding value upon completion.

296305withEnv :: String -> String -> IO a -> IO a

@@ -319,9 +328,12 @@ testSystemLoggerMsg t action interestingMessage =

319328 -- Wait for the trace message.

320329 receiveWait [ matchIf interestingMessage' $ const $ return () ]

321330 -- Only one interesting message should arrive.

322− Nothing <- receiveTimeout 100000

323− [ matchIf interestingMessage' $ const $ return () ]

324− return ()

331+ expectedTimeout <- receiveTimeout

332+ 100000

333+ [ matchIf interestingMessage' $ const $ return () ]

334+ case expectedTimeout of

335+ Nothing -> return ()

336+ Just _ -> die "Unexpected message arrived..."

325337

326338

327339-- | Tests that one and only one trace message is produced when a message is

src/Control/Distributed/Process/Internal/Primitives.hs+4−2

@@ -400,8 +400,10 @@ newtype Match b = Match { unMatch :: MatchOn Message (Process b) }

400400receiveWait :: [Match b] -> Process b

401401receiveWait ms = do

402402 queue <- processQueue <$> ask

403− Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)

404− proc

403+ mProc <- liftIO $ dequeue queue Blocking (map unMatch ms)

404+ case mProc of

405+ Just proc' -> proc'

406+ Nothing -> error "Well... That wasn't supposed to happen! o_O"

405407

406408-- | Like 'receiveWait' but with a timeout.

407409--

src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs+7−2

@@ -33,6 +33,7 @@ import Control.Distributed.Process.Internal.Primitives

3333 ( whereis

3434 , newChan

3535 , receiveChan

36+ , die

3637 )

3738import Control.Distributed.Process.Management.Internal.Trace.Types

3839 ( TraceArg(..)

@@ -168,6 +169,10 @@ withRegisteredTracer act = do

168169 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp

169170 currentTracer <- receiveChan rp

170171 case currentTracer of

171− Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }

172+ Nothing -> do mTP <- whereis "tracer.initial"

173+ -- NB: this should NOT ever happen, but forcing pattern matches

174+ -- is not considered cool in later versions of MonadFail

175+ case mTP of

176+ Just p' -> act p'

177+ Nothing -> die "Initial Tracer Name Not Registered"

172178 (Just p) -> act p

173−