@@ -1,3 +1,4 @@
1+{-# LANGUAGE DoAndIfThenElse #-}
12{-# LANGUAGE EmptyCase #-}
23{-# LANGUAGE LambdaCase #-}
34{-# LANGUAGE OverloadedStrings #-}
@@ -23,13 +24,13 @@ import qualified Network.HTTP.Client as HTTP
2324import qualified Network.HTTP.Types as HTTP
2425import qualified Network.Socket as Socket
2526import Shelly hiding (cp)
26−import System.Directory (withCurrentDirectory, getDirectoryContents)
27+import System.Directory (getCurrentDirectory, withCurrentDirectory, getDirectoryContents)
2728import System.Environment
2829import System.Exit (ExitCode (..))
2930import System.FilePath (replaceBaseName, takeBaseName)
3031import System.Which (staticWhich)
3132import qualified System.Info
32−import System.IO (Handle, hClose)
33+import System.IO (Handle, hClose, hIsEOF, hGetContents)
3334import System.IO.Temp
3435import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)
3536import Test.Hspec
@@ -52,11 +53,32 @@ cp = $(staticWhich "cp")
5253cabalPath :: FilePath
5354cabalPath = $(staticWhich "cabal")
5455
56+gitPath :: FilePath
57+gitPath = $(staticWhich "git")
58+
59+chownPath :: FilePath
60+chownPath = $(staticWhich "chown")
61+
62+chmodPath :: FilePath
63+chmodPath = $(staticWhich "chmod")
64+
65+whoamiPath :: FilePath
66+whoamiPath = $(staticWhich "whoami")
67+
68+nixBuildPath :: FilePath
69+nixBuildPath = $(staticWhich "nix-build")
70+
71+lnPath :: FilePath
72+lnPath = $(staticWhich "ln")
73+
74+rmPath :: FilePath
75+rmPath = $(staticWhich "rm")
76+
5577gitUserConfig :: [Text]
5678gitUserConfig = ["-c", "user.name=Obelisk Selftest", "-c", "user.email=noreply@example.com"]
5779
5880commit :: Text -> Sh ()
59−commit msg = void $ run "git" $ gitUserConfig <> [ "commit"
81+commit msg = void $ run gitPath $ gitUserConfig <> [ "commit"
6082 , "--no-gpg-sign"
6183 , "--allow-empty"
6284 , "-m"
@@ -92,20 +114,26 @@ main = do
92114 unless isVerbose $
93115 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"
94116 let verbosity = bool silently verbosely isVerbose
95− nixBuild args = run "nix-build" ("--no-out-link" : args)
96− obeliskImplRaw <- fromString <$> getEnv "OBELISK_IMPL"
117+ nixBuild args = run nixBuildPath ("--no-out-link" : args)
118+ obeliskImplDirtyReadOnly <- fromString <$> getCurrentDirectory
97119 let runOb_ = augmentWithVerbosity run_ ob isVerbose
98120 let runOb = augmentWithVerbosity run ob isVerbose
99121 let testObRunInDir' = augmentWithVerbosity testObRunInDir ob isVerbose ["run"]
100122 let testThunkPack' = augmentWithVerbosity testThunkPack ob isVerbose []
101123 let
102− withObeliskImpl f =
124+ withObeliskImplClean f =
125+ withSystemTempDirectory "obelisk-impl-clean" $ \(fromString -> obeliskImpl) -> do
126+ void . shellyOb verbosity $ chdir obeliskImpl $ do
127+ run_ gitPath ["clone", "file://" <> toTextIgnore obeliskImplDirtyReadOnly, toTextIgnore obeliskImpl]
128+ f obeliskImpl
129+
130+ withObeliskImplDirty f =
103131 withSystemTempDirectory "obelisk-impl-copy" $ \(fromString -> obeliskImpl) -> do
104132 void . shellyOb verbosity $ chdir obeliskImpl $ do
105− user <- T.strip <$> run "whoami" []
106− run_ cp ["-rT", toTextIgnore obeliskImplRaw, toTextIgnore obeliskImpl]
107− run_ "chown" ["-R", user, toTextIgnore obeliskImpl]
108− run_ "chmod" ["-R", "g-rw,o-rw", toTextIgnore obeliskImpl]
133+ user <- T.strip <$> run whoamiPath []
134+ run_ cp ["-rT", "--no-preserve=mode", toTextIgnore obeliskImplDirtyReadOnly, toTextIgnore obeliskImpl]
135+ run_ chownPath ["-R", user, toTextIgnore obeliskImpl]
136+ run_ chmodPath ["-R", "g-rw,o-rw", toTextIgnore obeliskImpl]
109137 f obeliskImpl
110138
111139 withInitCache f obeliskImpl =
@@ -113,16 +141,16 @@ main = do
113141 -- Setup the ob init cache
114142 void . shellyOb verbosity $ chdir initCache $ do
115143 runOb_ ["init", "--symlink", toTextIgnore obeliskImpl]
116− run_ "git" ["init"]
144+ run_ gitPath ["init"]
117145
118146 f initCache
119147
120− withObeliskImplAndInitCache f =
121− withObeliskImpl $ \impl -> withInitCache (f impl) impl
148+ withObeliskImplDirtyAndInitCache f =
149+ withObeliskImplDirty $ \impl -> withInitCache (f impl) impl
122150
123151 httpManager <- HTTP.newManager HTTP.defaultManagerSettings
124152
125− withObeliskImplAndInitCache $ \obeliskImpl initCache ->
153+ withObeliskImplDirtyAndInitCache $ \obeliskImplDirty initCache ->
126154 hspec $ parallel $ do
127155 let shelly_ = void . shellyOb verbosity
128156
@@ -142,18 +170,18 @@ main = do
142170
143171 -- To be used in tests that change the obelisk impl directory
144172 inTmpObInitWithImplCopy f = inTmpObInit $ \dir ->
145− withObeliskImpl $ \(fromString -> implCopy) -> do
146− run_ "rm" [thunk]
147− run_ "ln" ["-s", implCopy, thunk]
173+ withObeliskImplClean $ \(fromString -> implClean) -> do
174+ run_ rmPath [thunk]
175+ run_ lnPath ["-s", implClean, thunk]
148176 f dir
149177
150178 assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b
151179 assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b
152180
153− revParseHead = T.strip <$> run "git" ["rev-parse", "HEAD"]
181+ revParseHead = T.strip <$> run gitPath ["rev-parse", "HEAD"]
154182
155183 commitAll = do
156− run_ "git" ["add", "."]
184+ run_ gitPath ["add", "."]
157185 commit "checkpoint"
158186 revParseHead
159187
@@ -162,12 +190,12 @@ main = do
162190 pack = runOb ["thunk", "pack", thunk] >> commitAll
163191 unpack = runOb ["thunk", "unpack", thunk] >> commitAll
164192
165− diff a b = run "git" ["diff", a, b]
193+ diff a b = run gitPath ["diff", a, b]
166194
167195 describe "ob init" $ parallel $ do
168196 it "works with default impl" $ inTmp $ \_ -> runOb ["init"]
169197 it "works with master branch impl" $ inTmp $ \_ -> runOb ["init", "--branch", "master"]
170− it "works with symlink" $ inTmp $ \_ -> runOb ["init", "--symlink", toTextIgnore obeliskImpl]
198+ it "works with symlink" $ inTmp $ \_ -> runOb ["init", "--symlink", toTextIgnore obeliskImplDirty]
171199 it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init λ" $ \dir -> do
172200 let p force = (System.Process.proc ob $ "--no-handoff" : "-v" : "init" : ["--force"|force]) { cwd = Just dir }
173201 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""
@@ -194,10 +222,10 @@ main = do
194222 testObRunInDir' Nothing httpManager
195223
196224 describe "obelisk project" $ parallel $ do
197− it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , toTextIgnore obeliskImpl]
198− it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", toTextIgnore obeliskImpl]
199− it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", toTextIgnore obeliskImpl]
200− it "can build everything" $ inTmpObInit $ \_ -> nixBuild [toTextIgnore obeliskImpl]
225+ it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , toTextIgnore obeliskImplDirty]
226+ it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", toTextIgnore obeliskImplDirty]
227+ it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", toTextIgnore obeliskImplDirty]
228+ it "can build everything" $ inTmpObInit $ \_ -> nixBuild [toTextIgnore obeliskImplDirty]
201229
202230 describe "blank initialized project" $ parallel $ do
203231
@@ -247,16 +275,16 @@ main = do
247275
248276 it "unpacks the correct branch" $ withTmp $ \dir -> do
249277 let branch = "master"
250− run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]
278+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]
251279 runOb_ ["thunk", "pack", toTextIgnore dir]
252280 runOb_ ["thunk", "unpack", toTextIgnore dir]
253− branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]
281+ branch' <- chdir dir $ run gitPath ["rev-parse", "--abbrev-ref", "HEAD"]
254282 liftIO $ assertEqual "" branch (T.strip branch')
255283
256284 it "can pack and unpack plain git repos" $
257285 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do
258286 let repo = toTextIgnore $ dir </> ("repo" :: String)
259− run_ "git" ["clone", "https://github.com/haskell/process.git", repo]
287+ run_ gitPath ["clone", "https://github.com/haskell/process.git", repo]
260288 origHash <- chdir (fromText repo) revParseHead
261289
262290 runOb_ ["thunk", "pack", repo]
@@ -271,20 +299,20 @@ main = do
271299
272300 testThunkPack' $ fromText repo
273301
274− it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do
302+ it "aborts thunk pack when there are uncommitted files" $ inTmpObInitWithImplCopy $ \dir -> do
275303 testThunkPack' (dir </> thunk)
276304
277305 describe "ob thunk update --branch" $ parallel $ do
278306 it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do
279307 let branch1 = "master"
280308 branch2 = "develop"
281− run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch1]
309+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch1]
282310 runOb_ ["thunk" , "pack", toTextIgnore dir]
283311 runOb_ ["thunk", "update", toTextIgnore dir, "--branch", branch2]
284312
285313 it "doesn't create anything when given an invalid branch" $ withTmp $ \dir -> do
286314 let checkDir dir' = liftIO $ getDirectoryContents $ T.unpack $ toTextIgnore dir'
287− run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", "master"]
315+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", "master"]
288316 runOb_ ["thunk" , "pack", toTextIgnore dir]
289317 startingContents <- checkDir dir
290318 void $ errExit False $ runOb ["thunk", "update", toTextIgnore dir, "--branch", "dumble-palooza"]
@@ -297,13 +325,13 @@ testObRunInDir executable extraArgs mdir httpManager = handle_sh (\case ExitSucc
297325 [p0, p1] <- liftIO $ getFreePorts 2
298326 let uri p = "http://localhost:" <> T.pack (show p) <> "/" -- trailing slash required for comparison
299327 writefile "config/common/route" $ uri p0
300− maybe id chdir mdir $ runHandle executable extraArgs $ \stdout -> do
301− firstUri <- handleObRunStdout httpManager stdout
328+ maybe id chdir mdir $ runHandles executable extraArgs [] $ \_stdin stdout stderr -> do
329+ firstUri <- handleObRunStdout httpManager stdout stderr
302330 let newUri = uri p1
303331 when (firstUri == newUri) $ errorExit $
304332 "Startup URI (" <> firstUri <> ") is the same as test URI (" <> newUri <> ")"
305333 maybe id (\_ -> chdir "..") mdir $ alterRouteTo newUri stdout
306− runningUri <- handleObRunStdout httpManager stdout
334+ runningUri <- handleObRunStdout httpManager stdout stderr
307335 if runningUri /= newUri
308336 then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri
309337 else exit 0
@@ -313,10 +341,10 @@ testThunkPack executable args path' = withTempFile (T.unpack $ toTextIgnore path
313341 let pack' = readProcessWithExitCode executable (T.unpack <$> ["thunk", "pack", toTextIgnore path'] ++ args) ""
314342 ensureThunkPackFails q = liftIO $ pack' >>= \case
315343 (code, out, err)
316− | code == ExitSuccess -> fail "ob thunk pack succeeded when it should have failed"
344+ | code == ExitSuccess -> fail $ "ob thunk pack succeeded when it should have failed with error '" <> show q <> "'"
317345 | q `T.isInfixOf` T.pack (out <> err) -> pure ()
318− | otherwise -> fail $ "ob thunk pack failed for an unexpected reason: " <> show out <> "\nstderr: " <> err
319− git = chdir path' . run "git"
346+ | otherwise -> fail $ "ob thunk pack failed for an unexpected reason, expecting '" <> show q <> "', received: " <> show out <> "\nstderr: " <> err
347+ git = chdir path' . run gitPath
320348 -- Untracked files
321349 ensureThunkPackFails "Untracked files"
322350 void $ git ["add", T.pack file]
@@ -350,9 +378,12 @@ alterRouteTo uri stdout = do
350378 "Reloading failed: " <> T.pack (show t)
351379
352380-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly
353−handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text
354−handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) ->
355− liftIO (T.hGetLine stdout) >>= \t -> case state of
381+handleObRunStdout :: HTTP.Manager -> Handle -> Handle -> Sh Text
382+handleObRunStdout httpManager stdout stderr = flip fix (ObRunState_Init, []) $ \loop (state, msgs) -> do
383+ isEOF <- liftIO $ hIsEOF stdout
384+ if isEOF
385+ then handleObRunError msgs
386+ else liftIO (T.hGetLine stdout) >>= \t -> case state of
356387 ObRunState_Init
357388 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)
358389 ObRunState_Startup
@@ -364,8 +395,12 @@ handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (s
364395 obRunCheck httpManager stdout uri
365396 pure uri
366397 | not (T.null t) -> errorExit $ "Started: " <> t -- If theres any other output here, startup failed
367− _ | "Failed" `T.isPrefixOf` t -> errorExit $ "ob run failed: " <> T.unlines (reverse $ t : msgs)
398+ _ | "Failed" `T.isPrefixOf` t -> handleObRunError (t : msgs)
368399 | otherwise -> loop (state, t : msgs)
400+ where
401+ handleObRunError msgs = do
402+ stderrContent <- liftIO $ hGetContents stderr
403+ errorExit $ "ob run failed: " <> T.unlines (reverse msgs) <> " stderr: " <> T.pack stderrContent
369404
370405-- | Make requests to frontend/backend servers to check they are working properly
371406obRunCheck :: HTTP.Manager -> Handle -> Text -> Sh ()