Compile test suite with concurrency-oriented GHC flags

- Also avoid server cancelling in tests, or else certain requests
  sporadically fail.

pact.cabal

@@ -199,7 +199,7 @@ test-suite hspec
   main-is:          hspec.hs
   hs-source-dirs:   tests
   default-language: Haskell2010
-  ghc-options:      -Wall -threaded -rtsopts -O2 -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
+  ghc-options:      -Wall -threaded -with-rtsopts=-N -O2 -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
   build-depends:
                 base
               , hspec

tests/Utils/TestRunner.hs

@@ -72,19 +72,8 @@ startServer configFile = do
   return (asyncServer, asyncCmd, asyncHist)
 
 stopServer :: (Async (), Async (), Async ()) -> IO ()
-stopServer (asyncServer, asyncCmd, asyncHist) = do
-  uninterruptibleCancel asyncCmd
-  uninterruptibleCancel asyncHist
-  uninterruptibleCancel asyncServer
-  mapM_ checkFinished [asyncServer, asyncCmd, asyncHist]
-  where checkFinished asy = do
-          asyPoll <- poll asy
-          case asyPoll of
-            Nothing -> Exception.evaluate $ error $ ("Thread " ++
-                                                      (show (asyncThreadId asy)) ++
-                                                      " could not be cancelled.")
-            _ -> return ()
-
+stopServer (asyncServer, _, _) = cancel asyncServer
+
 run :: [Command T.Text] -> IO (HM.HashMap RequestKey ApiResult)
 run cmds = do
   sendResp <- doSend $ SubmitBatch cmds
@@ -95,7 +84,7 @@ run cmds = do
       case results of
         Nothing -> Exception.evaluate (error "Received empty poll. Timeout in retrying.")
         Just res -> return res
-      
+
   where helper reqKeys = do
           pollResp <- doPoll $ Poll reqKeys
           case pollResp of
@@ -107,7 +96,7 @@ run cmds = do
 doSend :: (ToJSON req) => req -> IO (ApiResponse RequestKeys)
 doSend req = do
   view responseBody <$> doSend' req
-    
+
 doSend' :: (ToJSON req) => req -> IO (Response (ApiResponse RequestKeys))
 doSend' req = do
   sendResp <- post (_serverPath ++ "send") (toJSON req)
@@ -124,7 +113,7 @@ doPoll' req = do
 
 
 flushDb :: IO ()
-flushDb = mapM_ deleteIfExists _logFiles 
+flushDb = mapM_ deleteIfExists _logFiles
   where deleteIfExists filename = do
           let fp = _testLogDir ++ filename
           isFile <- doesFileExist fp
@@ -135,7 +124,7 @@ genKeys = do
   g :: SystemRandom <- newGenIO
   case generateKeyPair g of
     Left _ -> error "Something went wrong in genKeys"
-    Right (s,p,_) -> return $ KeyPair s p 
+    Right (s,p,_) -> return $ KeyPair s p
 
 
 
@@ -154,7 +143,7 @@ checkResult isFailure expect result =
 
 checkIfSuccess :: Object -> Maybe Value -> Expectation
 checkIfSuccess h Nothing = HM.lookup (T.pack "status") h `shouldBe` (Just . String . T.pack) "success"
-checkIfSuccess h (Just expect) = do 
+checkIfSuccess h (Just expect) = do
   HM.lookup (T.pack "status") h `shouldBe` (Just . String . T.pack) "success"
   HM.lookup (T.pack "data") h `shouldBe` Just (toJSON expect)
 
@@ -177,7 +166,7 @@ threeStepPactCode moduleName = T.concat [begCode, T.pack moduleName, endCode]
                 (step "step 0")
                 (step "step 1")
                 (step "step 2")))
-              |] 
+              |]
 
 errorStepPactCode :: String -> T.Text
 errorStepPactCode moduleName = T.concat [begCode, T.pack moduleName, endCode]
@@ -188,7 +177,7 @@ errorStepPactCode moduleName = T.concat [begCode, T.pack moduleName, endCode]
                 (step "step 0")
                 (step (+ "will throw error in step 1"))
                 (step "step 2")))
-              |] 
+              |]
 
 pactWithRollbackCode :: String -> T.Text
 pactWithRollbackCode moduleName = T.concat [begCode, T.pack moduleName, endCode]