@@ -1,17 +1,36 @@
1+{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE OverloadedStrings #-}
23module Obelisk.SelfTest where
34
5+import Control.Monad.IO.Class
6+import Control.Exception (throw)
47import Control.Monad
8+import Data.Function (fix)
9+import Data.Semigroup ((<>))
510import Data.String
11+import Data.Text (Text)
612import qualified Data.Text as T
13+import qualified Data.Text.IO as T
14+import qualified Network.HTTP.Client as HTTP
15+import qualified Network.HTTP.Types as HTTP
716import Shelly
817import System.Environment
18+import System.Exit (ExitCode(..))
19+import System.IO (Handle)
920import System.IO.Temp
21+import System.Timeout
1022import Test.Hspec
1123
24+data ObRunState
25+ = ObRunState_Init
26+ | ObRunState_Startup
27+ | ObRunState_BackendStarted Text -- Port of backend
28+ deriving (Eq, Show)
29+
1230main :: IO ()
1331main = do
1432 obeliskImpl <- getEnv "OBELISK_IMPL"
33+ httpManager <- HTTP.newManager HTTP.defaultManagerSettings
1534 withSystemTempDirectory "blank-project" $ \blankProject ->
1635 hspec $ do
1736 describe "blank initialized project" $ do
@@ -23,3 +42,60 @@ main = do
2342 run "nix-build" ["--no-out-link", "-A", "ghc.backend"]
2443 it "can build ghcjs.frontend" $ inProj $ do
2544 run "nix-build" ["--no-out-link", "-A", "ghcjs.frontend"]
45+
46+ it "can use ob run" $ inProj $ handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do
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)