servant/servant-client/test/Servant/Client/TestServer/GHCJS.hs

35 lines
1.1 KiB
Haskell
Raw Normal View History

2016-05-12 15:20:15 +02:00
module Servant.Client.TestServer.GHCJS where
import Control.Exception
import Safe
import System.Exit
import System.IO
import System.Process
import Servant.Client.TestServer.Types
import Servant.Common.BaseUrl
buildTestServer :: IO ()
buildTestServer = do
process <- spawnProcess "./test/ghcjs/build-test-server.sh" []
ExitSuccess <- waitForProcess process
return ()
withServer :: TestServer -> (BaseUrl -> IO a) -> IO a
withServer (TestServer testServerName _) action = do
bracket start stop $ \ (port, _) -> action (BaseUrl Http "localhost" port ("/" ++ testServerName))
where
start :: IO (Int, ProcessHandle)
start = do
(Nothing, Just stdout, Nothing, process) <- createProcess $ (proc "./test/ghcjs/testServer/testServer" []) {
std_out = CreatePipe
}
line <- hGetLine stdout
case readMay line :: Maybe Int of
Nothing -> die ("unparseable port: " ++ show line)
Just port -> return (port, process)
stop (_, process) = do
terminateProcess process
waitForProcess process