Merge pull request #1526 from yesodweb/1523-fix-stalled-tests

1523 fix stalled tests

yesod-core/test/YesodCoreTest.hs

@@ -16,7 +16,12 @@ import qualified YesodCoreTest.Redirect as Redirect
 import qualified YesodCoreTest.JsLoader as JsLoader
 import qualified YesodCoreTest.RequestBodySize as RequestBodySize
 import qualified YesodCoreTest.Json as Json
+
+-- Skip on Windows, see https://github.com/yesodweb/yesod/issues/1523#issuecomment-398278450
+#if !WINDOWS
 import qualified YesodCoreTest.RawResponse as RawResponse
+#endif
+
 import qualified YesodCoreTest.Streaming as Streaming
 import qualified YesodCoreTest.Reps as Reps
 import qualified YesodCoreTest.Auth as Auth
@@ -43,7 +48,9 @@ specs = do
       JsLoader.specs
       RequestBodySize.specs
       Json.specs
+#if !WINDOWS
       RawResponse.specs
+#endif
       Streaming.specs
       Reps.specs
       Auth.specs

yesod-core/test/YesodCoreTest/RawResponse.hs

@@ -13,15 +13,13 @@ import qualified Data.ByteString.Char8 as S8
 import Data.Conduit
 import qualified Data.Conduit.Binary as CB
 import Data.Char (toUpper)
-import Control.Exception (try, IOException)
 import Data.Conduit.Network
-import Network.Socket (close)
 import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (withAsync)
+import Control.Concurrent.Async (race)
 import Control.Monad.Trans.Resource (register)
 import Data.IORef
-import Data.Streaming.Network (bindPortTCP)
 import Network.HTTP.Types (status200)
+import Network.Wai.Handler.Warp (testWithApplication)
 
 mkYesod "App" [parseRoutes|
 / HomeR GET
@@ -56,53 +54,38 @@ getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 []
     flush
     send " world"
 
-getFreePort :: IO Int
+allowFiveSeconds :: IO a -> IO a
-getFreePort = do
+allowFiveSeconds = fmap (either id id) . race (threadDelay 5000000 >> error "timed out")
-    loop 43124
-  where
-    loop port = do
-        esocket <- try $ bindPortTCP port "*"
-        case esocket of
-            Left (_ :: IOException) -> loop (succ port)
-            Right socket -> do
-                close socket
-                return port
 
 specs :: Spec
 specs = do
     describe "RawResponse" $ do
-        it "works" $ do
+        it "works" $ allowFiveSeconds $ testWithApplication (toWaiApp App) $ \port -> do
-            port <- getFreePort
+            runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
-            withAsync (warp port App) $ \_ -> do
+                runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad
-                threadDelay 100000
+                runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")
-                runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
+                runConduit $ yield "WORLd" .| appSink ad
-                    runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad
+                runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD")
-                    runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")
-                    runConduit $ yield "WORLd" .| appSink ad
-                    runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD")
 
-    let body req = do
+    let body req = allowFiveSeconds $ testWithApplication (toWaiApp App) $ \port -> do
-            port <- getFreePort
+            runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
-            withAsync (warp port App) $ \_ -> do
+                runConduit $ yield req .| appSink ad
-                threadDelay 100000
+                runConduit $ appSource ad .| CB.lines .| do
-                runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
+                    let loop = do
-                    runConduit $ yield req .| appSink ad
+                            x <- await
-                    runConduit $ appSource ad .| CB.lines .| do
+                            case x of
-                        let loop = do
+                                Nothing -> return ()
-                                x <- await
+                                Just "\r" -> return ()
-                                case x of
+                                _ -> loop
-                                    Nothing -> return ()
+                    loop
-                                    Just "\r" -> return ()
-                                    _ -> loop
-                        loop
 
-                        Just "0005\r" <- await
+                    Just "0005\r" <- await
-                        Just "hello\r" <- await
+                    Just "hello\r" <- await
 
-                        Just "0006\r" <- await
+                    Just "0006\r" <- await
-                        Just " world\r" <- await
+                    Just " world\r" <- await
 
-                        return ()
+                    return ()
     it "sendWaiResponse + responseStream" $ do
         body "GET /wai-stream HTTP/1.1\r\n\r\n"
     it "sendWaiApplication + responseStream" $ do

yesod-core/yesod-core.cabal

@@ -170,6 +170,8 @@ test-suite tests
                    YesodCoreTest.YesodTest
 
     cpp-options:   -DTEST
+    if os(windows)
+        cpp-options: -DWINDOWS
     build-depends:  base
                   , async
                   , bytestring
@@ -191,8 +193,9 @@ test-suite tests
                   , unliftio
                   , wai >= 3.0
                   , wai-extra
+                  , warp
                   , yesod-core
-    ghc-options:     -Wall
+    ghc-options:     -Wall -threaded
     extensions: TemplateHaskell
 
 benchmark widgets