@@ -4,8 +4,8 @@
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE PatternGuards #-}
66{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE ViewPatterns #-}
87{-# LANGUAGE TemplateHaskell #-}
8+{-# LANGUAGE ViewPatterns #-}
99module Obelisk.SelfTest where
1010
1111import Control.Exception (bracket, throw)
@@ -17,26 +17,24 @@ import Data.Semigroup ((<>))
1717import qualified Data.Set as Set
1818import Data.String
1919import Data.Text (Text)
20−import Data.Void
2120import qualified Data.Text as T
2221import qualified Data.Text.IO as T
2322import qualified Network.HTTP.Client as HTTP
2423import qualified Network.HTTP.Types as HTTP
2524import qualified Network.Socket as Socket
26−import Shelly hiding (cp)
25+import Shelly
2726import System.Directory (getCurrentDirectory, withCurrentDirectory, getDirectoryContents)
2827import System.Environment
2928import System.Exit (ExitCode (..))
30−import System.Which (staticWhich)
29+import System.FilePath (addTrailingPathSeparator)
3130import qualified System.Info
3231import System.IO (Handle, hClose, hIsEOF, hGetContents)
3332import System.IO.Temp
34−import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)
33+import System.Process (readProcessWithExitCode)
34+import System.Which (staticWhich)
3535import Test.Hspec
3636import Test.HUnit.Base
3737
38−import Obelisk.CliApp hiding (runCli, readCreateProcessWithExitCode)
39−import qualified Obelisk.CliApp as CliApp
4038import Obelisk.ExecutableConfig.Lookup (getConfigs)
4139import Obelisk.Run (getConfigRoute)
4240
@@ -46,8 +44,8 @@ data ObRunState
4644 | ObRunState_BackendStarted
4745 deriving (Eq, Show)
4846
49−cp :: FilePath
50−cp = $(staticWhich "cp")
47+cpPath :: FilePath
48+cpPath = $(staticWhich "cp")
5149
5250cabalPath :: FilePath
5351cabalPath = $(staticWhich "cabal")
@@ -73,6 +71,9 @@ lnPath = $(staticWhich "ln")
7371rmPath :: FilePath
7472rmPath = $(staticWhich "rm")
7573
74+rsyncPath :: FilePath
75+rsyncPath = $(staticWhich "rsync")
76+
7677gitUserConfig :: [Text]
7778gitUserConfig = ["-c", "user.name=Obelisk Selftest", "-c", "user.email=noreply@example.com"]
7879
@@ -84,12 +85,6 @@ commit msg = void $ run gitPath $ gitUserConfig <> [ "commit"
8485 , msg
8586 ]
8687
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−
9388tshow :: Show a => a -> Text
9489tshow = T.pack . show
9590
@@ -106,228 +101,252 @@ ob = "ob"
106101augmentWithVerbosity :: (String -> [Text] -> a) -> String -> Bool -> [Text] -> a
107102augmentWithVerbosity runner executable isVerbose args = runner executable $ (if isVerbose then ("-v" :) else id) args
108103
104+-- | Copies a git repo to a new location and "resets" the git history to include
105+-- exactly one commit with all files added. It then restricts writing and reading
106+-- for group and user to make the repo ideal for being a valid git remote for thunks.
107+--
108+-- Using this allows dirty repos to be used as git remotes during the test since 'git clone'ing
109+-- a dirty repo will not include the uncommitted changes.
110+copyForGitRemote :: Bool -> FilePath -> FilePath -> IO ()
111+copyForGitRemote isVerbose origDir copyDir = shelly $ bool silently verbosely isVerbose $ do
112+ setenv "HOME" "/dev/null"
113+ setenv "GIT_CONFIG_NOSYSTEM" "1"
114+ run_ rsyncPath
115+ [ "-r", "--no-perms", "--no-owner", "--no-group", "--exclude", ".git"
116+ , toTextIgnore (addTrailingPathSeparator origDir), toTextIgnore copyDir
117+ ]
118+ git ["init"]
119+ git ["config", "user.name", "SelfTest"]
120+ git ["config", "user.email", "self@test"]
121+ git ["add", "--all"]
122+ git ["commit", "-m", "Copy repo"]
123+ run_ chmodPath ["-R", "u-w,g-rw,o-rw", toTextIgnore copyDir] -- Freeze this state
124+ where
125+ git args = run_ gitPath $ ["-C", toTextIgnore copyDir] <> args
126+
109127main :: IO ()
110128main = do
111129 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`
112130 isVerbose <- elem "-v" <$> getArgs
113131 unless isVerbose $
114132 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 []
133+
134+ obeliskImplDirtyReadOnly <- getCurrentDirectory
135+ httpManager <- HTTP.newManager HTTP.defaultManagerSettings
136+
137+ withSystemTempDirectory "obelisk-repo-git-remote" $ \copyDir -> do
138+ copyForGitRemote isVerbose obeliskImplDirtyReadOnly copyDir
139+ main' isVerbose httpManager copyDir
140+
141+main' :: Bool -> HTTP.Manager -> FilePath -> IO ()
142+main' isVerbose httpManager obeliskRepoReadOnly = withInitCache $ \initCache -> hspec $ parallel $ do
122143 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
144+ inTmpObInit' dirname f = inTmp' dirname $ \dir -> do
145+ run_ cpPath ["-rT", fromString initCache, toTextIgnore dir]
146+ f dir
147+ inTmpObInit = inTmpObInit' defaultTmpDirName
148+
149+ -- To be used in tests that change the obelisk impl directory
150+ inTmpObInitWithImplCopy f = inTmpObInit $ \dir ->
151+ withObeliskImplClean $ \(fromString -> implClean) -> do
152+ run_ rmPath [thunk]
153+ run_ lnPath ["-s", implClean, thunk]
154+ f dir
155+
156+ describe "ob init" $ parallel $ do
157+ it "works with default impl" $ inTmp $ \_ -> runOb ["init"]
158+ it "works with master branch impl" $ inTmp $ \_ -> runOb ["init", "--branch", "master"]
159+ it "works with symlink" $ inTmp $ \_ -> runOb ["init", "--symlink", toTextIgnore obeliskRepoReadOnly]
160+ it "doesn't silently overwrite existing files" $ inTmp $ \_ -> do
161+ let p force = errExit False $ do
162+ run_ ob $ "--no-handoff" : "-v" : "init" : ["--force"|force]
163+ (== 0) <$> lastExitCode
164+
165+ True <- p False
166+ False <- p False
167+ True <- p True
168+ pure ()
169+
170+ it "doesn't create anything when given an invalid impl" $ inTmp $ \tmp -> do
171+ void $ errExit False $ runOb ["init", "--symlink", "/dev/null"]
172+ ls tmp >>= liftIO . assertEqual "" []
173+
174+ it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $
175+ withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do
176+ configs <- getConfigs
177+ return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing
178+
179+ -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"
180+ -- when not run by 'nix-build --attr selftest'
181+ describe "ob run" $ {- NOT parallel $ -} do
182+ it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir' Nothing httpManager
183+ it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir' (Just "frontend") httpManager
184+
185+ describe "obelisk project" $ parallel $ do
186+ it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , toTextIgnore obeliskRepoReadOnly]
187+ it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", toTextIgnore obeliskRepoReadOnly]
188+ it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", toTextIgnore obeliskRepoReadOnly]
189+ it "can build everything" $ inTmpObInit $ \_ -> nixBuild [toTextIgnore obeliskRepoReadOnly]
190+
191+ describe "blank initialized project" $ parallel $ do
192+
193+ it "can build ghc.backend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghc.backend"]
194+ it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghcjs.frontend"]
195+
196+ if System.Info.os == "darwin"
197+ then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]
198+ else it "can build android after accepting license" $ inTmpObInit $ \dir -> do
199+ let defaultNixPath = dir </> ("default.nix" :: FilePath)
200+ writefile defaultNixPath
201+ =<< T.replace
202+ "# config.android_sdk.accept_license = false;"
203+ "config.android_sdk.accept_license = true;"
204+ <$> readfile defaultNixPath
205+ nixBuild ["-A", "android.frontend"]
206+
207+ forM_ ["ghc", "ghcjs"] $ \compiler -> do
208+ let
209+ shellName = "shells." <> compiler
210+ inShell cmd' = run_ "nix-shell" ["default.nix", "-A", fromString shellName, "--run", cmd']
211+ it ("can enter " <> shellName) $ inTmpObInit $ \_ -> inShell "exit"
212+ -- NOTE: We override the temporary directory name because cabal has a bug preventing new-build from working
213+ -- in a path that has unicode characters.
214+ it ("can build in " <> shellName) $ inTmpObInit' "test" $ \_ -> inShell $
215+ T.pack cabalPath <> " --version; " <> T.pack cabalPath <> " new-build --" <> T.pack compiler <> " all"
216+
217+ it "has idempotent thunk update" $ inTmpObInitWithImplCopy $ \_ -> do
218+ _ <- pack
219+ u <- update
220+ uu <- update
221+ assertRevEQ u uu
222+
223+ describe "ob thunk pack/unpack" $ parallel $ do
224+ it "has thunk pack and unpack inverses" $ inTmpObInitWithImplCopy $ \_ -> do
225+
226+ _ <- pack
227+ e <- commitAll
228+ eu <- unpack
229+ eup <- pack
230+ eupu <- unpack
231+ _ <- pack
232+
233+ assertRevEQ e eup
234+ assertRevEQ eu eupu
235+ assertRevNE e eu
236+
237+ it "unpacks the correct branch" $ withTmp $ \dir -> do
238+ let branch = "master"
239+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]
240+ runOb_ ["thunk", "pack", toTextIgnore dir]
241+ runOb_ ["thunk", "unpack", toTextIgnore dir]
242+ branch' <- chdir dir $ run gitPath ["rev-parse", "--abbrev-ref", "HEAD"]
243+ liftIO $ assertEqual "" branch (T.strip branch')
244+
245+ it "can pack and unpack plain git repos" $
246+ shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do
247+ let repo = toTextIgnore $ dir </> ("repo" :: FilePath)
248+ run_ gitPath ["clone", "https://github.com/haskell/process.git", repo]
249+ origHash <- chdir (fromText repo) revParseHead
250+
251+ runOb_ ["thunk", "pack", repo]
252+ packedFiles <- Set.fromList <$> ls (fromText repo)
253+ liftIO $ assertEqual "" packedFiles $ Set.fromList $ (repo </>) <$>
254+ ["default.nix", "github.json", ".attr-cache" :: FilePath]
255+
256+ runOb_ ["thunk", "unpack", repo]
257+ chdir (fromText repo) $ do
258+ unpackHash <- revParseHead
259+ assertRevEQ origHash unpackHash
260+
261+ testThunkPack' $ fromText repo
262+
263+ it "aborts thunk pack when there are uncommitted files" $ inTmpObInitWithImplCopy $ \dir -> do
264+ testThunkPack' (dir </> thunk)
265+
266+ describe "ob thunk update --branch" $ parallel $ do
267+ it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do
268+ let branch1 = "master"
269+ branch2 = "develop"
270+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch1]
271+ runOb_ ["thunk" , "pack", toTextIgnore dir]
272+ runOb_ ["thunk", "update", toTextIgnore dir, "--branch", branch2]
273+
274+ it "doesn't create anything when given an invalid branch" $ withTmp $ \dir -> do
275+ let checkDir dir' = liftIO $ getDirectoryContents $ T.unpack $ toTextIgnore dir'
276+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", "master"]
277+ runOb_ ["thunk" , "pack", toTextIgnore dir]
278+ startingContents <- checkDir dir
279+ void $ errExit False $ runOb ["thunk", "update", toTextIgnore dir, "--branch", "dumble-palooza"]
280+ checkDir dir >>= liftIO . assertEqual "" startingContents
281+
282+ describe "ob hoogle" $ {- NOT parallel -} do
283+ it "starts a hoogle server on the given port" $ inTmpObInit $ \_ -> do
284+ [p0] <- liftIO $ getFreePorts 1
285+ maskExitSuccess $ runHandle "ob" ["hoogle", "--port", T.pack (show p0)] $ \stdout -> fix $ \loop -> do
286+ ln <- liftIO $ T.hGetLine stdout
287+ echo ln
288+ let search = "Server starting on port " <> T.pack (show p0)
289+ case search `T.isInfixOf` ln of
290+ False -> loop -- keep waiting
291+ True -> do
292+ let req uri = liftIO $ HTTP.parseRequest uri >>= flip HTTP.httpLbs httpManager
293+ req ("http://127.0.0.1:" <> show p0) >>= \r -> case HTTP.responseStatus r == HTTP.ok200 of
294+ False -> errorExit $ "Request to hoogle server failed: " <> T.pack (show r)
295+ True -> exit 0
296+ where
297+ verbosity = bool silently verbosely isVerbose
298+ nixBuild args = run nixBuildPath ("--no-out-link" : args)
299+
300+ runOb_ = augmentWithVerbosity run_ ob isVerbose
301+ runOb = augmentWithVerbosity run ob isVerbose
302+ testObRunInDir' = augmentWithVerbosity testObRunInDir ob isVerbose ["run"]
303+ testThunkPack' = augmentWithVerbosity testThunkPack ob isVerbose []
128304
129− withObeliskImplDirty f =
130− withSystemTempDirectory "obelisk-impl-copy" $ \(fromString -> obeliskImpl) -> do
305+ withObeliskImplClean f =
306+ withSystemTempDirectory "obelisk-impl-clean" $ \obeliskImpl -> do
131307 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]
308+ dirtyFiles <- T.strip <$> run gitPath ["-C", toTextIgnore obeliskRepoReadOnly, "diff", "--stat"]
309+ () <- when (dirtyFiles /= "") $ error "SelfTest does not work correctly with dirty obelisk repos as remote"
310+ run_ gitPath ["clone", "file://" <> toTextIgnore obeliskRepoReadOnly, toTextIgnore obeliskImpl]
136311 f obeliskImpl
137312
138− withInitCache f obeliskImpl =
313+ withInitCache f =
139314 withSystemTempDirectory "init Cache λ" $ \initCache -> do
140315 -- Setup the ob init cache
141316 void . shellyOb verbosity $ chdir initCache $ do
142− runOb_ ["init", "--symlink", toTextIgnore obeliskImpl]
317+ runOb_ ["init", "--symlink", toTextIgnore obeliskRepoReadOnly]
143318 run_ gitPath ["init"]
144319
145320 f initCache
146321
147− withObeliskImplDirtyAndInitCache f =
148− withObeliskImplDirty $ \impl -> withInitCache (f impl) impl
322+ shelly_ = void . shellyOb verbosity
149323
150− httpManager <- HTTP.newManager HTTP.defaultManagerSettings
324+ defaultTmpDirName = "test λ"
325+
326+ inTmp' :: FilePath -> (FilePath -> Sh a) -> IO ()
327+ inTmp' dirname f = withTmp' dirname (chdir <*> f)
328+ inTmp = inTmp' defaultTmpDirName
329+
330+ withTmp' dirname f = shelly_ . withSystemTempDirectory dirname $ f . fromString
331+ withTmp = withTmp' defaultTmpDirName
332+
333+ assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b
334+ assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b
335+
336+ revParseHead = T.strip <$> run gitPath ["rev-parse", "HEAD"]
337+
338+ commitAll = do
339+ run_ gitPath ["add", "."]
340+ commit "checkpoint"
341+ revParseHead
342+
343+ thunk = ".obelisk/impl"
344+ update = runOb ["thunk", "update", thunk] *> commitAll
345+ pack = runOb ["thunk", "pack", thunk] *> commitAll
346+ unpack = runOb ["thunk", "unpack", thunk] *> commitAll
347+
348+ diff a b = run gitPath ["diff", a, b]
151349
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
331350
332351maskExitSuccess :: Sh () -> Sh ()
333352maskExitSuccess = handle_sh (\case ExitSuccess -> pure (); e -> throw e)