@@ -4,11 +4,13 @@
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE PatternGuards #-}
66{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE ViewPatterns #-}
87{-# LANGUAGE TemplateHaskell #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE ViewPatterns #-}
910module Obelisk.SelfTest where
1011
11−import Control.Exception (bracket, throw)
12+import Control.Concurrent (threadDelay)
13+import Control.Exception (bracket, throw, try)
1214import Control.Monad
1315import Control.Monad.IO.Class
1416import Data.Bool (bool)
@@ -17,26 +19,24 @@ import Data.Semigroup ((<>))
1719import qualified Data.Set as Set
1820import Data.String
1921import Data.Text (Text)
20−import Data.Void
2122import qualified Data.Text as T
2223import qualified Data.Text.IO as T
2324import qualified Network.HTTP.Client as HTTP
2425import qualified Network.HTTP.Types as HTTP
2526import qualified Network.Socket as Socket
26−import Shelly hiding (cp)
27+import Shelly
2728import System.Directory (getCurrentDirectory, withCurrentDirectory, getDirectoryContents)
2829import System.Environment
2930import System.Exit (ExitCode (..))
30−import System.Which (staticWhich)
31+import System.FilePath (addTrailingPathSeparator)
3132import qualified System.Info
3233import System.IO (Handle, hClose, hIsEOF, hGetContents)
3334import System.IO.Temp
34−import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)
35+import System.Process (readProcessWithExitCode)
36+import System.Which (staticWhich)
3537import Test.Hspec
3638import Test.HUnit.Base
3739
38−import Obelisk.CliApp hiding (runCli, readCreateProcessWithExitCode)
39−import qualified Obelisk.CliApp as CliApp
4040import Obelisk.ExecutableConfig.Lookup (getConfigs)
4141import Obelisk.Run (getConfigRoute)
4242
@@ -46,8 +46,8 @@ data ObRunState
4646 | ObRunState_BackendStarted
4747 deriving (Eq, Show)
4848
49−cp :: FilePath
50−cp = $(staticWhich "cp")
49+cpPath :: FilePath
50+cpPath = $(staticWhich "cp")
5151
5252cabalPath :: FilePath
5353cabalPath = $(staticWhich "cabal")
@@ -73,6 +73,9 @@ lnPath = $(staticWhich "ln")
7373rmPath :: FilePath
7474rmPath = $(staticWhich "rm")
7575
76+rsyncPath :: FilePath
77+rsyncPath = $(staticWhich "rsync")
78+
7679gitUserConfig :: [Text]
7780gitUserConfig = ["-c", "user.name=Obelisk Selftest", "-c", "user.email=noreply@example.com"]
7881
@@ -84,12 +87,6 @@ commit msg = void $ run gitPath $ gitUserConfig <> [ "commit"
8487 , msg
8588 ]
8689
87−-- TODO replace Void and stop using loosely typed synchronous exceptions
88−runCli :: MonadIO m => CliT Void IO a -> m a
89−runCli f = liftIO $ do
90− c <- newCliConfig Notice False False (\case {})
91− CliApp.runCli c f
92−
9390tshow :: Show a => a -> Text
9491tshow = T.pack . show
9592
@@ -106,228 +103,255 @@ ob = "ob"
106103augmentWithVerbosity :: (String -> [Text] -> a) -> String -> Bool -> [Text] -> a
107104augmentWithVerbosity runner executable isVerbose args = runner executable $ (if isVerbose then ("-v" :) else id) args
108105
106+-- | Copies a git repo to a new location and "resets" the git history to include
107+-- exactly one commit with all files added. It then restricts writing and reading
108+-- for group and user to make the repo ideal for being a valid git remote for thunks.
109+--
110+-- Using this allows dirty repos to be used as git remotes during the test since 'git clone'ing
111+-- a dirty repo will not include the uncommitted changes.
112+copyForGitRemote :: Bool -> FilePath -> FilePath -> IO ()
113+copyForGitRemote isVerbose origDir copyDir = shelly $ bool silently verbosely isVerbose $ do
114+ setenv "HOME" "/dev/null"
115+ setenv "GIT_CONFIG_NOSYSTEM" "1"
116+ run_ rsyncPath
117+ [ "-r", "--no-perms", "--no-owner", "--no-group", "--exclude", ".git"
118+ , toTextIgnore (addTrailingPathSeparator origDir), toTextIgnore copyDir
119+ ]
120+ git ["init"]
121+ git ["config", "user.name", "SelfTest"]
122+ git ["config", "user.email", "self@test"]
123+ git ["add", "--all"]
124+ git ["commit", "-m", "Copy repo"]
125+ run_ chmodPath ["-R", "u-w,g-rw,o-rw", toTextIgnore copyDir] -- Freeze this state
126+ where
127+ git args = run_ gitPath $ ["-C", toTextIgnore copyDir] <> args
128+
109129main :: IO ()
110130main = do
111131 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`
112132 isVerbose <- elem "-v" <$> getArgs
113133 unless isVerbose $
114134 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"
115− let verbosity = bool silently verbosely isVerbose
116− nixBuild args = run nixBuildPath ("--no-out-link" : args)
117− obeliskImplDirtyReadOnly <- fromString <$> getCurrentDirectory
118− let runOb_ = augmentWithVerbosity run_ ob isVerbose
119− let runOb = augmentWithVerbosity run ob isVerbose
120− let testObRunInDir' = augmentWithVerbosity testObRunInDir ob isVerbose ["run"]
121− let testThunkPack' = augmentWithVerbosity testThunkPack ob isVerbose []
135+
136+ obeliskImplDirtyReadOnly <- getCurrentDirectory
137+ httpManager <- HTTP.newManager HTTP.defaultManagerSettings
138+
139+ withSystemTempDirectory "obelisk-repo-git-remote" $ \copyDir -> do
140+ copyForGitRemote isVerbose obeliskImplDirtyReadOnly copyDir
141+ main' isVerbose httpManager copyDir
142+
143+main' :: Bool -> HTTP.Manager -> FilePath -> IO ()
144+main' isVerbose httpManager obeliskRepoReadOnly = withInitCache $ \initCache -> hspec $ parallel $ do
122145 let
123− withObeliskImplClean f =
124− withSystemTempDirectory "obelisk-impl-clean" $ \(fromString -> obeliskImpl) -> do
125− void . shellyOb verbosity $ chdir obeliskImpl $ do
126− run_ gitPath ["clone", "file://" <> toTextIgnore obeliskImplDirtyReadOnly, toTextIgnore obeliskImpl]
127− f obeliskImpl
146+ inTmpObInit' dirname f = inTmp' dirname $ \dir -> do
147+ run_ cpPath ["-rT", fromString initCache, toTextIgnore dir]
148+ f dir
149+ inTmpObInit = inTmpObInit' defaultTmpDirName
150+
151+ -- To be used in tests that change the obelisk impl directory
152+ inTmpObInitWithImplCopy f = inTmpObInit $ \dir ->
153+ withObeliskImplClean $ \(fromString -> implClean) -> do
154+ run_ rmPath [thunk]
155+ run_ lnPath ["-s", implClean, thunk]
156+ f dir
157+
158+ describe "ob init" $ parallel $ do
159+ it "works with default impl" $ inTmp $ \_ -> runOb ["init"]
160+ it "works with master branch impl" $ inTmp $ \_ -> runOb ["init", "--branch", "master"]
161+ it "works with symlink" $ inTmp $ \_ -> runOb ["init", "--symlink", toTextIgnore obeliskRepoReadOnly]
162+ it "doesn't silently overwrite existing files" $ inTmp $ \_ -> do
163+ let p force = errExit False $ do
164+ run_ ob $ "--no-handoff" : "-v" : "init" : ["--force"|force]
165+ (== 0) <$> lastExitCode
166+
167+ True <- p False
168+ False <- p False
169+ True <- p True
170+ pure ()
171+
172+ it "doesn't create anything when given an invalid impl" $ inTmp $ \tmp -> do
173+ void $ errExit False $ runOb ["init", "--symlink", "/dev/null"]
174+ ls tmp >>= liftIO . assertEqual "" []
175+
176+ it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $
177+ withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do
178+ configs <- getConfigs
179+ return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing
180+
181+ -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"
182+ -- when not run by 'nix-build --attr selftest'
183+ describe "ob run" $ {- NOT parallel $ -} do
184+ it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir' Nothing httpManager
185+ it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir' (Just "frontend") httpManager
186+
187+ describe "obelisk project" $ parallel $ do
188+ it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , toTextIgnore obeliskRepoReadOnly]
189+ it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", toTextIgnore obeliskRepoReadOnly]
190+ it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", toTextIgnore obeliskRepoReadOnly]
191+ it "can build everything" $ inTmpObInit $ \_ -> nixBuild [toTextIgnore obeliskRepoReadOnly]
192+
193+ describe "blank initialized project" $ parallel $ do
194+
195+ it "can build ghc.backend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghc.backend"]
196+ it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghcjs.frontend"]
197+
198+ if System.Info.os == "darwin"
199+ then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]
200+ else it "can build android after accepting license" $ inTmpObInit $ \dir -> do
201+ let defaultNixPath = dir </> ("default.nix" :: FilePath)
202+ writefile defaultNixPath
203+ =<< T.replace
204+ "# config.android_sdk.accept_license = false;"
205+ "config.android_sdk.accept_license = true;"
206+ <$> readfile defaultNixPath
207+ nixBuild ["-A", "android.frontend"]
208+
209+ forM_ ["ghc", "ghcjs"] $ \compiler -> do
210+ let
211+ shellName = "shells." <> compiler
212+ inShell cmd' = run_ "nix-shell" ["default.nix", "-A", fromString shellName, "--run", cmd']
213+ it ("can enter " <> shellName) $ inTmpObInit $ \_ -> inShell "exit"
214+ -- NOTE: We override the temporary directory name because cabal has a bug preventing new-build from working
215+ -- in a path that has unicode characters.
216+ it ("can build in " <> shellName) $ inTmpObInit' "test" $ \_ -> inShell $
217+ T.pack cabalPath <> " --version; " <> T.pack cabalPath <> " new-build --" <> T.pack compiler <> " all"
218+
219+ it "has idempotent thunk update" $ inTmpObInitWithImplCopy $ \_ -> do
220+ _ <- pack
221+ u <- update
222+ uu <- update
223+ assertRevEQ u uu
224+
225+ describe "ob thunk pack/unpack" $ parallel $ do
226+ it "has thunk pack and unpack inverses" $ inTmpObInitWithImplCopy $ \_ -> do
227+
228+ _ <- pack
229+ e <- commitAll
230+ eu <- unpack
231+ eup <- pack
232+ eupu <- unpack
233+ _ <- pack
234+
235+ assertRevEQ e eup
236+ assertRevEQ eu eupu
237+ assertRevNE e eu
238+
239+ it "unpacks the correct branch" $ withTmp $ \dir -> do
240+ let branch = "master"
241+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]
242+ runOb_ ["thunk", "pack", toTextIgnore dir]
243+ runOb_ ["thunk", "unpack", toTextIgnore dir]
244+ branch' <- chdir dir $ run gitPath ["rev-parse", "--abbrev-ref", "HEAD"]
245+ liftIO $ assertEqual "" branch (T.strip branch')
246+
247+ it "can pack and unpack plain git repos" $
248+ shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do
249+ let repo = toTextIgnore $ dir </> ("repo" :: FilePath)
250+ run_ gitPath ["clone", "https://github.com/haskell/process.git", repo]
251+ origHash <- chdir (fromText repo) revParseHead
252+
253+ runOb_ ["thunk", "pack", repo]
254+ packedFiles <- Set.fromList <$> ls (fromText repo)
255+ liftIO $ assertEqual "" packedFiles $ Set.fromList $ (repo </>) <$>
256+ ["default.nix", "github.json", ".attr-cache" :: FilePath]
257+
258+ runOb_ ["thunk", "unpack", repo]
259+ chdir (fromText repo) $ do
260+ unpackHash <- revParseHead
261+ assertRevEQ origHash unpackHash
262+
263+ testThunkPack' $ fromText repo
264+
265+ it "aborts thunk pack when there are uncommitted files" $ inTmpObInitWithImplCopy $ \dir -> do
266+ testThunkPack' (dir </> thunk)
267+
268+ describe "ob thunk update --branch" $ parallel $ do
269+ it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do
270+ let branch1 = "master"
271+ branch2 = "develop"
272+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch1]
273+ runOb_ ["thunk" , "pack", toTextIgnore dir]
274+ runOb_ ["thunk", "update", toTextIgnore dir, "--branch", branch2]
275+
276+ it "doesn't create anything when given an invalid branch" $ withTmp $ \dir -> do
277+ let checkDir dir' = liftIO $ getDirectoryContents $ T.unpack $ toTextIgnore dir'
278+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", "master"]
279+ runOb_ ["thunk" , "pack", toTextIgnore dir]
280+ startingContents <- checkDir dir
281+ void $ errExit False $ runOb ["thunk", "update", toTextIgnore dir, "--branch", "dumble-palooza"]
282+ checkDir dir >>= liftIO . assertEqual "" startingContents
283+
284+ describe "ob hoogle" $ {- NOT parallel -} do
285+ it "starts a hoogle server on the given port" $ inTmpObInit $ \_ -> do
286+ [p0] <- liftIO $ getFreePorts 1
287+ maskExitSuccess $ runHandle "ob" ["hoogle", "--port", T.pack (show p0)] $ \stdout -> flip fix Nothing $ \loop -> \case
288+ Nothing -> do -- Still waiting for initial signal that the server has started
289+ ln <- liftIO $ T.hGetLine stdout
290+ let search = "Server starting on port " <> T.pack (show p0)
291+ case search `T.isInfixOf` ln of
292+ False -> loop Nothing -- keep waiting
293+ True -> loop $ Just 10
294+ Just (n :: Int) -> do -- Server has started and we have n attempts left
295+ let req uri = liftIO $ try @HTTP.HttpException $ HTTP.parseRequest uri >>= flip HTTP.httpLbs httpManager
296+ req ("http://127.0.0.1:" <> show p0) >>= \case
297+ Right r | HTTP.responseStatus r == HTTP.ok200 -> exit 0
298+ e -> if n <= 0
299+ then errorExit $ "Request to hoogle server failed: " <> T.pack (show e)
300+ else liftIO (threadDelay (1*10^(6 :: Int))) *> loop (Just $ n - 1)
301+ where
302+ verbosity = bool silently verbosely isVerbose
303+ nixBuild args = run nixBuildPath ("--no-out-link" : args)
304+
305+ runOb_ = augmentWithVerbosity run_ ob isVerbose
306+ runOb = augmentWithVerbosity run ob isVerbose
307+ testObRunInDir' = augmentWithVerbosity testObRunInDir ob isVerbose ["run"]
308+ testThunkPack' = augmentWithVerbosity testThunkPack ob isVerbose []
128309
129− withObeliskImplDirty f =
130− withSystemTempDirectory "obelisk-impl-copy" $ \(fromString -> obeliskImpl) -> do
310+ withObeliskImplClean f =
311+ withSystemTempDirectory "obelisk-impl-clean" $ \obeliskImpl -> do
131312 void . shellyOb verbosity $ chdir obeliskImpl $ do
132− user <- T.strip <$> run whoamiPath []
133− run_ cp ["-rT", "--no-preserve=mode", toTextIgnore obeliskImplDirtyReadOnly, toTextIgnore obeliskImpl]
134− run_ chownPath ["-R", user, toTextIgnore obeliskImpl]
135− run_ chmodPath ["-R", "g-rw,o-rw", toTextIgnore obeliskImpl]
313+ dirtyFiles <- T.strip <$> run gitPath ["-C", toTextIgnore obeliskRepoReadOnly, "diff", "--stat"]
314+ () <- when (dirtyFiles /= "") $ error "SelfTest does not work correctly with dirty obelisk repos as remote"
315+ run_ gitPath ["clone", "file://" <> toTextIgnore obeliskRepoReadOnly, toTextIgnore obeliskImpl]
136316 f obeliskImpl
137317
138− withInitCache f obeliskImpl =
318+ withInitCache f =
139319 withSystemTempDirectory "init Cache λ" $ \initCache -> do
140320 -- Setup the ob init cache
141321 void . shellyOb verbosity $ chdir initCache $ do
142− runOb_ ["init", "--symlink", toTextIgnore obeliskImpl]
322+ runOb_ ["init", "--symlink", toTextIgnore obeliskRepoReadOnly]
143323 run_ gitPath ["init"]
144324
145325 f initCache
146326
147− withObeliskImplDirtyAndInitCache f =
148− withObeliskImplDirty $ \impl -> withInitCache (f impl) impl
327+ shelly_ = void . shellyOb verbosity
149328
150− httpManager <- HTTP.newManager HTTP.defaultManagerSettings
329+ defaultTmpDirName = "test λ"
330+
331+ inTmp' :: FilePath -> (FilePath -> Sh a) -> IO ()
332+ inTmp' dirname f = withTmp' dirname (chdir <*> f)
333+ inTmp = inTmp' defaultTmpDirName
334+
335+ withTmp' dirname f = shelly_ . withSystemTempDirectory dirname $ f . fromString
336+ withTmp = withTmp' defaultTmpDirName
337+
338+ assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b
339+ assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b
340+
341+ revParseHead = T.strip <$> run gitPath ["rev-parse", "HEAD"]
342+
343+ commitAll = do
344+ run_ gitPath ["add", "."]
345+ commit "checkpoint"
346+ revParseHead
347+
348+ thunk = ".obelisk/impl"
349+ update = runOb ["thunk", "update", thunk] *> commitAll
350+ pack = runOb ["thunk", "pack", thunk] *> commitAll
351+ unpack = runOb ["thunk", "unpack", thunk] *> commitAll
352+
353+ diff a b = run gitPath ["diff", a, b]
151354
152− withObeliskImplDirtyAndInitCache $ \obeliskImplDirty initCache ->
153− hspec $ parallel $ do
154− let shelly_ = void . shellyOb verbosity
155−
156− defaultTmpDirName = "test λ"
157−
158− inTmp' :: FilePath -> (FilePath -> Sh a) -> IO ()
159− inTmp' dirname f = withTmp' dirname (chdir <*> f)
160− inTmp = inTmp' defaultTmpDirName
161−
162− withTmp' dirname f = shelly_ . withSystemTempDirectory dirname $ f . fromString
163− withTmp = withTmp' defaultTmpDirName
164−
165− inTmpObInit' dirname f = inTmp' dirname $ \dir -> do
166− run_ cp ["-rT", fromString initCache, toTextIgnore dir]
167− f dir
168− inTmpObInit = inTmpObInit' defaultTmpDirName
169−
170− -- To be used in tests that change the obelisk impl directory
171− inTmpObInitWithImplCopy f = inTmpObInit $ \dir ->
172− withObeliskImplClean $ \(fromString -> implClean) -> do
173− run_ rmPath [thunk]
174− run_ lnPath ["-s", implClean, thunk]
175− f dir
176−
177− assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b
178− assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b
179−
180− revParseHead = T.strip <$> run gitPath ["rev-parse", "HEAD"]
181−
182− commitAll = do
183− run_ gitPath ["add", "."]
184− commit "checkpoint"
185− revParseHead
186−
187− thunk = ".obelisk/impl"
188− update = runOb ["thunk", "update", thunk] >> commitAll
189− pack = runOb ["thunk", "pack", thunk] >> commitAll
190− unpack = runOb ["thunk", "unpack", thunk] >> commitAll
191−
192− diff a b = run gitPath ["diff", a, b]
193−
194− describe "ob init" $ parallel $ do
195− it "works with default impl" $ inTmp $ \_ -> runOb ["init"]
196− it "works with master branch impl" $ inTmp $ \_ -> runOb ["init", "--branch", "master"]
197− it "works with symlink" $ inTmp $ \_ -> runOb ["init", "--symlink", toTextIgnore obeliskImplDirty]
198− it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init λ" $ \dir -> do
199− let p force = (System.Process.proc ob $ "--no-handoff" : "-v" : "init" : ["--force"|force]) { cwd = Just dir }
200− (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""
201− (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""
202− (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""
203− pure ()
204−
205− it "doesn't create anything when given an invalid impl" $ inTmp $ \tmp -> do
206− void $ errExit False $ runOb ["init", "--symlink", "/dev/null"]
207− ls tmp >>= liftIO . assertEqual "" []
208−
209− it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $
210− withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do
211− configs <- getConfigs
212− return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing
213−
214− -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"
215− -- when not run by 'nix-build --attr selftest'
216− describe "ob run" $ {- NOT parallel $ -} do
217− it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir' Nothing httpManager
218− it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir' (Just "frontend") httpManager
219−
220− describe "obelisk project" $ parallel $ do
221− it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , toTextIgnore obeliskImplDirty]
222− it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", toTextIgnore obeliskImplDirty]
223− it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", toTextIgnore obeliskImplDirty]
224− it "can build everything" $ inTmpObInit $ \_ -> nixBuild [toTextIgnore obeliskImplDirty]
225−
226− describe "blank initialized project" $ parallel $ do
227−
228− it "can build ghc.backend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghc.backend"]
229− it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghcjs.frontend"]
230−
231− if System.Info.os == "darwin"
232− then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]
233− else it "can build android after accepting license" $ inTmpObInit $ \dir -> do
234− let defaultNixPath = dir </> ("default.nix" :: FilePath)
235− writefile defaultNixPath
236− =<< T.replace
237− "# config.android_sdk.accept_license = false;"
238− "config.android_sdk.accept_license = true;"
239− <$> readfile defaultNixPath
240− nixBuild ["-A", "android.frontend"]
241−
242− forM_ ["ghc", "ghcjs"] $ \compiler -> do
243− let
244− shellName = "shells." <> compiler
245− inShell cmd' = run_ "nix-shell" ["default.nix", "-A", fromString shellName, "--run", cmd']
246− it ("can enter " <> shellName) $ inTmpObInit $ \_ -> inShell "exit"
247− -- NOTE: We override the temporary directory name because cabal has a bug preventing new-build from working
248− -- in a path that has unicode characters.
249− it ("can build in " <> shellName) $ inTmpObInit' "test" $ \_ -> inShell $
250− T.pack cabalPath <> " --version; " <> T.pack cabalPath <> " new-build --" <> T.pack compiler <> " all"
251−
252− it "has idempotent thunk update" $ inTmpObInitWithImplCopy $ \_ -> do
253− _ <- pack
254− u <- update
255− uu <- update
256− assertRevEQ u uu
257−
258− describe "ob thunk pack/unpack" $ parallel $ do
259− it "has thunk pack and unpack inverses" $ inTmpObInitWithImplCopy $ \_ -> do
260−
261− _ <- pack
262− e <- commitAll
263− eu <- unpack
264− eup <- pack
265− eupu <- unpack
266− _ <- pack
267−
268− assertRevEQ e eup
269− assertRevEQ eu eupu
270− assertRevNE e eu
271−
272− it "unpacks the correct branch" $ withTmp $ \dir -> do
273− let branch = "master"
274− run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]
275− runOb_ ["thunk", "pack", toTextIgnore dir]
276− runOb_ ["thunk", "unpack", toTextIgnore dir]
277− branch' <- chdir dir $ run gitPath ["rev-parse", "--abbrev-ref", "HEAD"]
278− liftIO $ assertEqual "" branch (T.strip branch')
279−
280− it "can pack and unpack plain git repos" $
281− shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do
282− let repo = toTextIgnore $ dir </> ("repo" :: String)
283− run_ gitPath ["clone", "https://github.com/haskell/process.git", repo]
284− origHash <- chdir (fromText repo) revParseHead
285−
286− runOb_ ["thunk", "pack", repo]
287− packedFiles <- Set.fromList <$> ls (fromText repo)
288− liftIO $ assertEqual "" packedFiles $ Set.fromList $ (repo </>) <$>
289− ["default.nix", "github.json", ".attr-cache" :: String]
290−
291− runOb_ ["thunk", "unpack", repo]
292− chdir (fromText repo) $ do
293− unpackHash <- revParseHead
294− assertRevEQ origHash unpackHash
295−
296− testThunkPack' $ fromText repo
297−
298− it "aborts thunk pack when there are uncommitted files" $ inTmpObInitWithImplCopy $ \dir -> do
299− testThunkPack' (dir </> thunk)
300−
301− describe "ob thunk update --branch" $ parallel $ do
302− it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do
303− let branch1 = "master"
304− branch2 = "develop"
305− run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch1]
306− runOb_ ["thunk" , "pack", toTextIgnore dir]
307− runOb_ ["thunk", "update", toTextIgnore dir, "--branch", branch2]
308−
309− it "doesn't create anything when given an invalid branch" $ withTmp $ \dir -> do
310− let checkDir dir' = liftIO $ getDirectoryContents $ T.unpack $ toTextIgnore dir'
311− run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", "master"]
312− runOb_ ["thunk" , "pack", toTextIgnore dir]
313− startingContents <- checkDir dir
314− void $ errExit False $ runOb ["thunk", "update", toTextIgnore dir, "--branch", "dumble-palooza"]
315− checkDir dir >>= liftIO . assertEqual "" startingContents
316−
317− describe "ob hoogle" $ {- NOT parallel -} do
318− it "starts a hoogle server on the given port" $ inTmpObInit $ \_ -> do
319− [p0] <- liftIO $ getFreePorts 1
320− maskExitSuccess $ runHandle "ob" ["hoogle", "--port", T.pack (show p0)] $ \stdout -> fix $ \loop -> do
321− ln <- liftIO $ T.hGetLine stdout
322− echo ln
323− let search = "Server starting on port " <> T.pack (show p0)
324− case search `T.isInfixOf` ln of
325− False -> loop -- keep waiting
326− True -> do
327− let req uri = liftIO $ HTTP.parseRequest uri >>= flip HTTP.httpLbs httpManager
328− req ("http://127.0.0.1:" <> show p0) >>= \r -> case HTTP.responseStatus r == HTTP.ok200 of
329− False -> errorExit $ "Request to hoogle server failed: " <> T.pack (show r)
330− True -> exit 0
331355
332356maskExitSuccess :: Sh () -> Sh ()
333357maskExitSuccess = handle_sh (\case ExitSuccess -> pure (); e -> throw e)