git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/selftest/src/Obelisk/SelfTest.hs
328 lines 15 kB history raw
1{-# LANGUAGE EmptyCase #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PatternGuards #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeApplications #-}
7module Obelisk.SelfTest where
9import Control.Exception (bracket, throw)
10import Control.Monad
11import Control.Monad.IO.Class
12import Data.Bool (bool)
13import Data.Function (fix)
14import Data.Semigroup (Semigroup, (<>))
15import qualified Data.Set as Set
16import Data.String
17import Data.Text (Text)
18import Data.Void
19import qualified Data.Text as T
20import qualified Data.Text.IO as T
21import qualified Network.HTTP.Client as HTTP
22import qualified Network.HTTP.Types as HTTP
23import qualified Network.Socket as Socket
24import Shelly
25import System.Directory (withCurrentDirectory, getDirectoryContents)
26import System.Environment
27import System.Exit (ExitCode (..))
28import System.Info
29import System.IO (Handle, hClose)
30import System.IO.Temp
31import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)
32import Test.Hspec
33import Test.HUnit.Base
35import Obelisk.CliApp hiding (runCli, readCreateProcessWithExitCode)
36import qualified Obelisk.CliApp as CliApp
37import Obelisk.ExecutableConfig.Lookup (getConfigs)
38import Obelisk.Run (getConfigRoute)
40data ObRunState
41 = ObRunState_Init
42 | ObRunState_Startup
43 | ObRunState_BackendStarted
44 deriving (Eq, Show)
46doubleQuotes :: (IsString a, Semigroup a) => a -> a
47doubleQuotes s = "\"" <> s <> "\""
49commit :: Text -> Sh ()
50commit msg = void $ run "git"
51 [ "commit"
52 , "--no-gpg-sign"
53 , "--allow-empty"
54 , "-m"
55 , doubleQuotes msg
56 ]
58-- TODO replace Void and stop using loosely typed synchronous exceptions
59runCli :: MonadIO m => CliT Void IO a -> m a
60runCli f = liftIO $ do
61 c <- newCliConfig Notice False False (\case {})
62 CliApp.runCli c f
64tshow :: Show a => a -> Text
65tshow = T.pack . show
67-- | Like `shelly` but used when running `ob` commands
68shellyOb :: MonadIO m => (Sh a -> Sh a) -> Sh a -> m a
69shellyOb f obTest = shelly $ f obTest
71main :: IO ()
72main = do
73 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`
74 isVerbose <- (elem "-v") <$> getArgs
75 unless isVerbose $
76 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"
77 let verbosity = bool silently verbosely isVerbose
78 nixBuild args = run "nix-build" ("--no-out-link" : args)
79 obeliskImpl <- fromString <$> getEnv "OBELISK_IMPL"
80 httpManager <- HTTP.newManager HTTP.defaultManagerSettings
81 [p0, p1, p2, p3] <- liftIO $ getFreePorts 4
82 withSystemTempDirectory "initCache" $ \initCache -> do
83 -- Setup the ob init cache
84 void . shellyOb verbosity $ chdir (fromString initCache) $ do
85 run_ "ob" ["init"]
86 run_ "git" ["init"]
87 hspec $ parallel $ do
88 let shelly_ = void . shellyOb verbosity
90 inTmp :: (Shelly.FilePath -> Sh a) -> IO ()
91 inTmp f = withTmp (chdir <*> f)
93 withTmp f = shelly_ . withSystemTempDirectory "test" $ f . fromString
95 inTmpObInit f = inTmp $ \dir -> do
96 run_ "cp" ["-a", fromString $ initCache <> "/.", toTextIgnore dir]
97 f dir
99 assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b
100 assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b
102 revParseHead = T.strip <$> run "git" ["rev-parse", "HEAD"]
104 commitAll = do
105 run_ "git" ["add", "."]
106 commit "checkpoint"
107 revParseHead
109 thunk = ".obelisk/impl"
110 update = run "ob" ["thunk", "update", thunk] >> commitAll
111 pack = run "ob" ["thunk", "pack", thunk] >> commitAll
112 unpack = run "ob" ["thunk", "unpack", thunk] >> commitAll
114 diff a b = run "git" ["diff", a, b]
116 describe "ob init" $ parallel $ do
117 it "works with default impl" $ inTmp $ \_ -> run "ob" ["init"]
118 it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]
119 it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", obeliskImpl]
120 it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init" $ \dir -> do
121 let p force = (proc "ob" $ "--no-handoff" : "init" : if force then ["--force"] else []) { cwd = Just dir }
122 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""
123 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""
124 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""
125 pure ()
127 it "doesn't create anything when given an invalid impl" $ inTmp $ \tmp -> do
128 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]
129 ls tmp >>= liftIO . assertEqual "" []
131 it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $ do
132 configs <- getConfigs
133 withCurrentDirectory (T.unpack $ toTextIgnore tmp) $
134 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing
136 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"
137 -- when not run by 'nix-build --attr selftest'
138 describe "ob run" $ parallel $ do
139 it "works in root directory" $ inTmpObInit $ \_ -> do
140 testObRunInDir p0 p1 Nothing httpManager
141 it "works in sub directory" $ inTmpObInit $ \_ -> do
142 testObRunInDir p2 p3 (Just "frontend") httpManager
144 describe "obelisk project" $ parallel $ do
145 it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , obeliskImpl]
146 it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", obeliskImpl]
147 it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", obeliskImpl]
148 -- See https://github.com/obsidiansystems/obelisk/issues/101
149 -- it "can build everything" $ shelly_ $ nixBuild [obeliskImpl]
151 describe "blank initialized project" $ parallel $ do
153 it "can build ghc.backend" $ inTmpObInit $ \_ -> do
154 nixBuild ["-A", "ghc.backend"]
155 it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> do
156 nixBuild ["-A", "ghcjs.frontend"]
158 if os == "darwin"
159 then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]
160 else it "can build android" $ inTmpObInit $ \_ -> nixBuild ["-A", "android.frontend"]
162 forM_ ["ghc", "ghcjs"] $ \compiler -> do
163 let
164 shell = "shells." <> compiler
165 inShell cmd' = run "nix-shell" ["-A", fromString shell, "--run", cmd']
166 it ("can enter " <> shell) $ inTmpObInit $ \_ -> inShell "exit"
167 it ("can build in " <> shell) $ inTmpObInit $ \_ -> inShell $ "cabal new-build --" <> fromString compiler <> " all"
169 it "can build reflex project" $ inTmpObInit $ \_ -> do
170 nixBuild []
172 it "has idempotent thunk update" $ inTmpObInit $ \_ -> do
173 u <- update
174 uu <- update
175 assertRevEQ u uu
177 describe "ob thunk pack/unpack" $ parallel $ do
178 it "has thunk pack and unpack inverses" $ inTmpObInit $ \_ -> do
180 e <- commitAll
181 eu <- unpack
182 eup <- pack
183 eupu <- unpack
184 _ <- pack
186 assertRevEQ e eup
187 assertRevEQ eu eupu
188 assertRevNE e eu
190 it "unpacks the correct branch" $ withTmp $ \dir -> do
191 let branch = "master"
192 run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]
193 run_ "ob" ["thunk", "pack", toTextIgnore dir]
194 run_ "ob" ["thunk", "unpack", toTextIgnore dir]
195 branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]
196 liftIO $ assertEqual "" branch (T.strip branch')
198 it "can pack and unpack plain git repos" $ do
199 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do
200 let repo = toTextIgnore $ dir </> ("repo" :: String)
201 run_ "git" ["clone", "https://github.com/haskell/process.git", repo]
202 origHash <- chdir (fromText repo) revParseHead
204 run_ "ob" ["thunk", "pack", repo]
205 packedFiles <- Set.fromList <$> ls (fromText repo)
206 liftIO $ assertEqual "" packedFiles $ Set.fromList $ (repo </>) <$>
207 ["default.nix", "github.json", ".attr-cache" :: String]
209 run_ "ob" ["thunk", "unpack", repo]
210 chdir (fromText repo) $ do
211 unpackHash <- revParseHead
212 assertRevEQ origHash unpackHash
214 testThunkPack $ fromText repo
216 it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do
217 void $ unpack
218 testThunkPack (dir </> thunk)
220 describe "ob thunk update --branch" $ parallel $ do
221 it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do
222 let branch1 = "master"
223 branch2 = "develop"
224 run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch1]
225 run_ "ob" ["thunk" , "pack", toTextIgnore dir]
226 run_ "ob" ["thunk", "update", toTextIgnore dir, "--branch", branch2]
228 it "doesn't create anything when given an invalid branch" $ withTmp $ \dir -> do
229 let checkDir dir' = liftIO $ getDirectoryContents $ T.unpack $ toTextIgnore dir'
230 run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", "master"]
231 run_ "ob" ["thunk" , "pack", toTextIgnore dir]
232 startingContents <- checkDir dir
233 void $ errExit False $ run "ob" ["thunk", "update", toTextIgnore dir, "--branch", "dumble-palooza"]
234 checkDir dir >>= liftIO . assertEqual "" startingContents
237-- | Run `ob run` in the given directory (maximum of one level deep)
238testObRunInDir :: Socket.PortNumber -> Socket.PortNumber -> Maybe Shelly.FilePath -> HTTP.Manager -> Sh ()
239testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do
240 let uri p = "http://localhost:" <> T.pack (show p) <> "/" -- trailing slash required for comparison
241 writefile "config/common/route" $ uri p0
242 maybe id chdir mdir $ runHandle "ob" ["run"] $ \stdout -> do
243 firstUri <- handleObRunStdout httpManager stdout
244 let newUri = uri p1
245 when (firstUri == newUri) $ errorExit $
246 "Startup URI (" <> firstUri <> ") is the same as test URI (" <> newUri <> ")"
247 maybe id (\_ -> chdir "..") mdir $ alterRouteTo newUri stdout
248 runningUri <- handleObRunStdout httpManager stdout
249 if runningUri /= newUri
250 then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri
251 else exit 0
253testThunkPack :: Shelly.FilePath -> Sh ()
254testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $ \file handle -> do
255 let pack' = readProcessWithExitCode "ob" ["thunk", "pack", T.unpack $ toTextIgnore path'] ""
256 ensureThunkPackFails q = liftIO $ pack' >>= \case
257 (code, out, err)
258 | code == ExitSuccess -> fail "ob thunk pack succeeded when it should have failed"
259 | q `T.isInfixOf` T.pack (out <> err) -> pure ()
260 | otherwise -> fail $ "ob thunk pack failed for an unexpected reason: " <> show out <> "\nstderr: " <> err
261 git = chdir path' . run "git"
262 -- Untracked files
263 ensureThunkPackFails "Untracked files"
264 void $ git ["add", T.pack file]
265 -- Uncommitted files (staged)
266 ensureThunkPackFails "unsaved"
267 chdir path' $ commit "test commit"
268 -- Non-pushed commits in any branch
269 ensureThunkPackFails "not yet pushed"
270 -- Uncommitted files (unstaged)
271 liftIO $ T.hPutStrLn handle "test file" >> hClose handle
272 ensureThunkPackFails "modified"
273 -- Existing stashes
274 void $ git ["stash"]
275 ensureThunkPackFails "has stashes"
277-- | Blocks until a non-empty line is available
278hGetLineSkipBlanks :: MonadIO m => Handle -> m Text
279hGetLineSkipBlanks h = liftIO $ fix $ \loop -> T.hGetLine h >>= \case
280 "" -> loop
281 t -> pure t
283-- | Alters the route file and waits for `ob run` to reload
284alterRouteTo :: Text -> Handle -> Sh ()
285alterRouteTo uri stdout = do
286 writefile "config/common/route" uri
287 hGetLineSkipBlanks stdout >>= \t -> when (t /= "Reloading...") $ errorExit $
288 "Reloading failed: " <> T.pack (show t)
289 hGetLineSkipBlanks stdout >>= \t -> when (t /= " config/common/route") $ errorExit $
290 "Reloading failed: " <> T.pack (show t)
291 hGetLineSkipBlanks stdout >>= \t -> when (t /= "Interrupted.") $ errorExit $
292 "Reloading failed: " <> T.pack (show t)
294-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly
295handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text
296handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) -> do
297 liftIO (T.hGetLine stdout) >>= \t -> case state of
298 ObRunState_Init
299 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)
300 ObRunState_Startup
301 | t == "backend stopped; make a change to your code to reload" -> loop (ObRunState_Startup, msgs)
302 -- | Just port <- "Backend running on port " `T.stripPrefix` t -> loop $ ObRunState_BackendStarted port
303 | not (T.null t) -> errorExit $ "Startup: " <> t -- If theres any other output here, startup failed
304 ObRunState_BackendStarted
305 | Just uri <- "Frontend running on " `T.stripPrefix` t -> do
306 obRunCheck httpManager stdout uri
307 pure uri
308 | not (T.null t) -> errorExit $ "Started: " <> t -- If theres any other output here, startup failed
309 _ | "Failed" `T.isPrefixOf` t -> errorExit $ "ob run failed: " <> T.unlines (reverse $ t : msgs)
310 | otherwise -> loop (state, t : msgs)
312-- | Make requests to frontend/backend servers to check they are working properly
313obRunCheck :: HTTP.Manager -> Handle -> Text -> Sh ()
314obRunCheck httpManager _stdout frontendUri = do
315 let req uri = liftIO $ HTTP.parseRequest (T.unpack uri) >>= flip HTTP.httpLbs httpManager
316 req frontendUri >>= \r -> when (HTTP.responseStatus r /= HTTP.ok200) $ errorExit $
317 "Request to frontend server failed: " <> T.pack (show r)
319getFreePorts :: Int -> IO [Socket.PortNumber]
320getFreePorts 0 = pure []
321getFreePorts n = Socket.withSocketsDo $ do
322 addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")
323 bracket (open addr) Socket.close $ \s -> (:) <$> Socket.socketPort s <*> getFreePorts (n - 1)
324 where
325 open addr = do
326 sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)
327 Socket.bind sock (Socket.addrAddress addr)
328 pure sock