@@ -2,6 +2,7 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Obelisk.SelfTest where
44
5+import Control.Monad.IO.Class
56import Control.Exception (throw)
67import Control.Monad
78import Data.Function (fix)
@@ -15,6 +16,7 @@ import qualified Network.HTTP.Types as HTTP
1516import Shelly
1617import System.Environment
1718import System.Exit (ExitCode(..))
19+import System.IO (Handle)
1820import System.IO.Temp
1921import System.Timeout
2022import Test.Hspec
@@ -23,7 +25,6 @@ data ObRunState
2325 = ObRunState_Init
2426 | ObRunState_Startup
2527 | ObRunState_BackendStarted Text -- Port of backend
26− | ObRunState_FrontendStarted Text Text -- Port of backend, URI of frontend
2728 deriving (Eq, Show)
2829
2930main :: IO ()
@@ -43,24 +44,58 @@ main = do
4344 run "nix-build" ["--no-out-link", "-A", "ghcjs.frontend"]
4445
4546 it "can use ob run" $ inProj $ handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do
46− runHandle "ob" ["run"] $ \stdout -> flip fix ObRunState_Init $ \loop -> \case
47− ObRunState_FrontendStarted backendPort frontendUri -> do
48− let req uri = liftIO $ HTTP.parseRequest (T.unpack uri) >>= flip HTTP.httpLbs httpManager
49− req frontendUri >>= \r -> when (HTTP.responseStatus r /= HTTP.ok200) $ errorExit $
50− "Request to frontend server failed: " <> T.pack (show r)
51− void $ req $ "http://localhost:" <> backendPort
52− liftIO (timeout 1000000 $ T.hGetLine stdout) >>= \case
53− Just t | "127.0.0.1" `T.isPrefixOf` t -> exit 0 -- Backend request successfully logged
54− x -> errorExit $ "Couldn't get backend request log: " <> T.pack (show x)
55− last -> liftIO (T.hGetLine stdout) >>= \t -> case last of
56− ObRunState_Init
57− | "Running test..." `T.isPrefixOf` t -> loop ObRunState_Startup
58− ObRunState_Startup
59− | Just port <- "Backend running on port " `T.stripPrefix` t
60− -> loop $ ObRunState_BackendStarted port
61− | not (T.null t) -> errorExit t -- If theres any other output here, startup failed
62− ObRunState_BackendStarted port
63− | Just uri <- "Frontend running on " `T.stripPrefix` t
64− -> loop $ ObRunState_FrontendStarted port uri
65− | not (T.null t) -> errorExit t -- If theres any other output here, startup failed
66− _ -> loop last
47+ runHandle "ob" ["run"] $ \stdout -> do
48+ (_, firstUri) <- obRun httpManager stdout
49+ let newUri = "http://localhost:8080/" -- trailing slash required for comparison
50+ when (firstUri == newUri) $ errorExit $
51+ "Default URI (" <> firstUri <> ") is the same as test URI (" <> newUri <> ")"
52+ alterRouteTo newUri stdout
53+ (_, runningUri) <- obRun httpManager stdout
54+ if runningUri /= newUri
55+ then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri
56+ else exit 0
57+
58+-- | Blocks until a non-empty line is available
59+hGetLineSkipBlanks :: MonadIO m => Handle -> m Text
60+hGetLineSkipBlanks h = liftIO $ fix $ \loop -> T.hGetLine h >>= \case
61+ "" -> loop
62+ t -> pure t
63+
64+-- | Alters the route file and waits for `ob run` to reload
65+alterRouteTo :: Text -> Handle -> Sh ()
66+alterRouteTo uri stdout = do
67+ writefile "config/common/route" uri
68+ hGetLineSkipBlanks stdout >>= \t -> when (t /= "Reloading...") $ errorExit $
69+ "Reloading failed: " <> T.pack (show t)
70+ hGetLineSkipBlanks stdout >>= \t -> when (t /= " config/common/route") $ errorExit $
71+ "Reloading failed: " <> T.pack (show t)
72+ hGetLineSkipBlanks stdout >>= \t -> when (t /= "Interrupted.") $ errorExit $
73+ "Reloading failed: " <> T.pack (show t)
74+
75+-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly
76+obRun :: HTTP.Manager -> Handle -> Sh (Text, Text)
77+obRun httpManager stdout = flip fix ObRunState_Init $ \loop state -> do
78+ liftIO (T.hGetLine stdout) >>= \t -> case state of
79+ ObRunState_Init
80+ | "Running test..." `T.isPrefixOf` t -> loop ObRunState_Startup
81+ ObRunState_Startup
82+ | t == "backend stopped; make a change to your code to reload" -> loop ObRunState_Startup
83+ | Just port <- "Backend running on port " `T.stripPrefix` t -> loop $ ObRunState_BackendStarted port
84+ | not (T.null t) -> errorExit $ "Startup: " <> t -- If theres any other output here, startup failed
85+ ObRunState_BackendStarted port
86+ | Just uri <- "Frontend running on " `T.stripPrefix` t -> do
87+ obRunCheck httpManager stdout port uri
88+ pure (port, uri)
89+ | not (T.null t) -> errorExit $ "Started: " <> t -- If theres any other output here, startup failed
90+ _ -> loop state
91+
92+-- | Make requests to frontend/backend servers to check they are working properly
93+obRunCheck :: HTTP.Manager -> Handle -> Text -> Text -> Sh ()
94+obRunCheck httpManager stdout backendPort frontendUri = do
95+ let req uri = liftIO $ HTTP.parseRequest (T.unpack uri) >>= flip HTTP.httpLbs httpManager
96+ req frontendUri >>= \r -> when (HTTP.responseStatus r /= HTTP.ok200) $ errorExit $
97+ "Request to frontend server failed: " <> T.pack (show r)
98+ void $ req $ "http://localhost:" <> backendPort
99+ liftIO (timeout 1000000 $ T.hGetLine stdout) >>= \case
100+ Just t | "127.0.0.1" `T.isPrefixOf` t -> pure () -- Backend request logged
101+ x -> errorExit $ "Couldn't get backend request log: " <> T.pack (show x)