f8533f0 · distributed-process

git.iko.soy/distributed-process

on master help sign in

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

f8533f0Tim Watson8 years ago

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

compare with master

unifiedsplit

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

169 node <- newLocalNode testTransport rtable

170 done <- newEmptyMVar

171 forkProcess node $ do

172− 120 <- join . unClosure $ factorialClosure 5

172+ i <- join . unClosure $ factorialClosure 5

173 liftIO $ putMVar done ()

174+ if i == 720

175+ then return ()

176+ else error "Something went horribly wrong"

174 takeMVar done

177 takeMVar done

175

178

176testBind :: TestTransport -> RemoteTable -> Assertion

179testBind :: TestTransport -> RemoteTable -> Assertion

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

180 runProcess node $ do

183 runProcess node $ do

181 us <- getSelfPid

184 us <- getSelfPid

182 join . unClosure $ sendFac 6 us

185 join . unClosure $ sendFac 6 us

183− (720 :: Int) <- expect

186+ (i :: Int) <- expect

184 liftIO $ putMVar done ()

187 liftIO $ putMVar done ()

188+ if i == 720

189+ then return ()

190+ else error "Something went horribly wrong"

185 takeMVar done

191 takeMVar done

186

192

187testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

193testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

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

194 addr <- forkProcess node $ do

200 addr <- forkProcess node $ do

195 cl <- expect

201 cl <- expect

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

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

197− 13 <- return $ fn 6

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

198 liftIO $ putMVar serverDone ()

204 liftIO $ putMVar serverDone ()

199 putMVar serverAddr addr

205 putMVar serverAddr addr

200

206

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

218 liftIO $ do

224 liftIO $ do

219 someMVar <- newEmptyMVar

225 someMVar <- newEmptyMVar

220 io someMVar

226 io someMVar

221− 5 <- readMVar someMVar

227+ i <- readMVar someMVar

222 putMVar serverDone ()

228 putMVar serverDone ()

229+ if i == 5

230+ then return ()

231+ else error "Something went horribly wrong"

223 putMVar serverAddr addr

232 putMVar serverAddr addr

224

233

225 forkIO $ do

234 forkIO $ do

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

248 runProcess node $ do

257 runProcess node $ do

249 pid <- getSelfPid

258 pid <- getSelfPid

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

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

251− 5 <- expect :: Process Int

260+ i <- expect :: Process Int

261+ if i == 5

252− liftIO $ putMVar clientDone ()

262+ then liftIO $ putMVar clientDone ()

263+ else error "Something went horribly wrong"

253

264

254 takeMVar clientDone

265 takeMVar clientDone

255

266

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

269 pid <- getSelfPid

280 pid <- getSelfPid

270 pid' <- spawn nid (sendPidClosure pid)

281 pid' <- spawn nid (sendPidClosure pid)

271 pid'' <- expect

282 pid'' <- expect

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

283+ if pid' == pid''

273− liftIO $ putMVar clientDone ()

284+ then liftIO $ putMVar clientDone ()

285+ else error "Something went horribly wrong"

274

286

275 takeMVar clientDone

287 takeMVar clientDone

276

288

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

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

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

295 pid' <- expect :: Process ProcessId

307 pid' <- expect :: Process ProcessId

296 pid'' <- expect :: Process ProcessId

308 pid'' <- expect :: Process ProcessId

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

309+ if pid' == pid''

298− return ()

310+ then return ()

311+ else error "Something went horribly wrong"

299

312

300 where

313 where

301

314

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

332 node <- newLocalNode testTransport rtable

345 node <- newLocalNode testTransport rtable

333 nid <- readMVar serverNodeAddr

346 nid <- readMVar serverNodeAddr

334 runProcess node $ do

347 runProcess node $ do

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

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

349+ if a == 120

336− liftIO $ putMVar clientDone ()

350+ then liftIO $ putMVar clientDone ()

351+ else error "something went horribly wrong"

337

352

338 takeMVar clientDone

353 takeMVar clientDone

339

354

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

350 node <- newLocalNode testTransport rtable

365 node <- newLocalNode testTransport rtable

351 nid <- readMVar serverNodeAddr

366 nid <- readMVar serverNodeAddr

352 runProcess node $ do

367 runProcess node $ do

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

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

369+ if a == 120

354− liftIO $ putMVar clientDone ()

370+ then liftIO $ putMVar clientDone ()

371+ else error "Something went horribly wrong"

355

372

356 takeMVar clientDone

373 takeMVar clientDone

357

374

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

362 runProcess node $ do

379 runProcess node $ do

363 us <- getSelfPid

380 us <- getSelfPid

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

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

365− 120 :: Int <- expect

382+ a :: Int <- expect

366− 720 :: Int <- expect

383+ b :: Int <- expect

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

367− liftIO $ putMVar done ()

385+ then liftIO $ putMVar done ()

386+ else error "Something went horribly wrong"

368 takeMVar done

387 takeMVar done

369

388

370-- Test 'spawnSupervised'

389-- Test 'spawnSupervised'

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

407 liftIO $ putMVar linkUp ()

426 liftIO $ putMVar linkUp ()

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

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

409 -- we hope that it will be processed before

428 -- we hope that it will be processed before

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

429+ res <- expect

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

430+ case res of

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

412− && pid' == child

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

433+ e == show (ProcessLinkException super

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

434+ (DiedException (show supervisorDeath))))

414− liftIO $ putMVar thirdProcessDone ()

435+ then liftIO $ putMVar thirdProcessDone ()

415−

436+ else error "Something went horribly wrong"

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

416 takeMVar thirdProcessDone

438 takeMVar thirdProcessDone

417 where

439 where

418 supervisorDeath :: IOException

440 supervisorDeath :: IOException

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

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

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

427 ProcessMonitorNotification ref' pid' _reason <- expect

449 ProcessMonitorNotification ref' pid' _reason <- expect

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

450 -- 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'

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

452+ if res == True

430− liftIO $ putMVar done ()

453+ then liftIO $ putMVar done ()

454+ else error "Something went horribly wrong"

431 takeMVar done

455 takeMVar done

432

456

433testClosureExpect :: TestTransport -> RemoteTable -> Assertion

457testClosureExpect :: TestTransport -> RemoteTable -> Assertion

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

439 us <- getSelfPid

463 us <- getSelfPid

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

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

441 send them (1234 :: Int)

465 send them (1234 :: Int)

442− (1234 :: Int) <- expect

466+ (res :: Int) <- expect

467+ if res == 1234

443− liftIO $ putMVar done ()

468+ then liftIO $ putMVar done ()

469+ else error "Something went horribly wrong"

444 takeMVar done

470 takeMVar done

445

471

446testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

472testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

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

465 done <- newEmptyMVar

491 done <- newEmptyMVar

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

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

467 forkProcess node1 $ do

493 forkProcess node1 $ do

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

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

495+ if res == True

469− liftIO $ putMVar done ()

496+ then liftIO $ putMVar done ()

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

470 takeMVar done

498 takeMVar done

471

499

472testFib :: TestTransport -> RemoteTable -> Assertion

500testFib :: TestTransport -> RemoteTable -> Assertion

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

503 liftIO $ threadDelay 100000

531 liftIO $ threadDelay 100000

504

532

505 count <- liftIO $ takeMVar iv

533 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'

507

535

508 liftIO $ putMVar done ()

536 liftIO $ putMVar done ()

537+ if res /= True

538+ then error "Something went horribly wrong"

539+ else return ()

509

540

510 takeMVar done

541 takeMVar done

511

542

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

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

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

31testLocalDeadProcessInfo result = do

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

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

33 mref <- monitor pid

34 send pid "finish"

35 _ <- receiveWait [

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

52 link self

53 mRef <- monitor self

54 stash mon mRef

55− "die" <- expect

55+ res <- expect

56+ case res of

56− return ()

57+ "die" -> return ()

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

58 monRef <- liftIO $ takeMVar mon

60 monRef <- liftIO $ takeMVar mon

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

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

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

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

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

86 send serverPid (self, "ping")

88 send serverPid (self, "ping")

87− "pong" <- expect

89+ pong <- expect

88 pInfo <- getProcessInfo serverPid

90 pInfo <- getProcessInfo serverPid

89− stash result $ pInfo /= Nothing

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

90 where

92 where

91 launchRemote :: MVar ProcessId -> IO ()

93 launchRemote :: MVar ProcessId -> IO ()

92 launchRemote locMV = do

94 launchRemote locMV = do

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

97 _ <- receiveWait [

99 _ <- receiveWait [

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

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

99 ]

101 ]

100− "stop" <- expect

102+ res <- expect

103+ case res of

101− return ()

104+ "stop" -> return ()

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

102 return ()

106 return ()

103

107

104 withActiveRemote :: LocalNode

108 withActiveRemote :: LocalNode

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

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

125 (\ev ->

126 case ev of

127 (MxSent to from msg) -> do

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

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

129+ case mS of

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

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

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

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

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

131 _ ->

133 _ ->

132 return ()) $ do

134 return ()) $ do

133 send pid "hello there"

135 send pid "hello there"

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

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

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

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

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

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

250 -- 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 ())

254

251

252+ pid <- splinchLogger node2 mvNid

255 nid <- liftIO $ takeMVar mvNid

253 nid <- liftIO $ takeMVar mvNid

256 mref <- monitor pid

254 mref <- monitor pid

257 observedPid <- liftIO $ newEmptyMVar

255 observedPid <- liftIO $ newEmptyMVar

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

291 -- and just to be polite...

289 -- and just to be polite...

292 liftIO $ closeLocalNode node2

290 liftIO $ closeLocalNode node2

293

291

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+

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

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

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

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

296withEnv :: String -> String -> IO a -> IO a

305withEnv :: String -> String -> IO a -> IO a

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

319 -- Wait for the trace message.

328 -- Wait for the trace message.

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

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

321 -- Only one interesting message should arrive.

330 -- Only one interesting message should arrive.

322− Nothing <- receiveTimeout 100000

331+ expectedTimeout <- receiveTimeout

332+ 100000

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

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

334+ case expectedTimeout of

324− return ()

335+ Nothing -> return ()

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

325

337

326

338

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

339-- | 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) }

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

401receiveWait ms = do

402 queue <- processQueue <$> ask

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

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

404+ case mProc of

404− proc

405+ Just proc' -> proc'

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

405

407

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

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

407--

409--

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

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

33 ( whereis

34 , newChan

35 , receiveChan

36+ , die

36 )

37 )

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

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

38 ( TraceArg(..)

39 ( TraceArg(..)

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

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

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

169 currentTracer <- receiveChan rp

170 currentTracer <- receiveChan rp

170 case currentTracer of

171 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"

172 (Just p) -> act p

178 (Just p) -> act p

173−