@@ -1,14 +1,15 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE PatternGuards #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
35{-# LANGUAGE TypeApplications #-}
46module Obelisk.SelfTest where
57
6−import Control.Exception (Exception, throw, bracket)
8+import Control.Exception (bracket, throw)
79import Control.Monad
810import Control.Monad.IO.Class
911import Data.Bool (bool)
1012import Data.Function (fix)
11−import Data.Maybe (isJust)
1213import Data.Semigroup (Semigroup, (<>))
1314import qualified Data.Set as Set
1415import Data.String
@@ -21,15 +22,17 @@ import qualified Network.Socket as Socket
2122import Shelly
2223import System.Directory (withCurrentDirectory)
2324import System.Environment
24−import System.Exit (ExitCode (..), exitWith)
25+import System.Exit (ExitCode (..))
2526import System.Info
2627import System.IO (Handle, hClose)
2728import System.IO.Temp
29+import System.Process (readProcessWithExitCode)
2830import System.Timeout
2931import Test.Hspec
3032import Test.HUnit.Base
31−import System.Process (readProcessWithExitCode)
3233
34+import Obelisk.CliApp hiding (runCli)
35+import qualified Obelisk.CliApp as CliApp
3336import Obelisk.Run (getConfigRoute)
3437
3538data ObRunState
@@ -50,18 +53,44 @@ commit msg = void $ run "git"
5053 , doubleQuotes msg
5154 ]
5255
56+runCli :: MonadIO m => CliT IO a -> m a
57+runCli f = liftIO $ do
58+ c <- newCliConfig Notice False False
59+ CliApp.runCli c f
60+
61+tshow :: Show a => a -> Text
62+tshow = T.pack . show
63+
64+-- | Like `shelly` but used when running `ob` commands
65+--
66+-- This tests the NIX_REMOTE workaround, whether that gets printed
67+-- on failure, and whether retrying with the suggested workaround
68+-- leads to the test succeeding.
69+shellyOb :: MonadIO m => (Sh a -> Sh a) -> Sh a -> m a
70+shellyOb f obTest = shelly $ f $ do
71+ obTest `catch_sh` \(e :: RunFailed) -> do
72+ obStderr <- lastStderr
73+ if T.isInfixOf "export NIX_REMOTE" obStderr
74+ then do
75+ runCli $ do
76+ putLog Notice "Detected NIX_REMOTE suggestion in stderr of failed ob"
77+ putLog Warning "Retrying this test with NIX_REMOTE=daemon"
78+ setenv "NIX_REMOTE" "daemon"
79+ f obTest
80+ else throw e
81+
5382main :: IO ()
5483main = do
55− isVerbose <- getArgs >>= \case
56− ["-v"] -> pure True
57− [] -> putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output" *> pure False
58− _ -> putStrLn "Usage: selftest [-v]" *> exitWith (ExitFailure 2)
84+ -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`
85+ isVerbose <- (elem "-v") <$> getArgs
86+ unless isVerbose $
87+ putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"
5988 let verbosity = bool silently verbosely isVerbose
6089 obeliskImpl <- fromString <$> getEnv "OBELISK_IMPL"
6190 httpManager <- HTTP.newManager HTTP.defaultManagerSettings
6291 withSystemTempDirectory "blank-project" $ \blankProject ->
6392 hspec $ do
64− let shelly_ = void . shelly . verbosity
93+ let shelly_ = void . shellyOb verbosity
6594
6695 inProj :: Sh a -> IO ()
6796 inProj = shelly_ . chdir (fromString blankProject)
@@ -75,7 +104,7 @@ main = do
75104 revParseHead = T.strip <$> run "git" ["rev-parse", "HEAD"]
76105
77106 commitAll = do
78− run "git" ["add", "."]
107+ run_ "git" ["add", "."]
79108 commit "checkpoint"
80109 revParseHead
81110
@@ -92,31 +121,32 @@ main = do
92121 it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", obeliskImpl]
93122
94123 it "doesn't create anything when given an invalid impl" $ inTmp $ \tmp -> do
95− errExit False $ run "ob" ["init", "--symlink", "/dev/null"]
124+ void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]
96125 ls tmp >>= liftIO . assertEqual "" []
97126
98127 it "produces a valid route config" $ inTmp $ \tmp -> do
99− run "ob" ["init"]
128+ run_ "ob" ["init"]
100129 liftIO $ withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ getConfigRoute `shouldNotReturn` Nothing
101130
102131 describe "ob run" $ do
103132 it "works in root directory" $ inTmp $ \_ -> do
104− run "ob" ["init"]
133+ run_ "ob" ["init"]
105134 testObRunInDir Nothing httpManager
106135 it "works in sub directory" $ inTmp $ \_ -> do
107− run "ob" ["init"]
136+ run_ "ob" ["init"]
108137 testObRunInDir (Just "frontend") httpManager
109138
110139 describe "obelisk project" $ parallel $ do
111140 it "can build obelisk command" $ shelly_ $ run "nix-build" ["-A", "command" , obeliskImpl]
112141 it "can build obelisk skeleton" $ shelly_ $ run "nix-build" ["-A", "skeleton", obeliskImpl]
113142 it "can build obelisk shell" $ shelly_ $ run "nix-build" ["-A", "shell", obeliskImpl]
114− it "can build everything" $ shelly_ $ run "nix-build" [obeliskImpl]
143+ -- See https://github.com/obsidiansystems/obelisk/issues/101
144+ -- it "can build everything" $ shelly_ $ run "nix-build" [obeliskImpl]
115145
116146 describe "blank initialized project" $ do
117147 it "can be created" $ inProj $ do
118− run "ob" ["init"]
119− run "git" ["init"]
148+ run_ "ob" ["init"]
149+ run_ "git" ["init"]
120150 commitAll
121151
122152 it "can build ghc.backend" $ inProj $ do
@@ -131,7 +161,7 @@ main = do
131161 forM_ ["ghc", "ghcjs"] $ \compiler -> do
132162 let
133163 shell = "shells." <> compiler
134− inShell cmd = run "nix-shell" ["-A", fromString shell, "--run", cmd]
164+ inShell cmd' = run "nix-shell" ["-A", fromString shell, "--run", cmd']
135165 it ("can enter " <> shell) $ inProj $ inShell "exit"
136166 it ("can build in " <> shell) $ inProj $ inShell $ "cabal new-build --" <> fromString compiler <> " all"
137167
@@ -156,15 +186,15 @@ main = do
156186 assertRevNE e eu
157187
158188 it "can pack and unpack plain git repos" $ do
159− withSystemTempDirectory "git-repo" $ \dir -> shelly_ $ do
189+ shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do
160190 let repo = toTextIgnore $ dir </> ("repo" :: String)
161− run_ "git" ["clone", "https://git.haskell.org/packages/primitive.git", repo]
191+ run_ "git" ["clone", "https://github.com/haskell/process.git", repo]
162192 origHash <- chdir (fromText repo) revParseHead
163193
164194 run_ "ob" ["thunk", "pack", repo]
165195 packedFiles <- Set.fromList <$> ls (fromText repo)
166− liftIO $ assertEqual "" packedFiles $
167− Set.fromList $ (repo </>) <$> ["default.nix", "git.json", ".attr-cache" :: String]
196+ liftIO $ assertEqual "" packedFiles $ Set.fromList $ (repo </>) <$>
197+ ["default.nix", "github.json", ".attr-cache" :: String]
168198
169199 run_ "ob" ["thunk", "unpack", repo]
170200 chdir (fromText repo) $ do
@@ -174,7 +204,7 @@ main = do
174204 testThunkPack $ fromText repo
175205
176206 it "aborts thunk pack when there are uncommitted files" $ inProj $ do
177− unpack
207+ void $ unpack
178208 testThunkPack (blankProject </> thunk)
179209
180210-- | Run `ob run` in the given directory (maximum of one level deep)
@@ -191,33 +221,31 @@ testObRunInDir mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e ->
191221 maybe id (\_ -> chdir "..") mdir $ alterRouteTo newUri stdout
192222 (_, runningUri) <- handleObRunStdout httpManager stdout
193223 if runningUri /= newUri
194− then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri
195− else exit 0
224+ then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri
225+ else exit 0
196226
197227testThunkPack :: Shelly.FilePath -> Sh ()
198−testThunkPack path = withTempFile (T.unpack $ toTextIgnore path) "test-file" $ \file handle -> do
199− let try_sh :: Exception e => Sh a -> Sh (Either e a)
200− try_sh a = catch_sh (a >>= pure . Right) (pure . Left)
201− pack' = readProcessWithExitCode "ob" ["thunk", "pack", T.unpack $ toTextIgnore path] ""
202− ensureThunkPackFails err = liftIO $ pack' >>= \case
203− (code, out, _err)
228+testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $ \file handle -> do
229+ let pack' = readProcessWithExitCode "ob" ["thunk", "pack", T.unpack $ toTextIgnore path'] ""
230+ ensureThunkPackFails q = liftIO $ pack' >>= \case
231+ (code, out, err)
204232 | code == ExitSuccess -> fail "ob thunk pack succeeded when it should have failed"
205− | err `T.isInfixOf` T.pack out -> pure ()
206− | otherwise -> fail $ "ob thunk pack failed for an unexpected reason: " <> show out
207− git = chdir path . run "git"
233+ | q `T.isInfixOf` T.pack (out <> err) -> pure ()
234+ | otherwise -> fail $ "ob thunk pack failed for an unexpected reason: " <> show out <> "\nstderr: " <> err
235+ git = chdir path' . run "git"
208236 -- Untracked files
209− ensureThunkPackFails "unsaved modifications"
210− git ["add", T.pack file]
237+ ensureThunkPackFails "Untracked files"
238+ void $ git ["add", T.pack file]
211239 -- Uncommitted files (staged)
212− ensureThunkPackFails "unsaved modifications"
213− chdir path $ commit "test commit"
240+ ensureThunkPackFails "unsaved"
241+ chdir path' $ commit "test commit"
214242 -- Non-pushed commits in any branch
215243 ensureThunkPackFails "not been pushed"
216244 -- Uncommitted files (unstaged)
217245 liftIO $ T.hPutStrLn handle "test file" >> hClose handle
218− ensureThunkPackFails "unsaved modifications"
246+ ensureThunkPackFails "modified"
219247 -- Existing stashes
220− git ["stash"]
248+ void $ git ["stash"]
221249 ensureThunkPackFails "has stashes"
222250
223251-- | Blocks until a non-empty line is available