haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add timeouts so stalling is more obvious

Browse Source
This commit is contained in:
Michael Snoyman 2018-06-19 09:52:20 +03:00
parent 0437ace264
commit 12a2bb58e9
2 changed files with 28 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
yesod-core/test/YesodCoreTest/RawResponse.hs
View File

@ -13,15 +13,13 @@ import qualified Data.ByteString.Char8 as S8
import Data.Conduit import Data.Conduit
import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Binary as CB
import Data.Char (toUpper) import Data.Char (toUpper)
import Control.Exception (try, IOException)
import Data.Conduit.Network import Data.Conduit.Network
import Network.Socket (close)
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (withAsync) import Control.Concurrent.Async (race)
import Control.Monad.Trans.Resource (register) import Control.Monad.Trans.Resource (register)
import Data.IORef import Data.IORef
import Data.Streaming.Network (bindPortTCP)
import Network.HTTP.Types (status200) import Network.HTTP.Types (status200)
import Network.Wai.Handler.Warp (testWithApplication)
mkYesod "App" [parseRoutes| mkYesod "App" [parseRoutes|
/ HomeR GET / HomeR GET
@ -56,53 +54,38 @@ getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 []
flush flush
send " world" 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 :: Spec
specs = do specs = do
describe "RawResponse" $ 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 it "sendWaiResponse + responseStream" $ do
body "GET /wai-stream HTTP/1.1\r\n\r\n" body "GET /wai-stream HTTP/1.1\r\n\r\n"
it "sendWaiApplication + responseStream" $ do it "sendWaiApplication + responseStream" $ do

3
yesod-core/yesod-core.cabal
View File

@ -191,8 +191,9 @@ test-suite tests
, unliftio , unliftio
, wai >= 3.0 , wai >= 3.0
, wai-extra , wai-extra
, warp
, yesod-core , yesod-core
ghc-options: -Wall ghc-options: -Wall -threaded
extensions: TemplateHaskell extensions: TemplateHaskell
benchmark widgets benchmark widgets