@@ -4,6 +4,7 @@
44{-# LANGUAGE PatternGuards #-}
55{-# LANGUAGE ScopedTypeVariables #-}
66{-# LANGUAGE ViewPatterns #-}
7+{-# LANGUAGE TemplateHaskell #-}
78module Obelisk.SelfTest where
89
910import Control.Exception (bracket, throw)
@@ -11,7 +12,7 @@ import Control.Monad
1112import Control.Monad.IO.Class
1213import Data.Bool (bool)
1314import Data.Function (fix)
14−import Data.Semigroup (Semigroup, (<>))
15+import Data.Semigroup ((<>))
1516import qualified Data.Set as Set
1617import Data.String
1718import Data.Text (Text)
@@ -21,10 +22,12 @@ import qualified Data.Text.IO as T
2122import qualified Network.HTTP.Client as HTTP
2223import qualified Network.HTTP.Types as HTTP
2324import qualified Network.Socket as Socket
24−import Shelly
25+import Shelly hiding (cp)
2526import System.Directory (withCurrentDirectory, getDirectoryContents)
2627import System.Environment
2728import System.Exit (ExitCode (..))
29+import System.FilePath (replaceBaseName, takeBaseName)
30+import System.Which (staticWhich)
2831import qualified System.Info
2932import System.IO (Handle, hClose)
3033import System.IO.Temp
@@ -43,16 +46,21 @@ data ObRunState
4346 | ObRunState_BackendStarted
4447 deriving (Eq, Show)
4548
46−doubleQuotes :: (IsString a, Semigroup a) => a -> a
47−doubleQuotes s = "\"" <> s <> "\""
49+cp :: FilePath
50+cp = $(staticWhich "cp")
51+
52+cabalPath :: FilePath
53+cabalPath = $(staticWhich "cabal")
54+
55+gitUserConfig :: [Text]
56+gitUserConfig = ["-c", "user.name=Obelisk Selftest", "-c", "user.email=noreply@example.com"]
4857
4958commit :: Text -> Sh ()
50−commit msg = void $ run "git"
51− [ "commit"
59+commit msg = void $ run "git" $ gitUserConfig <> [ "commit"
5260 , "--no-gpg-sign"
5361 , "--allow-empty"
5462 , "-m"
55− , doubleQuotes msg
63+ , msg
5664 ]
5765
5866-- TODO replace Void and stop using loosely typed synchronous exceptions
@@ -68,6 +76,7 @@ tshow = T.pack . show
6876shellyOb :: MonadIO m => (Sh a -> Sh a) -> Sh a -> m a
6977shellyOb f obTest = shelly $ f obTest
7078
79+
7180main :: IO ()
7281main = do
7382 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`
@@ -82,33 +91,49 @@ main = do
8291 withSystemTempDirectory "obelisk-impl-copy" $ \(fromString -> obeliskImpl) -> do
8392 void . shellyOb verbosity $ chdir obeliskImpl $ do
8493 user <- T.strip <$> run "whoami" []
85− run_ "cp" ["-rT", toTextIgnore obeliskImplRaw, toTextIgnore obeliskImpl]
94+ run_ cp ["-rT", toTextIgnore obeliskImplRaw, toTextIgnore obeliskImpl]
8695 run_ "chown" ["-R", user, toTextIgnore obeliskImpl]
8796 run_ "chmod" ["-R", "g-rw,o-rw", toTextIgnore obeliskImpl]
97+ f obeliskImpl
98+
99+ withInitCache f obeliskImpl =
100+ withSystemTempDirectory "init Cache λ" $ \initCache -> do
101+ -- Setup the ob init cache
102+ void . shellyOb verbosity $ chdir initCache $ do
103+ run_ "ob" ["init", "--symlink", toTextIgnore obeliskImpl]
104+ run_ "git" ["init"]
88105
89− withSystemTempDirectory "init Cache λ" $ \initCache -> do
90− -- Setup the ob init cache
91− void . shellyOb verbosity $ chdir (fromString initCache) $ do
92− run_ "ob" ["init", "--symlink", toTextIgnore obeliskImpl]
93− run_ "git" ["init"]
106+ f initCache
94107
95− f obeliskImpl initCache
108+ withObeliskImplAndInitCache f =
109+ withObeliskImpl $ \impl -> withInitCache (f impl) impl
96110
97111 httpManager <- HTTP.newManager HTTP.defaultManagerSettings
98− [p0, p1, p2, p3] <- liftIO $ getFreePorts 4
99112
100− withObeliskImpl $ \obeliskImpl initCache ->
113+ withObeliskImplAndInitCache $ \obeliskImpl initCache ->
101114 hspec $ parallel $ do
102115 let shelly_ = void . shellyOb verbosity
103116
104− inTmp :: (Shelly.FilePath -> Sh a) -> IO ()
105− inTmp f = withTmp (chdir <*> f)
117+ defaultTmpDirName = "test λ"
106118
107− withTmp f = shelly_ . withSystemTempDirectory "test λ" $ f . fromString
119+ inTmp' :: FilePath -> (FilePath -> Sh a) -> IO ()
120+ inTmp' dirname f = withTmp' dirname (chdir <*> f)
121+ inTmp = inTmp' defaultTmpDirName
108122
109− inTmpObInit f = inTmp $ \dir -> do
110− run_ "cp" ["-rT", fromString initCache, toTextIgnore dir]
123+ withTmp' dirname f = shelly_ . withSystemTempDirectory dirname $ f . fromString
124+ withTmp = withTmp' defaultTmpDirName
125+
126+ inTmpObInit' dirname f = inTmp' dirname $ \dir -> do
127+ run_ cp ["-rT", fromString initCache, toTextIgnore dir]
111128 f dir
129+ inTmpObInit = inTmpObInit' defaultTmpDirName
130+
131+ -- To be used in tests that change the obelisk impl directory
132+ inTmpObInitWithImplCopy f = inTmpObInit $ \dir ->
133+ withObeliskImpl $ \(fromString -> implCopy) -> do
134+ run_ "rm" [thunk]
135+ run_ "ln" ["-s", implCopy, thunk]
136+ f dir
112137
113138 assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b
114139 assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b
@@ -149,9 +174,12 @@ main = do
149174
150175 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"
151176 -- when not run by 'nix-build --attr selftest'
152− describe "ob run" $ parallel $ do
153− it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir p0 p1 Nothing httpManager
154− it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir p2 p3 (Just "frontend") httpManager
177+ describe "ob run" $ {- NOT parallel $ -} do
178+ it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir Nothing httpManager
179+ it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir (Just "frontend") httpManager
180+ it "works with differently named cabal files" $ inTmpObInit $ \_ -> do
181+ changeCabalPackageName "backend/backend.cabal" "new-backend"
182+ testObRunInDir Nothing httpManager
155183
156184 describe "obelisk project" $ parallel $ do
157185 it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , toTextIgnore obeliskImpl]
@@ -167,7 +195,7 @@ main = do
167195 if System.Info.os == "darwin"
168196 then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]
169197 else it "can build android after accepting license" $ inTmpObInit $ \dir -> do
170− let defaultNixPath = dir </> ("default.nix" :: Shelly.FilePath)
198+ let defaultNixPath = dir </> ("default.nix" :: FilePath)
171199 writefile defaultNixPath
172200 =<< T.replace
173201 "# config.android_sdk.accept_license = false;"
@@ -178,18 +206,21 @@ main = do
178206 forM_ ["ghc", "ghcjs"] $ \compiler -> do
179207 let
180208 shellName = "shells." <> compiler
181− inShell cmd' = run "nix-shell" ["default.nix", "-A", fromString shellName, "--run", cmd']
209+ inShell cmd' = run_ "nix-shell" ["default.nix", "-A", fromString shellName, "--run", cmd']
182210 it ("can enter " <> shellName) $ inTmpObInit $ \_ -> inShell "exit"
183− it ("can build in " <> shellName) $ inTmpObInit $ \_ -> inShell $ "cabal new-build --" <> fromString compiler <> " all"
211+ -- NOTE: We override the temporary directory name because cabal has a bug preventing new-build from working
212+ -- in a path that has unicode characters.
213+ it ("can build in " <> shellName) $ inTmpObInit' "test" $ \_ -> inShell $
214+ T.pack cabalPath <> " --version; " <> T.pack cabalPath <> " new-build --" <> T.pack compiler <> " all"
184215
185− it "has idempotent thunk update" $ inTmpObInit $ \_ -> do
216+ it "has idempotent thunk update" $ inTmpObInitWithImplCopy $ \_ -> do
186217 _ <- pack
187218 u <- update
188219 uu <- update
189220 assertRevEQ u uu
190221
191222 describe "ob thunk pack/unpack" $ parallel $ do
192− it "has thunk pack and unpack inverses" $ inTmpObInit $ \_ -> do
223+ it "has thunk pack and unpack inverses" $ inTmpObInitWithImplCopy $ \_ -> do
193224
194225 _ <- pack
195226 e <- commitAll
@@ -249,8 +280,9 @@ main = do
249280
250281
251282-- | Run `ob run` in the given directory (maximum of one level deep)
252−testObRunInDir :: Socket.PortNumber -> Socket.PortNumber -> Maybe Shelly.FilePath -> HTTP.Manager -> Sh ()
253−testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do
283+testObRunInDir :: Maybe FilePath -> HTTP.Manager -> Sh ()
284+testObRunInDir mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do
285+ [p0, p1] <- liftIO $ getFreePorts 2
254286 let uri p = "http://localhost:" <> T.pack (show p) <> "/" -- trailing slash required for comparison
255287 writefile "config/common/route" $ uri p0
256288 maybe id chdir mdir $ runHandle "ob" ["run", "-v"] $ \stdout -> do
@@ -264,7 +296,7 @@ testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure ();
264296 then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri
265297 else exit 0
266298
267−testThunkPack :: Shelly.FilePath -> Sh ()
299+testThunkPack :: FilePath -> Sh ()
268300testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $ \file handle -> do
269301 let pack' = readProcessWithExitCode "ob" ["thunk", "pack", T.unpack $ toTextIgnore path'] ""
270302 ensureThunkPackFails q = liftIO $ pack' >>= \case
@@ -285,7 +317,7 @@ testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $
285317 liftIO $ T.hPutStrLn handle "test file" >> hClose handle
286318 ensureThunkPackFails "modified"
287319 -- Existing stashes
288− void $ git ["stash"]
320+ void $ git $ gitUserConfig <> [ "stash" ]
289321 ensureThunkPackFails "has stashes"
290322
291323-- | Blocks until a non-empty line is available
@@ -330,6 +362,14 @@ obRunCheck httpManager _stdout frontendUri = do
330362 req frontendUri >>= \r -> when (HTTP.responseStatus r /= HTTP.ok200) $ errorExit $
331363 "Request to frontend server failed: " <> T.pack (show r)
332364
365+-- | Rename a cabal file and do a really dumb, brittle search/replace in its content to update the name.
366+changeCabalPackageName :: FilePath -> Text -> Sh ()
367+changeCabalPackageName cabalFile newName = do
368+ contents <- readfile cabalFile
369+ writefile (replaceBaseName cabalFile (T.unpack newName)) $
370+ T.replace (" " <> T.pack (takeBaseName cabalFile)) (" " <> newName) contents -- WARNING: Super brittle
371+ rm cabalFile
372+
333373getFreePorts :: Int -> IO [Socket.PortNumber]
334374getFreePorts 0 = pure []
335375getFreePorts n = Socket.withSocketsDo $ do