diff --git a/driver/seito.hs b/driver/seito.hs --- a/driver/seito.hs +++ b/driver/seito.hs @@ -8,6 +8,6 @@ main :: IO () main = do - (success, output) <- client + (success, output) <- client "" L.putStr output unless success exitFailure diff --git a/sensei.cabal b/sensei.cabal --- a/sensei.cabal +++ b/sensei.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: sensei -version: 0.7.0 +version: 0.8.0 synopsis: Automatically run Hspec tests on file modifications category: Development homepage: https://github.com/hspec/sensei#readme @@ -23,133 +23,237 @@ executable seito main-is: seito.hs + other-modules: + Client + Config + EventQueue + HTTP + Imports + Input + Language.Haskell.GhciWrapper + Options + Pager + ReadHandle + Run + Session + Trigger + Util + Paths_sensei hs-source-dirs: src driver - ghc-options: -Wall + default-extensions: + DuplicateRecordFields + LambdaCase + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + ViewPatterns + other-extensions: + NoFieldSelectors + ghc-options: -Wall -threaded build-depends: - ansi-terminal + aeson + , ansi-terminal + , async , base >=4.11 && <5 - , bytestring + , bytestring >=0.11 + , casing + , containers , directory , filepath , fsnotify ==0.4.* , http-client >=0.5.0 , http-types + , mtl , network , process , stm , text , time + , transformers , unix , wai , warp + , yaml + default-language: GHC2021 + +executable sensei + main-is: sensei.hs other-modules: Client + Config EventQueue HTTP Imports + Input Language.Haskell.GhciWrapper Options + Pager ReadHandle Run Session Trigger Util Paths_sensei - default-language: Haskell2010 - -executable sensei - main-is: sensei.hs hs-source-dirs: src driver - ghc-options: -Wall + default-extensions: + DuplicateRecordFields + LambdaCase + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + ViewPatterns + other-extensions: + NoFieldSelectors + ghc-options: -Wall -threaded build-depends: - ansi-terminal + aeson + , ansi-terminal + , async , base >=4.11 && <5 - , bytestring + , bytestring >=0.11 + , casing + , containers , directory , filepath , fsnotify ==0.4.* , http-client >=0.5.0 , http-types + , mtl , network , process , stm , text , time + , transformers , unix , wai , warp + , yaml + default-language: GHC2021 + +executable sensei-web + main-is: sensei-web.hs other-modules: Client + Config EventQueue HTTP Imports + Input Language.Haskell.GhciWrapper Options + Pager ReadHandle Run Session Trigger Util Paths_sensei - default-language: Haskell2010 - -executable sensei-web - main-is: sensei-web.hs hs-source-dirs: src driver - ghc-options: -Wall + default-extensions: + DuplicateRecordFields + LambdaCase + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + ViewPatterns + other-extensions: + NoFieldSelectors + ghc-options: -Wall -threaded build-depends: - ansi-terminal + aeson + , ansi-terminal + , async , base >=4.11 && <5 - , bytestring + , bytestring >=0.11 + , casing + , containers , directory , filepath , fsnotify ==0.4.* , http-client >=0.5.0 , http-types + , mtl , network , process , stm , text , time + , transformers , unix , wai , warp + , yaml + default-language: GHC2021 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs other-modules: Client + Config EventQueue HTTP Imports + Input Language.Haskell.GhciWrapper Options + Pager ReadHandle Run Session Trigger Util + ClientSpec + ConfigSpec + EventQueueSpec + Helper + HTTPSpec + Language.Haskell.GhciWrapperSpec + OptionsSpec + PagerSpec + ReadHandleSpec + RunSpec + SessionSpec + SpecHook + TriggerSpec + UtilSpec Paths_sensei - default-language: Haskell2010 - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs hs-source-dirs: src test - ghc-options: -Wall + default-extensions: + DuplicateRecordFields + LambdaCase + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + RecordWildCards + ViewPatterns + other-extensions: + NoFieldSelectors + ghc-options: -Wall -threaded cpp-options: -DTEST build-tool-depends: hspec-discover:hspec-discover build-depends: QuickCheck + , aeson , ansi-terminal + , async , base >=4.11 && <5 - , bytestring + , bytestring >=0.11 + , casing + , containers , directory , filepath , fsnotify ==0.4.* @@ -159,36 +263,16 @@ , http-client >=0.5.0 , http-types , mockery + , mtl , network , process - , silently , stm + , temporary , text , time + , transformers , unix , wai , warp - other-modules: - Client - EventQueue - HTTP - Imports - Language.Haskell.GhciWrapper - Options - ReadHandle - Run - Session - Trigger - Util - ClientSpec - EventQueueSpec - Helper - HTTPSpec - Language.Haskell.GhciWrapperSpec - OptionsSpec - ReadHandleSpec - SessionSpec - TriggerSpec - UtilSpec - Paths_sensei - default-language: Haskell2010 + , yaml + default-language: GHC2021 diff --git a/src/Client.hs b/src/Client.hs --- a/src/Client.hs +++ b/src/Client.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Client (client) where import Imports @@ -11,11 +10,11 @@ import HTTP (newSocket, socketAddr, socketName) -client :: IO (Bool, L.ByteString) -client = either (const $ connectError) id <$> tryJust p go +client :: FilePath -> IO (Bool, L.ByteString) +client dir = fromRight connectError <$> tryJust p go where connectError :: (Bool, L.ByteString) - connectError = (False, "could not connect to " <> fromString socketName <> "\n") + connectError = (False, "could not connect to " <> fromString (socketName dir) <> "\n") p :: HttpException -> Maybe () p e = case e of @@ -32,5 +31,5 @@ newConnection _ _ _ = do sock <- newSocket - connect sock socketAddr + connect sock $ socketAddr dir socketConnection sock 8192 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +module Config ( + Config(..) +, Hook +, HookResult(..) +, defaultConfig +, loadConfig +#ifdef TEST +, ConfigFile(..) +, readConfigFilesFrom +#endif +) where + +import Imports + +import GHC.Generics +import Data.ByteString qualified as ByteString +import System.Directory +import System.Process +import Text.Casing +import Data.Aeson +import Data.Yaml + +import Util + +configFilename :: FilePath +configFilename = "sensei.yaml" + +data ConfigFile = ConfigFile { + -- | Shell command to run after a file has changed, but before reloading. Cancels the current + -- trigger cycle when exiting with non-zero exit code. + beforeReload :: Maybe String + -- | Shell command to run after a successful reload, but before running the tests. Cancels the + -- current trigger cycle when exiting with non-zero exit code. +, afterReload :: Maybe String + -- | Shell command to run after the trigger cycle completed with failure. Has access to the result + -- via seito. +, onFailure :: Maybe String + -- | Shell command to run after the trigger cycle successfully completed. Has access to the result + -- via seito. +, onSuccess :: Maybe String +} deriving (Generic, Show, Eq) + +instance Semigroup ConfigFile where + a <> b = ConfigFile { + beforeReload = a.beforeReload <|> b.beforeReload + , afterReload = a.afterReload <|> b.afterReload + , onFailure = a.onFailure <|> b.onFailure + , onSuccess = a.onSuccess <|> b.onSuccess + } + +instance Monoid ConfigFile where + mempty = ConfigFile Nothing Nothing Nothing Nothing + +instance FromJSON ConfigFile where + parseJSON = \ case + Null -> return mempty + value -> genericParseJSON defaultOptions { + fieldLabelModifier = kebab + , rejectUnknownFields = True + } value + +type Hook = IO HookResult + +data HookResult = HookSuccess | HookFailure String + +data Config = Config { + senseiHooksBeforeReload :: Hook +, senseiHooksAfterReload :: Hook +, senseiHooksOnSuccess :: Hook +, senseiHooksOnFailure :: Hook +} + +tryReadFile :: FilePath -> IO (Maybe ByteString) +tryReadFile = fmap (either (const Nothing) Just) . tryJust (guard . isDoesNotExistError) . ByteString.readFile + +readConfigFile :: FilePath -> IO (Either String ConfigFile) +readConfigFile path = tryReadFile path >>= \ case + Just input -> return $ first displayException . decodeEither' $ input + Nothing -> return $ Right mempty + +readConfigFiles :: IO (Either String ConfigFile) +readConfigFiles = do + configDir <- getXdgDirectory XdgConfig "sensei" + readConfigFilesFrom (configDir configFilename) configFilename + +readConfigFilesFrom :: FilePath -> FilePath -> IO (Either String ConfigFile) +readConfigFilesFrom global local = fmap mconcat . sequence <$> sequence [ + readConfigFile local + , readConfigFile global + ] + +toConfig :: ConfigFile -> Config +toConfig ConfigFile{..} = Config { + senseiHooksBeforeReload = maybeToHook "before-reload" beforeReload +, senseiHooksAfterReload = maybeToHook "after-reload" afterReload +, senseiHooksOnSuccess = maybeToHook "on-success" onSuccess +, senseiHooksOnFailure = maybeToHook "on-failure" onFailure +} where + maybeToHook :: String -> Maybe String -> Hook + maybeToHook name = maybe (return HookSuccess) (toHook name) + + toHook :: String -> String -> Hook + toHook name command = system command >>= \ case + ExitSuccess -> return HookSuccess + ExitFailure code -> do + let message = withColor Red $ name <> ": " <> command <> " # failed with status " <> show code + return $ HookFailure message + +defaultConfig :: Config +defaultConfig = toConfig mempty + +loadConfig :: IO Config +loadConfig = readConfigFiles >>= either (throwIO . ErrorCall) (return . toConfig) diff --git a/src/EventQueue.hs b/src/EventQueue.hs --- a/src/EventQueue.hs +++ b/src/EventQueue.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} module EventQueue ( EventQueue @@ -21,6 +20,7 @@ ) where import Imports +import qualified Data.Set as Set import Control.Monad.STM import Control.Concurrent.STM.TChan @@ -29,14 +29,18 @@ type EventQueue = TChan Event -data Event = TriggerAll | FileEvent FileEventType FilePath | Done +data Event = + TriggerAll + | FileEvent FileEventType FilePath + | RestartWith [String] + | Done deriving (Eq, Show) data FileEventType = FileAdded | FileRemoved | FileModified deriving (Eq, Show) newQueue :: IO EventQueue -newQueue = atomically $ newTChan +newQueue = atomically newTChan emitEvent :: EventQueue -> Event -> IO () emitEvent chan = atomically . writeTChan chan @@ -45,12 +49,16 @@ readEvents chan = do e <- atomically $ readTChan chan unless (isKeyboardInput e) $ do - threadDelay 100000 + threadDelay 100_000 es <- atomically emptyQueue return (e : es) where isKeyboardInput :: Event -> Bool - isKeyboardInput event = event == Done || event == TriggerAll + isKeyboardInput = \ case + TriggerAll -> True + FileEvent {} -> False + RestartWith {} -> True + Done -> True emptyQueue :: STM [Event] emptyQueue = do @@ -59,54 +67,83 @@ Nothing -> return [] Just e -> (e :) <$> emptyQueue -data Status = Terminate | Reload +data Status = Terminate | Restart (Maybe [String]) + deriving (Eq, Show) -processQueue :: EventQueue -> IO () -> IO () -> IO Status -processQueue chan triggerAll trigger = go +processQueue :: IO () -> (String -> IO ()) -> FilePath -> EventQueue -> IO () -> IO () -> IO Status +processQueue cleanup echo dir chan triggerAll trigger = go where - go = readEvents chan >>= processEvents >>= \ case - NoneAction -> do - go - TriggerAction files -> do - output files - trigger - go - TriggerAllAction -> do - triggerAll - go - ReloadAction file t -> do - output [file <> " (" <> show t <> ", reloading)"] - return Reload - DoneAction -> do - return Terminate + go :: IO Status + go = do + action <- readEvents chan >>= processEvents echo dir + runCleanup action + case action of + NoneAction -> do + go + TriggerAction files -> do + output files + trigger + go + TriggerAllAction -> do + triggerAll + go + RestartAction file t -> do + output [file <> " (" <> show t <> ", restarting)"] + return $ Restart Nothing + RestartWithAction args -> do + return $ Restart (Just args) + DoneAction -> do + return Terminate + runCleanup :: Action -> IO () + runCleanup = \ case + NoneAction -> pass + TriggerAction {} -> cleanup + TriggerAllAction -> cleanup + RestartAction {} -> cleanup + RestartWithAction {} -> cleanup + DoneAction -> cleanup + output :: [String] -> IO () - output = withInfoColor . mapM_ (putStrLn . mappend "--> ") + output = mapM_ (\ name -> echo . withInfoColor $ "--> " <> name <> "\n") -data Action = NoneAction | TriggerAction [FilePath] | TriggerAllAction | ReloadAction FilePath FileEventType | DoneAction +data Action = + NoneAction + | TriggerAction [FilePath] + | TriggerAllAction + | RestartAction FilePath FileEventType + | RestartWithAction [String] + | DoneAction deriving (Eq, Show) -processEvents :: [Event] -> IO Action -processEvents events = do - files <- fileEvents events +processEvents :: (String -> IO ()) -> FilePath -> [Event] -> IO Action +processEvents echo dir events = do + files <- fileEvents echo dir events return $ if | Done `elem` events -> DoneAction - | (file, t) : _ <- filter shouldReload files -> ReloadAction file t + | args : _ <- [args | RestartWith args <- reverse events] -> RestartWithAction args + | (file, t) : _ <- filter shouldRestart files -> RestartAction file t | TriggerAll `elem` events -> TriggerAllAction - | not (null files) -> TriggerAction $ nub . sort $ map fst files + | not (null files) -> TriggerAction . Set.toList . Set.fromList $ map fst files | otherwise -> NoneAction -shouldReload :: (FilePath, FileEventType) -> Bool -shouldReload (name, event) = "Spec.hs" `isSuffixOf` name && case event of - FileAdded -> True - FileRemoved -> True - FileModified -> False +shouldRestart :: (FilePath, FileEventType) -> Bool +shouldRestart = (||) <$> specAddedOrRemoved <*> dotGhciModified + where + specAddedOrRemoved :: (FilePath, FileEventType) -> Bool + specAddedOrRemoved (name, event) = "Spec.hs" `isSuffixOf` name && case event of + FileAdded -> True + FileRemoved -> True + FileModified -> False -fileEvents :: [Event] -> IO [(FilePath, FileEventType)] -fileEvents events = filterGitIgnored $ combineFileEvents [(p, e) | FileEvent e p <- events] + dotGhciModified :: (FilePath, FileEventType) -> Bool + dotGhciModified (name, _) = takeFileName name == ".ghci" -filterGitIgnored :: [(FilePath, FileEventType)] -> IO [(FilePath, FileEventType)] -filterGitIgnored events = map f <$> filterGitIgnoredFiles (map fst events) +fileEvents :: (String -> IO ()) -> FilePath -> [Event] -> IO [(FilePath, FileEventType)] +fileEvents echo dir events = filterGitIgnored echo dir $ combineFileEvents [(p, e) | FileEvent e p <- events] + +filterGitIgnored :: (String -> IO ()) -> FilePath -> [(FilePath, FileEventType)] -> IO [(FilePath, FileEventType)] +filterGitIgnored echo dir events = map f <$> filterGitIgnoredFiles echo dir (map fst events) where f :: FilePath -> (FilePath, FileEventType) f p = (p, fromJust $ lookup p events) diff --git a/src/HTTP.hs b/src/HTTP.hs --- a/src/HTTP.hs +++ b/src/HTTP.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} module HTTP ( withServer , socketName @@ -14,36 +13,39 @@ import Imports import System.Directory +import Data.Text.Lazy.Encoding (encodeUtf8) import Network.Wai import Network.HTTP.Types import Network.Wai.Handler.Warp (runSettingsSocket, defaultSettings) import Network.Socket -socketName :: String -socketName = ".sensei.sock" +import qualified Trigger -socketAddr :: SockAddr -socketAddr = SockAddrUnix socketName +socketName :: FilePath -> String +socketName dir = dir ".sensei.sock" +socketAddr :: FilePath -> SockAddr +socketAddr = SockAddrUnix . socketName + newSocket :: IO Socket newSocket = socket AF_UNIX Stream 0 withSocket :: (Socket -> IO a) -> IO a -withSocket action = bracket newSocket close action +withSocket = bracket newSocket close -withServer :: IO (Bool, String) -> IO a -> IO a -withServer trigger = withApplication (app trigger) +withServer :: FilePath -> IO (Trigger.Result, String) -> IO a -> IO a +withServer dir trigger = withApplication dir (app trigger) -withApplication :: Application -> IO a -> IO a -withApplication application action = do - removeSocketFile - withSocket $ \sock -> do - bracket_ (bind sock socketAddr) removeSocketFile $ do +withApplication :: FilePath -> Application -> IO a -> IO a +withApplication dir application action = do + removeSocketFile dir + withSocket $ \ sock -> do + bracket_ (bind sock $ socketAddr dir) (removeSocketFile dir) $ do listen sock maxListenQueue withThread (runSettingsSocket defaultSettings sock application) action -removeSocketFile :: IO () -removeSocketFile = void $ tryJust (guard . isDoesNotExistError) (removeFile socketName) +removeSocketFile :: FilePath -> IO () +removeSocketFile dir = void $ tryJust (guard . isDoesNotExistError) (removeFile $ socketName dir) withThread :: IO () -> IO a -> IO a withThread asyncAction action = do @@ -55,11 +57,12 @@ takeMVar mvar return r -app :: IO (Bool, String) -> Application +app :: IO (Trigger.Result, String) -> Application app trigger _ respond = trigger >>= textPlain where - textPlain (success, xs) = respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ xs) + textPlain (result, xs) = respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ xs) where - status - | success = ok200 - | otherwise = internalServerError500 + status = case result of + Trigger.HookFailed -> internalServerError500 + Trigger.Failure -> internalServerError500 + Trigger.Success -> ok200 diff --git a/src/Imports.hs b/src/Imports.hs --- a/src/Imports.hs +++ b/src/Imports.hs @@ -1,21 +1,31 @@ +{-# LANGUAGE CPP #-} module Imports (module Imports) where import Control.Arrow as Imports ((>>>), (&&&)) import Control.Concurrent as Imports -import Control.Exception as Imports +import Control.Exception as Imports hiding (handle) import Control.Monad as Imports -import Data.Functor as Imports +import Data.Function as Imports (fix) +import Control.Applicative as Imports +import Data.Functor as Imports ((<&>)) import Data.Bifunctor as Imports import Data.Char as Imports +import Data.Either as Imports import Data.List as Imports import Data.Maybe as Imports import Data.String as Imports import Data.ByteString.Char8 as Imports (ByteString, pack, unpack) -import Data.Text.Lazy.Encoding as Imports (encodeUtf8) import Data.Tuple as Imports +import System.FilePath as Imports hiding (combine) import System.IO.Error as Imports (isDoesNotExistError) import Text.Read as Imports (readMaybe) +import System.Exit as Imports (ExitCode(..)) +import System.Process as Process +import Control.Monad.IO.Class as Imports +import System.IO (Handle) +import GHC.IO.Handle.Internals (wantReadableHandle_) + pass :: Applicative m => m () pass = pure () @@ -27,3 +37,12 @@ when notDone $ do action go + +withLockedHandle :: Handle -> IO a -> IO a +withLockedHandle h = wantReadableHandle_ "pager" h . const + +createPipe :: IO (Handle, Handle) +#if defined(__IO_MANAGER_WINIO__) +#error Use `associateHandle'` as per https://hackage.haskell.org/package/process-1.6.17.0/docs/System-Process.html#v:createPipe +#endif +createPipe = Process.createPipe diff --git a/src/Input.hs b/src/Input.hs new file mode 100644 --- /dev/null +++ b/src/Input.hs @@ -0,0 +1,39 @@ +module Input (watch) where + +import Imports + +import System.IO +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 + +watch :: Handle -> (Char -> IO ()) -> IO () -> IO () +watch handle dispatch onEof = void . forkIO $ do + forEachInputChar handle dispatch `finally` onEof + +forEachInputChar :: Handle -> (Char -> IO ()) -> IO () +forEachInputChar handle action = do + hSetBuffering handle NoBuffering + hSetEcho handle False + go + where + chunkSize :: Int + chunkSize = 64 + + inputDelay :: Int + inputDelay = 100_000 + + go :: IO () + go = ByteString.hGetNonBlocking handle chunkSize >>= \ case + "" -> threadDelay inputDelay >> go + cs -> consume (Char8.unpack cs) + + consume :: [Char] -> IO () + consume = \ case + c : _ | eof c -> pass + c : cs -> do + when (isAscii c) (action c) + consume cs + [] -> go + + eof :: Char -> Bool + eof = (== '\EOT') diff --git a/src/Language/Haskell/GhciWrapper.hs b/src/Language/Haskell/GhciWrapper.hs --- a/src/Language/Haskell/GhciWrapper.hs +++ b/src/Language/Haskell/GhciWrapper.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} module Language.Haskell.GhciWrapper ( Config(..) -, Interpreter +, Interpreter(echo) , withInterpreter , eval , evalVerbose @@ -10,98 +9,127 @@ import Imports -import qualified Data.ByteString as B +import qualified Data.ByteString as ByteString import Data.Text.Encoding (decodeUtf8) import qualified Data.Text as T import System.IO hiding (stdin, stdout, stderr) -import qualified System.IO as System -import System.Directory (doesFileExist) -import System.Process -import System.Exit (ExitCode(..)) +import System.Directory (doesFileExist, makeAbsolute) +import System.Environment (getEnvironment) +import System.Process hiding (createPipe) +import System.Exit (exitFailure) +import Util (isWritableByOthers) import qualified ReadHandle import ReadHandle (ReadHandle, toReadHandle) data Config = Config { configIgnoreDotGhci :: Bool -, configVerbose :: Bool , configStartupFile :: FilePath -} deriving (Eq, Show) +, configWorkingDirectory :: Maybe FilePath +, configEcho :: ByteString -> IO () +} data Interpreter = Interpreter { hIn :: Handle , hOut :: Handle , readHandle :: ReadHandle , process :: ProcessHandle +, echo :: ByteString -> IO () } die :: String -> IO a die = throwIO . ErrorCall withInterpreter :: Config -> [String] -> (Interpreter -> IO r) -> IO r -withInterpreter config args = bracket (new config args) (close $ verbosity config) +withInterpreter config args = bracket (new config args) close -new :: Config -> [String] -> IO Interpreter -new config@Config{..} args_ = do +sanitizeEnv :: [(String, String)] -> [(String, String)] +sanitizeEnv = filter p + where + p ("HSPEC_FAILURES", _) = False + p _ = True +new :: Config -> [String] -> IO Interpreter +new Config{..} args_ = do + checkDotGhci requireFile configStartupFile + startupFile <- makeAbsolute configStartupFile + env <- sanitizeEnv <$> getEnvironment + let + args = "-ghci-script" : startupFile : args_ ++ catMaybes [ + if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing + ] - (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess (proc "ghci" args) { - std_in = CreatePipe - , std_out = CreatePipe - , std_err = Inherit + (stdoutReadEnd, stdoutWriteEnd) <- createPipe + + (Just stdin_, Nothing, Nothing, processHandle ) <- createProcess (proc "ghci" args) { + cwd = configWorkingDirectory + , env = Just env + , std_in = CreatePipe + , std_out = UseHandle stdoutWriteEnd + , std_err = UseHandle stdoutWriteEnd } setMode stdin_ - readHandle <- toReadHandle stdout_ 1024 + readHandle <- toReadHandle stdoutReadEnd 1024 let interpreter = Interpreter { hIn = stdin_ , readHandle - , hOut = stdout_ + , hOut = stdoutReadEnd , process = processHandle + , echo = configEcho } - _ <- printStartupMessages interpreter - evalThrow interpreter "GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr" - - -- GHCi uses NoBuffering for stdout and stderr by default: - -- https://downloads.haskell.org/ghc/9.4.4/docs/users_guide/ghci.html - evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering" - evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering" + _ <- printStartupMessages interpreter + getProcessExitCode processHandle >>= \ case + Just _ -> exitFailure + Nothing -> do + -- GHCi uses NoBuffering for stdout and stderr by default: + -- https://downloads.haskell.org/ghc/9.4.4/docs/users_guide/ghci.html + evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering" + evalThrow interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering" - evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8" - evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8" + evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8" + evalThrow interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8" - return interpreter + return interpreter where + checkDotGhci = unless configIgnoreDotGhci $ do + let dotGhci = fromMaybe "" configWorkingDirectory ".ghci" + isWritableByOthers dotGhci >>= \ case + False -> pass + True -> die $ unlines [ + dotGhci <> " is writable by others, you can fix this with:" + , "" + , " chmod go-w " <> dotGhci <> " ." + , "" + ] + requireFile name = do exists <- doesFileExist name unless exists $ do die $ "Required file " <> show name <> " does not exist!" - args = "-ghci-script" : configStartupFile : args_ ++ catMaybes [ - if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing - ] - setMode h = do hSetBinaryMode h False hSetBuffering h LineBuffering hSetEncoding h utf8 - printStartupMessages interpreter = evalWith (verbosity config) interpreter "" + printStartupMessages :: Interpreter -> IO String + printStartupMessages interpreter = evalVerbose interpreter "" evalThrow :: Interpreter -> String -> IO () evalThrow interpreter expr = do output <- eval interpreter expr unless (null output) $ do - close (verbosity config) interpreter + close interpreter die output -close :: (ByteString -> IO ()) -> Interpreter -> IO () -close echo Interpreter{..} = do +close :: Interpreter -> IO () +close Interpreter{..} = do hClose hIn ReadHandle.drain readHandle echo hClose hOut @@ -112,30 +140,17 @@ putExpression :: Interpreter -> String -> IO () putExpression Interpreter{hIn = stdin} e = do hPutStrLn stdin e - B.hPut stdin ReadHandle.marker + ByteString.hPut stdin ReadHandle.marker hFlush stdin -getResult :: Interpreter -> (ByteString -> IO ()) -> IO String -getResult Interpreter{readHandle = h} = fmap (T.unpack . decodeUtf8) . ReadHandle.getResult h - -verbosity :: Config -> ByteString -> IO () -verbosity config - | configVerbose config = verbose - | otherwise = silent - -verbose :: ByteString -> IO () -verbose string = B.putStr string >> hFlush System.stdout +getResult :: Interpreter -> IO String +getResult Interpreter{..} = T.unpack . decodeUtf8 <$> ReadHandle.getResult readHandle echo silent :: ByteString -> IO () silent _ = pass -evalWith :: (ByteString -> IO ()) -> Interpreter -> String -> IO String -evalWith echo repl expr = do - putExpression repl expr - getResult repl echo - eval :: Interpreter -> String -> IO String -eval = evalWith silent +eval ghci = evalVerbose ghci {echo = silent} evalVerbose :: Interpreter -> String -> IO String -evalVerbose = evalWith verbose +evalVerbose ghci expr = putExpression ghci expr >> getResult ghci diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -11,30 +11,63 @@ x : _ -> (dropEnd (length x) args, x) [] -> (args, []) where + isHspecArgs :: [String] -> Bool isHspecArgs xs = case getOpt Permute options xs of - (_, [], []) -> True + (result, [], []) -> all (== Valid) result _ -> False dropEnd :: Int -> [a] -> [a] dropEnd n = reverse . drop n . reverse -options :: [OptDescr ()] -options = map ($ "") [ - Option [] ["help"] (NoArg ()) - , Option "m" ["match"] (ReqArg (const ()) "PATTERN") - , Option [] ["skip"] (ReqArg (const ()) "PATTERN") - , Option [] ["color"] (NoArg ()) - , Option [] ["no-color"] (NoArg ()) - , Option "f" ["format"] (ReqArg (const ()) "FORMATTER") - , Option "o" ["out"] (ReqArg (const ()) "FILE") - , Option [] ["depth"] (ReqArg (const ()) "N") - , Option "a" ["qc-max-success"] (ReqArg (const ()) "N") - , Option [] ["qc-max-size"] (ReqArg (const ()) "N") - , Option [] ["qc-max-discard"] (ReqArg (const ()) "N") - , Option [] ["seed"] (ReqArg (const ()) "N") - , Option [] ["print-cpu-time"] (NoArg ()) - , Option [] ["focused-only"] (NoArg ()) - , Option [] ["dry-run"] (NoArg ()) - , Option [] ["fail-fast"] (NoArg ()) - , Option "r" ["rerun"] (NoArg ()) +data Valid = Valid | Invalid + deriving (Eq, Show) + +options :: [OptDescr Valid] +options = concat [ + flag "color" + , flag "diff" + , flag "dry-run" + , flag "expert" + , flag "fail-fast" + , flag "fail-on=ITEMS" + , flag "focused-only" + , flag "pretty" + , flag "randomize" + , flag "strict" + , flag "times" + , flag "unicode" + , noArg "" "help" + , noArg "" "ignore-dot-hspec" + , noArg "" "print-cpu-time" + , noArg "" "rerun-all-on-success" + , noArg "r" "rerun" + , reqArg "" "depth" "N" + , reqArg "" "diff-command" "CMD" + , reqArg "" "diff-context" "N" + , reqArg "" "failure-report" "FILE" + , reqArg "" "jobs" "N" + , reqArg "" "qc-max-discard" "N" + , reqArg "" "qc-max-shrinks" "N" + , reqArg "" "qc-max-size" "N" + , reqArg "" "seed" "N" + , reqArg "" "skip" "PATTERN" + , reqArg "a" "qc-max-success" "N" + , reqArg "f" "format" "NAME" + , reqArg "m" "match" "PATTERN" + , [Option "p" ["print-slow-items"] (OptArg (maybe Valid intArg) "N") ""] ] + where + flag :: String -> [OptDescr Valid] + flag name = concat [ + noArg "" name + , noArg "" ("no-" <> name) + ] + + noArg :: [Char] -> String -> [OptDescr Valid] + noArg short name = [Option short [name] (NoArg Valid) ""] + + reqArg :: [Char] -> String -> String -> [OptDescr Valid] + reqArg short name arg = [Option short [name] (ReqArg (const Valid) arg) ""] + + intArg :: String -> Valid + intArg = maybe Invalid (const Valid) . readMaybe @Int diff --git a/src/Pager.hs b/src/Pager.hs new file mode 100644 --- /dev/null +++ b/src/Pager.hs @@ -0,0 +1,28 @@ +module Pager where + +import Imports + +import System.IO +import System.IO.Error +import System.Process +import Control.Concurrent.Async + +pager :: String -> IO (IO ()) +pager = pagerWith less + where + less = proc "less" $ "--RAW" : "--QUIT-AT-EOF" : matchOptions + +matchOptions :: [String] +matchOptions = ["--incsearch", "--pattern", "^.*\\w:\\d+:\\d+:.+$|"] + +pagerWith :: CreateProcess -> String -> IO (IO ()) +pagerWith process input = do + pid <- newEmptyMVar + tid <- async $ withLockedHandle stdin $ do + (Just hin, Nothing, Nothing, p) <- createProcess process { delegate_ctlc = True, std_in = CreatePipe } + putMVar pid p + _ <- tryJust (guard . isResourceVanishedError) $ hPutStr hin input >> hClose hin + waitForProcess p + return $ do + readMVar pid >>= terminateProcess + void $ wait tid diff --git a/src/ReadHandle.hs b/src/ReadHandle.hs --- a/src/ReadHandle.hs +++ b/src/ReadHandle.hs @@ -1,9 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} module ReadHandle ( ReadHandle(..) , toReadHandle @@ -17,20 +12,11 @@ import Imports -import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Char8 as ByteString import Data.IORef import System.IO hiding (stdin, stdout, stderr, isEOF) -#if MIN_VERSION_bytestring(0,11,0) import Data.ByteString (dropEnd) -#else -import qualified Data.ByteString.Internal as B -dropEnd :: Int -> ByteString -> ByteString -dropEnd n ps@(B.PS x offset len) - | n <= 0 = ps - | n >= len = B.empty - | otherwise = B.PS x offset (len - n) -#endif -- | Truly random marker, used to separate expressions. -- @@ -41,7 +27,7 @@ marker = pack (show @String "be77d2c8427d29cd1d62b7612d8e98cc") <> "\n" partialMarkers :: [ByteString] -partialMarkers = reverse . drop 1 . init $ B.inits marker +partialMarkers = reverse . drop 1 . init $ ByteString.inits marker data ReadHandle = ReadHandle { getChunk :: IO ByteString @@ -70,7 +56,7 @@ mkBufferChunk :: ByteString -> Buffer mkBufferChunk chunk - | B.null chunk = BufferEmpty + | ByteString.null chunk = BufferEmpty | otherwise = BufferChunk chunk data Buffer = @@ -82,7 +68,7 @@ toReadHandle :: Handle -> Int -> IO ReadHandle toReadHandle h n = do hSetBinaryMode h True - ReadHandle (B.hGetSome h n) <$> newEmptyBuffer + ReadHandle (ByteString.hGetSome h n) <$> newEmptyBuffer newEmptyBuffer :: IO (IORef Buffer) newEmptyBuffer = newIORef BufferEmpty @@ -113,7 +99,7 @@ getSome :: IO (Maybe ByteString) getSome = do chunk <- getChunk - if B.null chunk then do + if ByteString.null chunk then do putBuffer BufferEOF return Nothing else do @@ -141,7 +127,7 @@ NoMarker -> case splitPartialMarker chunk of Just (prefix, partialMarker) -> do putBuffer (BufferPartialMarker partialMarker) - if B.null prefix then do + if ByteString.null prefix then do go else do return (Chunk prefix) @@ -150,10 +136,10 @@ splitPartialMarker :: ByteString -> Maybe (ByteString, ByteString) splitPartialMarker chunk = split <$> findPartialMarker chunk where - split partialMarker = (dropEnd (B.length partialMarker) chunk, partialMarker) + split partialMarker = (dropEnd (ByteString.length partialMarker) chunk, partialMarker) findPartialMarker :: ByteString -> Maybe ByteString -findPartialMarker chunk = find (`B.isSuffixOf` chunk) partialMarkers +findPartialMarker chunk = find (`ByteString.isSuffixOf` chunk) partialMarkers data StripMarker = NoMarker @@ -166,5 +152,5 @@ ("", dropMarker -> ys) -> StrippedMarker ys (xs, ys) -> PrefixBeforeMarker xs ys where - brakeAtMarker = B.breakSubstring marker - dropMarker = B.drop (B.length marker) + brakeAtMarker = ByteString.breakSubstring marker + dropMarker = ByteString.drop (ByteString.length marker) diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -1,98 +1,167 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} module Run ( run , runWeb +#ifdef TEST +, RunArgs(..) +, runWith +, defaultRunArgs +, watchFiles +#endif ) where import Imports -import System.Exit -import System.FSNotify +import qualified Data.ByteString as ByteString +import Data.IORef +import System.IO +import qualified System.FSNotify as FSNotify import qualified HTTP import qualified Session -import Session (Session, Config(..)) import EventQueue import Trigger +import qualified Input +import Pager (pager) import Util +import Config waitForever :: IO () waitForever = forever $ threadDelay 10000000 -watchFiles :: EventQueue -> IO () -watchFiles queue = do - watch $ \ case - Added file _ _ -> emit $ FileEvent FileAdded file - Modified file _ _ -> emit $ FileEvent FileModified file - ModifiedAttributes _file _ _ -> pass - Removed file _ _ -> emit $ FileEvent FileRemoved file - WatchedDirectoryRemoved _file _ _ -> pass - CloseWrite file _ _ -> emit $ FileEvent FileModified file - Unknown file _ _ _ -> emit $ FileEvent FileModified file +watchFiles :: FilePath -> EventQueue -> IO () -> IO () +watchFiles dir queue action = do + FSNotify.withManager $ \ manager -> do + bracket (FSNotify.watchTree manager dir isInteresting dispatch) (\ stopListening -> stopListening) $ \ _ -> do + action where + dispatch :: FSNotify.Event -> IO () + dispatch = \ case + FSNotify.Added file _ _ -> emit $ FileEvent FileAdded file + FSNotify.Modified file _ _ -> emit $ FileEvent FileModified file + FSNotify.ModifiedAttributes file _ _ -> emit $ FileEvent FileModified file + FSNotify.Removed file _ _ -> emit $ FileEvent FileRemoved file + FSNotify.WatchedDirectoryRemoved _file _ _ -> pass + FSNotify.CloseWrite file _ _ -> emit $ FileEvent FileModified file + FSNotify.Unknown file _ _ _ -> emit $ FileEvent FileModified file + + emit :: EventQueue.Event -> IO () emit = emitEvent queue - watch action = void . forkIO $ do - withManager $ \ manager -> do - _stopListening <- watchTree manager "." isInteresting action - waitForever - where - isInteresting = (&&) <$> isFile <*> not . isBoring . eventPath - isFile = eventIsDirectory >>> (== IsFile) + isInteresting :: FSNotify.Event -> Bool + isInteresting = (&&) <$> isFile <*> not . isBoring . FSNotify.eventPath -watchInput :: EventQueue -> IO () -watchInput queue = void . forkIO $ do - input <- getContents - forM_ (lines input) $ \_ -> do - emitEvent queue TriggerAll - emitEvent queue Done + isFile :: FSNotify.Event -> Bool + isFile = FSNotify.eventIsDirectory >>> (== FSNotify.IsFile) +data Mode = Lenient | Strict + run :: FilePath -> [String] -> IO () run startupFile args = do + runArgs@RunArgs{dir, lastOutput, queue} <- defaultRunArgs startupFile + HTTP.withServer dir (readMVar lastOutput) $ do + watchFiles dir queue $ do + mode <- newIORef Lenient + Input.watch stdin (dispatch mode queue) (emitEvent queue Done) + runWith runArgs {args} + where + dispatch :: IORef Mode -> EventQueue -> Char -> IO () + dispatch mode queue = \ case + '\n' -> emitEvent queue TriggerAll + 'w' -> do + modifyIORef mode toggle + readIORef mode >>= \ case + Lenient -> emitEvent queue (RestartWith ["-Wdefault"]) + Strict -> emitEvent queue (RestartWith ["-Wall"]) + 'q' -> emitEvent queue Done + _ -> pass + + toggle :: Mode -> Mode + toggle = \ case + Lenient -> Strict + Strict -> Lenient + +defaultRunArgs :: FilePath -> IO RunArgs +defaultRunArgs startupFile = do queue <- newQueue - watchFiles queue - watchInput queue - lastOutput <- newMVar (True, "") - HTTP.withServer (readMVar lastOutput) $ do - let - saveOutput :: IO (Bool, String) -> IO () - saveOutput action = modifyMVar_ lastOutput $ \_ -> action + lastOutput <- newMVar (Trigger.Success, "") + return RunArgs { + ignoreConfig = False + , dir = "" + , args = [] + , lastOutput = lastOutput + , queue = queue + , sessionConfig = defaultSessionConfig startupFile + , withSession = Session.withSession + } - go = do - status <- withSession startupFile args $ \ session -> do - let - triggerAction = saveOutput (trigger session) - triggerAllAction = saveOutput (triggerAll session) - triggerAction - processQueue queue triggerAllAction triggerAction - case status of - Reload -> go - Terminate -> return () - go +data RunArgs = RunArgs { + ignoreConfig :: Bool +, dir :: FilePath +, args :: [String] +, lastOutput :: MVar (Result, String) +, queue :: EventQueue +, sessionConfig :: Session.Config +, withSession :: forall r. Session.Config -> [String] -> (Session.Session -> IO r) -> IO r +} +runWith :: RunArgs -> IO () +runWith RunArgs {..} = do + config <- case ignoreConfig of + False -> loadConfig + True -> return defaultConfig + cleanup <- newIORef pass + let + runCleanupAction :: IO () + runCleanupAction = join $ atomicModifyIORef' cleanup $ (,) pass + + addCleanupAction :: IO () -> IO () + addCleanupAction cleanupAction = atomicModifyIORef' cleanup $ \ action -> (action >> cleanupAction, ()) + + saveOutput :: IO (Trigger.Result, String) -> IO () + saveOutput action = do + runCleanupAction + result <- modifyMVar lastOutput $ \ _ -> (id &&& id) <$> action + case result of + (HookFailed, _output) -> pass + (Failure, output) -> config.senseiHooksOnFailure >>= \ case + HookSuccess -> pager output >>= addCleanupAction + HookFailure message -> hPutStrLn stderr message + (Success, _output) -> config.senseiHooksOnSuccess >>= \ case + HookSuccess -> pass + HookFailure message -> hPutStrLn stderr message + + hooks :: Hooks + hooks = Hooks { + beforeReload = config.senseiHooksBeforeReload + , afterReload = config.senseiHooksAfterReload + } + + go extraArgs = do + status <- withSession sessionConfig (extraArgs <> args) $ \ session -> do + let + triggerAction = saveOutput (trigger session hooks) + triggerAllAction = saveOutput (triggerAll session hooks) + triggerAction + processQueue runCleanupAction (sessionConfig.configEcho . encodeUtf8) dir queue triggerAllAction triggerAction + case status of + Restart mExtraArgs -> go (fromMaybe extraArgs mExtraArgs) + Terminate -> return () + go [] + runWeb :: FilePath -> [String] -> IO () runWeb startupFile args = do - withSession startupFile args $ \session -> do - _ <- trigger session + Session.withSession (defaultSessionConfig startupFile) args $ \session -> do + _ <- trigger session defaultHooks lock <- newMVar () - HTTP.withServer (withMVar lock $ \() -> trigger session) $ do + HTTP.withServer "" (withMVar lock $ \() -> trigger session defaultHooks) $ do waitForever -withSession :: FilePath -> [String] -> (Session -> IO a) -> IO a -withSession startupFile args action = do - check <- dotGhciWritableByOthers - when check $ do - putStrLn ".ghci is writable by others, you can fix this with:" - putStrLn "" - putStrLn " chmod go-w .ghci ." - putStrLn "" - exitFailure - Session.withSession config args action - where - config :: Config - config = Config { - configIgnoreDotGhci = False - , configVerbose = True - , configStartupFile = startupFile - } +defaultSessionConfig :: FilePath -> Session.Config +defaultSessionConfig startupFile = Session.Config { + configIgnoreDotGhci = False +, configStartupFile = startupFile +, configWorkingDirectory = Nothing +, configEcho = \ string -> ByteString.putStr string >> hFlush stdout +} diff --git a/src/Session.hs b/src/Session.hs --- a/src/Session.hs +++ b/src/Session.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} module Session ( Config(..) , Session(..) +, echo , withSession , reload @@ -16,7 +16,6 @@ #ifdef TEST , runSpec , hasSpec -, hspecFailureEnvName , hasHspecCommandSignature , hspecCommand , parseSummary @@ -32,32 +31,31 @@ import Util import Options -hspecFailureEnvName :: String -hspecFailureEnvName = "HSPEC_FAILURES" - data Session = Session { - sessionInterpreter :: Interpreter -, sessionHspecArgs :: [String] -, sessionHspecPreviousSummary :: IORef (Maybe Summary) + interpreter :: Interpreter +, hspecArgs :: [String] +, hspecPreviousSummaryRef :: IORef (Maybe Summary) } +echo :: Session -> String -> IO () +echo session = session.interpreter.echo . encodeUtf8 + resetSummary :: Session -> IO () -resetSummary Session{..} = writeIORef sessionHspecPreviousSummary (Just $ Summary 0 0) +resetSummary session = writeIORef session.hspecPreviousSummaryRef (Just $ Summary 0 0) -hspecPreviousSummary :: Session -> IO (Maybe Summary) -hspecPreviousSummary Session{..} = readIORef sessionHspecPreviousSummary +hspecPreviousSummary :: MonadIO m => Session -> m (Maybe Summary) +hspecPreviousSummary session = liftIO $ readIORef session.hspecPreviousSummaryRef withSession :: Config -> [String] -> (Session -> IO r) -> IO r withSession config args action = do withInterpreter config ghciArgs $ \ ghci -> do - _ <- eval ghci ("System.Environment.unsetEnv " ++ show hspecFailureEnvName) ref <- newIORef (Just $ Summary 0 0) action (Session ghci hspecArgs ref) where (ghciArgs, hspecArgs) = splitArgs args -reload :: Session -> IO String -reload Session{..} = evalVerbose sessionInterpreter ":reload" +reload :: MonadIO m => Session -> m String +reload session = liftIO $ evalVerbose session.interpreter ":reload" data Summary = Summary { summaryExamples :: Int @@ -67,15 +65,21 @@ hspecCommand :: String hspecCommand = "Test.Hspec.Runner.hspecResult spec" +hspecCoreCommand :: String +hspecCoreCommand = "Test.Hspec.Core.Runner.hspecResult spec" + hspecMetaCommand :: String hspecMetaCommand = "Test.Hspec.Meta.hspecResult spec" getRunSpec :: Session -> IO (Maybe (IO String)) -getRunSpec session = do - r <- getRunSpecWith hspecCommand session - case r of - Just _ -> return r - Nothing -> getRunSpecWith hspecMetaCommand session +getRunSpec session = go [hspecCommand, hspecCoreCommand, hspecMetaCommand] + where + go = \ case + [] -> return Nothing + command : commands -> do + getRunSpecWith command session >>= \ case + r@Just{} -> return r + Nothing -> go commands getRunSpecWith :: String -> Session -> IO (Maybe (IO String)) getRunSpecWith command session = do @@ -85,7 +89,7 @@ else return Nothing hasSpec :: String -> Session -> IO Bool -hasSpec command Session{..} = hasHspecCommandSignature command <$> eval sessionInterpreter (":type " ++ command) +hasSpec command session = hasHspecCommandSignature command <$> eval session.interpreter (":type " ++ command) hasHspecCommandSignature :: String -> String -> Bool hasHspecCommandSignature command = any match . lines . normalizeTypeSignatures @@ -93,18 +97,18 @@ match line = (command ++ " :: IO ") `isPrefixOf` line && "Summary" `isSuffixOf` line runSpec :: String -> Session -> IO String -runSpec command session@Session{..} = do +runSpec command session = do failedPreviously <- isFailure <$> hspecPreviousSummary session - let args = "--color" : (if failedPreviously then addRerun else id) sessionHspecArgs - r <- evalVerbose sessionInterpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command - writeIORef sessionHspecPreviousSummary (parseSummary r) + let args = "--color" : (if failedPreviously then addRerun else id) session.hspecArgs + r <- evalVerbose session.interpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ command + writeIORef session.hspecPreviousSummaryRef (parseSummary r) return r where addRerun :: [String] -> [String] addRerun args = "--rerun" : args isFailure :: Maybe Summary -> Bool -isFailure = maybe True ((/= 0) . summaryFailures) +isFailure = maybe True ((/= 0) . (.summaryFailures)) isSuccess :: Maybe Summary -> Bool isSuccess = not . isFailure diff --git a/src/Trigger.hs b/src/Trigger.hs --- a/src/Trigger.hs +++ b/src/Trigger.hs @@ -1,23 +1,52 @@ {-# LANGUAGE CPP #-} module Trigger ( - trigger + Hook +, HookResult(..) +, Hooks(..) +, defaultHooks +, Result(..) +, trigger , triggerAll #ifdef TEST , reloadedSuccessfully +, removeProgress #endif ) where import Imports +#if MIN_VERSION_mtl(2,3,1) +import Control.Monad.Trans.Writer.CPS (runWriterT) +import Control.Monad.Writer.CPS hiding (pass) +#else +import Control.Monad.Writer.Strict hiding (pass) +#endif +import Control.Monad.Except + import Util +import Config (Hook, HookResult(..)) import Session (Session, isFailure, isSuccess, hspecPreviousSummary, resetSummary) import qualified Session -triggerAll :: Session -> IO (Bool, String) -triggerAll session = do +data Hooks = Hooks { + beforeReload :: Hook +, afterReload :: Hook +} + +defaultHooks :: Hooks +defaultHooks = Hooks { + beforeReload = return HookSuccess +, afterReload = return HookSuccess +} + +data Result = HookFailed | Failure | Success + deriving (Eq, Show) + +triggerAll :: Session -> Hooks -> IO (Result, String) +triggerAll session hooks = do resetSummary session - trigger session + trigger session hooks reloadedSuccessfully :: String -> Bool reloadedSuccessfully = any success . lines @@ -30,34 +59,62 @@ Just xs -> "modules loaded: " `isPrefixOf` xs Nothing -> False -trigger :: Session -> IO (Bool, String) -trigger session = do - xs <- Session.reload session - fmap (xs ++) <$> if reloadedSuccessfully xs - then do - withColor Green $ putStrLn "RELOADING SUCCEEDED" - hspec - else do - withColor Red $ putStrLn "RELOADING FAILED" - return (False, "") +removeProgress :: String -> String +removeProgress xs = case break (== '\r') xs of + (_, "") -> xs + (ys, _ : zs) -> dropLastLine ys ++ removeProgress zs where - hspec :: IO (Bool, String) - hspec = do - mRun <- Session.getRunSpec session - case mRun of - Just run -> runSpecs run - Nothing -> return (True, "") + dropLastLine :: String -> String + dropLastLine = reverse . dropWhile (/= '\n') . reverse - runSpecs :: IO String -> IO (Bool, String) - runSpecs run = do +type Trigger = ExceptT Result (WriterT String IO) + +trigger :: Session -> Hooks -> IO (Result, String) +trigger session hooks = runWriterT (runExceptT go) >>= \ case + (Left result, output) -> return (result, output) + (Right (), output) -> return (Success, output) + where + go :: Trigger () + go = do + runHook hooks.beforeReload + output <- Session.reload session + tell output + case reloadedSuccessfully output of + False -> do + echo $ withColor Red "RELOADING FAILED" <> "\n" + abort + True -> do + echo $ withColor Green "RELOADING SUCCEEDED" <> "\n" + + runHook hooks.afterReload + getRunSpec >>= \ case + Just hspec -> rerunAllOnSuccess hspec + Nothing -> pass + + abort :: Trigger a + abort = throwError Failure + + rerunAllOnSuccess :: Trigger () -> Trigger () + rerunAllOnSuccess hspec = do failedPreviously <- isFailure <$> hspecPreviousSummary session - (success, xs) <- runSpec run - fmap (xs ++) <$> if success && failedPreviously - then runSpec run - else return (success, "") + hspec + when failedPreviously hspec - runSpec :: IO a -> IO (Bool, a) - runSpec run = do - xs <- run - success <- isSuccess <$> hspecPreviousSummary session - return (success, xs) + getRunSpec :: MonadIO m => m (Maybe (Trigger ())) + getRunSpec = liftIO $ fmap runSpec <$> Session.getRunSpec session + + runSpec :: IO String -> Trigger () + runSpec hspec = do + liftIO hspec >>= tell . removeProgress + result <- hspecPreviousSummary session + unless (isSuccess result) abort + + runHook :: Hook -> Trigger () + runHook hook = liftIO hook >>= \ case + HookSuccess -> pass + HookFailure message -> echo message >> throwError HookFailed + + echo :: String -> Trigger () + echo message = do + tell message + liftIO $ Session.echo session message diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE CPP, OverloadedStrings, LambdaCase, RecordWildCards, ViewPatterns #-} +{-# LANGUAGE CPP #-} module Util ( Color(..) , withColor , withInfoColor +, encodeUtf8 , isBoring , filterGitIgnoredFiles , normalizeTypeSignatures -, dotGhciWritableByOthers +, isWritableByOthers #ifdef TEST , filterGitIgnoredFiles_ @@ -18,44 +19,47 @@ import Imports import System.Console.ANSI -import System.FilePath import System.Process import System.Posix.Files import System.Posix.Types import qualified Data.Text as T +import qualified Data.Text.Encoding as T -withInfoColor :: IO a -> IO a +withInfoColor :: String -> String withInfoColor = withColor Magenta -withColor :: Color -> IO a -> IO a -withColor c = bracket_ set reset +withColor :: Color -> String -> String +withColor c string = set <> string <> reset where - set = setSGR [SetColor Foreground Dull c] - reset = setSGR [] + set = setSGRCode [SetColor Foreground Dull c] + reset = setSGRCode [] +encodeUtf8 :: String -> ByteString +encodeUtf8 = T.encodeUtf8 . T.pack + isBoring :: FilePath -> Bool isBoring p = ".git" `elem` dirs || "dist" `elem` dirs || isEmacsAutoSave p where dirs = splitDirectories p isEmacsAutoSave = isPrefixOf ".#" . takeFileName -filterGitIgnoredFiles :: [FilePath] -> IO [FilePath] -filterGitIgnoredFiles files = do - (feedback, ignoredFiles) <- filterGitIgnoredFiles_ files +filterGitIgnoredFiles :: (String -> IO ()) -> FilePath -> [FilePath] -> IO [FilePath] +filterGitIgnoredFiles echo dir files = do + (feedback, ignoredFiles) <- filterGitIgnoredFiles_ dir files printFeedback feedback - return $ ignoredFiles + return ignoredFiles where printFeedback :: Feedback -> IO () - printFeedback = mapM_ $ \ (color, err) -> withColor color $ putStrLn ('\n' : err) + printFeedback = mapM_ $ \ (color, err) -> echo ('\n' : withColor color err <> "\n") type Feedback = Maybe (Color, String) -filterGitIgnoredFiles_ :: [FilePath] -> IO (Feedback, [FilePath]) -filterGitIgnoredFiles_ files = fmap (files \\) <$> gitCheckIgnore files +filterGitIgnoredFiles_ :: FilePath -> [FilePath] -> IO (Feedback, [FilePath]) +filterGitIgnoredFiles_ dir files = fmap (files \\) <$> gitCheckIgnore dir files -gitCheckIgnore :: [FilePath] -> IO (Feedback, [FilePath]) -gitCheckIgnore files = do - (_, ignoredFiles, err) <- readProcessWithExitCode "git" ["check-ignore", "--stdin", "-z"] $ join_ files +gitCheckIgnore :: FilePath -> [FilePath] -> IO (Feedback, [FilePath]) +gitCheckIgnore dir files = do + (_, ignoredFiles, err) <- readProcessWithExitCode "git" ["-C", dir, "check-ignore", "--stdin", "-z"] $ join_ files return (gitCheckIgnoreFeedback err, split ignoredFiles) where join_ = intercalate "\0" @@ -82,12 +86,12 @@ '\8594' -> "->" _ -> [c] -dotGhciWritableByOthers :: IO Bool -dotGhciWritableByOthers = do - exists <- fileExist ".ghci" +isWritableByOthers :: FilePath -> IO Bool +isWritableByOthers name = do + exists <- fileExist name if exists then do - mode <- fileMode <$> getFileStatus ".ghci" - dirMode <- fileMode <$> getFileStatus "." + mode <- fileMode <$> getFileStatus name + dirMode <- fileMode <$> getFileStatus (takeDirectory name) return (writableByOthers mode || writableByOthers dirMode) else return False diff --git a/test/ClientSpec.hs b/test/ClientSpec.hs --- a/test/ClientSpec.hs +++ b/test/ClientSpec.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE OverloadedStrings #-} module ClientSpec (spec) where import Helper import HTTP import Client +import qualified Trigger spec :: Spec spec = do describe "client" $ do it "does a HTTP request via a Unix domain socket" $ do - inTempDirectory $ do - withServer (return (True, "hello")) $ do - client `shouldReturn` (True, "hello") + withTempDirectory $ \ dir -> do + withServer dir (return (Trigger.Success, "hello")) $ do + client dir `shouldReturn` (True, "hello") it "indicates failure" $ do - inTempDirectory $ do - withServer (return (False, "hello")) $ do - client `shouldReturn` (False, "hello") + withTempDirectory $ \ dir -> do + withServer dir (return (Trigger.Failure, "hello")) $ do + client dir `shouldReturn` (False, "hello") context "when server socket is missing" $ do it "reports error" $ do - inTempDirectory $ do - client `shouldReturn` (False, "could not connect to .sensei.sock\n") + withTempDirectory $ \ dir -> do + client dir `shouldReturn` (False, "could not connect to " <> fromString (socketName dir) <> "\n") diff --git a/test/ConfigSpec.hs b/test/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/ConfigSpec.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module ConfigSpec (spec) where + +import Helper +import Data.Aeson +import Data.Yaml.TH +import Data.ByteString.Lazy qualified as LB + +import Config + +spec :: Spec +spec = do + describe "readConfigFilesFrom" $ do + it "reads config values from ./sensei.yaml" $ do + withTempDirectory $ \ dir -> do + let + global = dir "global.yaml" + local = dir "local.yaml" + LB.writeFile local $ encode [yamlQQ| + before-reload: local-before-reload + on-success: local-on-success + |] + readConfigFilesFrom global local `shouldReturn` Right mempty { + beforeReload = Just "local-before-reload" + , onSuccess = Just "local-on-success" + } + + it "reads config values from ~/.config/sensei/sensei.yaml" $ do + withTempDirectory $ \ dir -> do + let + global = dir "global.yaml" + local = dir "local.yaml" + LB.writeFile global $ encode [yamlQQ| + on-failure: global-on-failure + on-success: global-on-success + |] + readConfigFilesFrom global local `shouldReturn` Right mempty { + onFailure = Just "global-on-failure" + , onSuccess = Just "global-on-success" + } + + context "with both ~/.config/sensei/sensei.yaml and ./sensei.yaml" $ do + it "gives fields from ./sensei.yaml precedence" $ do + withTempDirectory $ \ dir -> do + let + global = dir "global.yaml" + local = dir "local.yaml" + LB.writeFile global $ encode [yamlQQ| + on-failure: global-on-failure + on-success: global-on-success + |] + LB.writeFile local $ encode [yamlQQ| + before-reload: local-before-reload + on-success: local-on-success + |] + readConfigFilesFrom global local `shouldReturn` Right mempty { + beforeReload = Just "local-before-reload" + , onFailure = Just "global-on-failure" + , onSuccess = Just "local-on-success" + } + + context "with unknown fields" $ do + it "returns an error" $ do + withTempDirectory $ \ dir -> do + let + global = dir "global.yaml" + local = dir "local.yaml" + LB.writeFile local $ encode [yamlQQ| + some-field: some-value + |] + readConfigFilesFrom global local `shouldReturn` Left "Aeson exception:\nError in $: parsing Config.ConfigFile(ConfigFile) failed, unknown fields: [\"some-field\"]" + + describe "ConfigFile" $ do + it "deserializes from yaml" $ do + fromJSON [yamlQQ| + after-reload: foo bar baz + before-reload: blah + on-success: snafu + on-failure: failure + |] `shouldBe` Success ConfigFile { + afterReload = Just "foo bar baz" + , beforeReload = Just "blah" + , onSuccess = Just "snafu" + , onFailure = Just "failure" + } + + it "supports null" $ do + fromJSON [yamlQQ| + after-reload: null + before-reload: blah + on-success: finally + on-failure: failure + |] `shouldBe` Success ConfigFile { + afterReload = Nothing + , beforeReload = Just "blah" + , onSuccess = Just "finally" + , onFailure = Just "failure" + } + + it "supports missing fields" $ do + fromJSON [yamlQQ| + after-reload: blah + |] `shouldBe` Success ConfigFile { + afterReload = Just "blah" + , beforeReload = Nothing + , onSuccess = Nothing + , onFailure = Nothing + } + + it "accepts an emty config" $ do + fromJSON @ConfigFile [yamlQQ| + |] `shouldBe` Success mempty diff --git a/test/EventQueueSpec.hs b/test/EventQueueSpec.hs --- a/test/EventQueueSpec.hs +++ b/test/EventQueueSpec.hs @@ -1,58 +1,95 @@ module EventQueueSpec (spec) where import Helper +import qualified System.Info +import Run (watchFiles) + import EventQueue -withGitRepository :: IO a -> IO a -withGitRepository action = inTempDirectory (readProcess "git" ["init"] "" >> action) +withGitRepository :: (FilePath -> IO a) -> IO a +withGitRepository action = withTempDirectory $ \ dir -> do + readProcess "git" ["-C", dir, "init"] "" >> action dir spec :: Spec spec = do + describe "processQueue" $ do + context "when a spec is added" $ do + it "restarts" $ do + when (System.Info.os == "darwin") pending + withTempDirectory $ \ dir -> do + queue <- newQueue + watchFiles dir queue $ do + threadDelay 100_000 + touch $ dir "FooSpec.hs" + timeout (processQueue pass silent dir queue pass pass) `shouldReturn` Just (Restart Nothing) + + context "when a spec is removed" $ do + it "restarts" $ do + withTempDirectory $ \ dir -> do + let file = dir "FooSpec.hs" + touch file + queue <- newQueue + watchFiles dir queue $ do + threadDelay 100_000 + removeFile file + timeout (processQueue pass silent dir queue pass pass) `shouldReturn` Just (Restart Nothing) + + context "when .ghci is modified" $ do + it "restarts" $ do + withTempDirectory $ \ dir -> do + let file = dir ".ghci" + touch file + queue <- newQueue + watchFiles dir queue $ do + threadDelay 100_000 + touch file + timeout (processQueue pass silent dir queue pass pass) `shouldReturn` Just (Restart Nothing) + describe "processEvents" $ do - around_ withGitRepository $ do + around withGitRepository $ do context "with FileEvent" $ do - it "returns TriggerAction" $ do - processEvents [FileEvent FileModified "test/FooSpec.hs"] `shouldReturn` TriggerAction ["test/FooSpec.hs"] + it "returns TriggerAction" $ \ dir -> do + processEvents silent dir [FileEvent FileModified "test/FooSpec.hs"] `shouldReturn` TriggerAction ["test/FooSpec.hs"] context "with git ignored files" $ do - it "returns NoneAction" $ do - writeFile ".gitignore" "test/FooSpec.hs" - processEvents [FileEvent FileModified "test/FooSpec.hs"] `shouldReturn` NoneAction + it "returns NoneAction" $ \ dir -> do + writeFile (dir ".gitignore") "test/FooSpec.hs" + processEvents silent dir [FileEvent FileModified "test/FooSpec.hs"] `shouldReturn` NoneAction context "when a Spec file is added" $ do - it "returns ReloadAction" $ do - processEvents [FileEvent FileAdded "test/FooSpec.hs"] `shouldReturn` ReloadAction "test/FooSpec.hs" FileAdded + it "returns RestartAction" $ \ dir -> do + processEvents silent dir [FileEvent FileAdded "test/FooSpec.hs"] `shouldReturn` RestartAction "test/FooSpec.hs" FileAdded - it "takes precedence over TriggerAll" $ do - processEvents [TriggerAll, FileEvent FileAdded "test/FooSpec.hs", TriggerAll] `shouldReturn` ReloadAction "test/FooSpec.hs" FileAdded + it "takes precedence over TriggerAll" $ \ dir -> do + processEvents silent dir [TriggerAll, FileEvent FileAdded "test/FooSpec.hs", TriggerAll] `shouldReturn` RestartAction "test/FooSpec.hs" FileAdded - it "is overruled by Done" $ do - processEvents [Done, FileEvent FileAdded "test/FooSpec.hs", Done] `shouldReturn` DoneAction + it "is overruled by Done" $ \ dir -> do + processEvents silent dir [Done, FileEvent FileAdded "test/FooSpec.hs", Done] `shouldReturn` DoneAction context "when a Spec file is removed" $ do - it "returns ReloadAction" $ do - processEvents [FileEvent FileRemoved "test/FooSpec.hs"] `shouldReturn` ReloadAction "test/FooSpec.hs" FileRemoved + it "returns RestartAction" $ \ dir -> do + processEvents silent dir [FileEvent FileRemoved "test/FooSpec.hs"] `shouldReturn` RestartAction "test/FooSpec.hs" FileRemoved context "when file is first removed and then added" $ do - it "returns TriggerAction" $ do - processEvents [FileEvent FileRemoved "test/FooSpec.hs", FileEvent FileAdded "test/FooSpec.hs"] `shouldReturn` TriggerAction ["test/FooSpec.hs"] + it "returns TriggerAction" $ \ dir -> do + processEvents silent dir [FileEvent FileRemoved "test/FooSpec.hs", FileEvent FileAdded "test/FooSpec.hs"] `shouldReturn` TriggerAction ["test/FooSpec.hs"] context "when file is first added and then removed" $ do - it "returns NoneAction" $ do - processEvents [FileEvent FileAdded "test/FooSpec.hs", FileEvent FileRemoved "test/FooSpec.hs"] `shouldReturn` NoneAction + it "returns NoneAction" $ \ dir -> do + processEvents silent dir [FileEvent FileAdded "test/FooSpec.hs", FileEvent FileRemoved "test/FooSpec.hs"] `shouldReturn` NoneAction context "with TriggerAll" $ do - it "returns TriggerAllAction" $ do - processEvents [TriggerAll] `shouldReturn` TriggerAllAction + it "returns TriggerAllAction" $ \ dir -> do + processEvents silent dir [TriggerAll] `shouldReturn` TriggerAllAction - it "takes precedence over FileEvent" $ do - processEvents [FileEvent FileModified "foo", TriggerAll, FileEvent FileModified "foo"] `shouldReturn` TriggerAllAction + it "takes precedence over FileEvent" $ \ dir -> do + processEvents silent dir [FileEvent FileModified "foo", TriggerAll, FileEvent FileModified "foo"] `shouldReturn` TriggerAllAction context "with Done" $ do - it "returns DoneAction" $ do - processEvents [Done] `shouldReturn` DoneAction + it "returns DoneAction" $ \ dir -> do + processEvents silent dir [Done] `shouldReturn` DoneAction describe "combineFileEvents" $ do it "combines removed/added to modified" $ do diff --git a/test/HTTPSpec.hs b/test/HTTPSpec.hs --- a/test/HTTPSpec.hs +++ b/test/HTTPSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module HTTPSpec (spec) where import Helper @@ -6,14 +5,15 @@ import Test.Hspec.Wai import HTTP +import qualified Trigger spec :: Spec spec = do describe "app" $ do - with (return $ app $ return (True, "hello")) $ do + with (return $ app $ return (Trigger.Success, "hello")) $ do it "returns 200 on success" $ do get "/" `shouldRespondWith` 200 - with (return $ app $ return (False, "hello")) $ do + with (return $ app $ return (Trigger.Failure, "hello")) $ do it "return 500 on failure" $ do get "/" `shouldRespondWith` 500 diff --git a/test/Helper.hs b/test/Helper.hs --- a/test/Helper.hs +++ b/test/Helper.hs @@ -1,48 +1,61 @@ module Helper ( module Imports +, silent , ghciConfig -, withSession +, withTempDirectory , withSomeSpec , passingSpec , passingMetaSpec , failingSpec , Status(..) , modulesLoaded + +, Color(..) +, withColor + +, timeout ) where import Imports -import System.IO.Silently as Imports -import System.Process as Imports (readProcess, callCommand) +import System.Directory as Imports +import System.IO.Temp (withSystemTempDirectory) +import System.Process as Imports (readProcess, callProcess, callCommand) import Test.Hspec as Imports -import Test.Mockery.Directory as Imports import Test.Hspec.Contrib.Mocks.V1 as Imports +import Test.Mockery.Directory as Imports (touch) +import System.Environment +import qualified System.Timeout + import Run () -import qualified Session -import Session (Session) +import Util import Language.Haskell.GhciWrapper (Config(..)) -startupFile :: FilePath -startupFile = "startup.ghci" +timeout :: IO a -> IO (Maybe a) +timeout action = lookupEnv "CI" >>= \ case + Nothing -> System.Timeout.timeout 5_000_000 action + Just _ -> System.Timeout.timeout 30_000_000 action +silent :: a -> IO () +silent _ = pass + ghciConfig :: Config ghciConfig = Config { configIgnoreDotGhci = True -, configVerbose = False -, configStartupFile = startupFile +, configStartupFile = "startup.ghci" +, configWorkingDirectory = Nothing +, configEcho = silent } -withSession :: [String] -> (Session -> IO a) -> IO a -withSession = Session.withSession ghciConfig +withTempDirectory :: (FilePath -> IO a) -> IO a +withTempDirectory = withSystemTempDirectory "hspec" -withSomeSpec :: IO a -> IO a -withSomeSpec action = do - startup <- readFile startupFile - inTempDirectory $ do - writeFile startupFile startup - writeFile "Spec.hs" passingSpec - action +withSomeSpec :: (FilePath -> IO a) -> IO a +withSomeSpec action = withTempDirectory $ \ dir -> do + let name = dir "Spec.hs" + writeFile name passingSpec + action name passingSpec :: String passingSpec = unlines [ diff --git a/test/Language/Haskell/GhciWrapperSpec.hs b/test/Language/Haskell/GhciWrapperSpec.hs --- a/test/Language/Haskell/GhciWrapperSpec.hs +++ b/test/Language/Haskell/GhciWrapperSpec.hs @@ -2,8 +2,9 @@ module Language.Haskell.GhciWrapperSpec (main, spec) where import Helper +import qualified Data.ByteString.Char8 as ByteString -import Language.Haskell.GhciWrapper (Config(..), Interpreter) +import Language.Haskell.GhciWrapper (Config(..), Interpreter(..)) import qualified Language.Haskell.GhciWrapper as Interpreter main :: IO () @@ -20,16 +21,50 @@ describe "withInterpreter" $ do context "on shutdown" $ do it "drains `stdout` of the `ghci` process" $ do - result <- capture_ $ Interpreter.withInterpreter ghciConfig {configVerbose = True} [] $ \ _ghci -> do - pass - last (lines result) `shouldBe` "Leaving GHCi." + result <- withSpy $ \ spy -> do + Interpreter.withInterpreter ghciConfig {configEcho = spy} [] $ \ _ghci -> do + pass + last (ByteString.lines $ mconcat result) `shouldBe` "Leaving GHCi." + context "when .ghci is writable by others" $ do + let + with :: FilePath -> Config -> IO String + with dir config = do + let dotGhci = dir ".ghci" + writeFile dotGhci "" + callProcess "chmod" ["go+w", dotGhci] + Interpreter.withInterpreter config { configWorkingDirectory = Just dir } [] $ \ ghci -> Interpreter.eval ghci "23" + + context "when configIgnoreDotGhci is False" $ do + it "terminates with an error message" $ do + withTempDirectory $ \ dir -> do + let dotGhci = dir ".ghci" + with dir ghciConfig { configIgnoreDotGhci = False } `shouldThrow` (== (ErrorCall . unlines) [ + dotGhci <> " is writable by others, you can fix this with:" + , "" + , " chmod go-w " <> dotGhci <> " ." + , "" + ]) + + context "when configIgnoreDotGhci is True" $ do + it "does not terminate" $ do + withTempDirectory $ \ dir -> do + with dir ghciConfig { configIgnoreDotGhci = True } `shouldReturn` "23\n" + describe "evalVerbose" $ do - it "echos result to stdout" $ do - withInterpreter [] $ \ ghci -> do - capture (Interpreter.evalVerbose ghci $ "putStr" ++ show "foo\nbar") `shouldReturn` ("foo\nbar", "foo\nbar") + it "echos result" $ do + fmap mconcat . withSpy $ \ spy -> do + withInterpreter [] $ \ ghci -> do + Interpreter.evalVerbose ghci {echo = spy} "23" `shouldReturn` "23\n" + `shouldReturn` "23\n" describe "eval" $ do + it "does not echo result" $ do + fmap mconcat . withSpy $ \ spy -> do + withInterpreter [] $ \ ghci -> do + Interpreter.eval ghci {echo = spy} "23" `shouldReturn` "23\n" + `shouldReturn` "" + it "shows literals" $ withGhci $ \ ghci -> do ghci "23" `shouldReturn` "23\n" diff --git a/test/OptionsSpec.hs b/test/OptionsSpec.hs --- a/test/OptionsSpec.hs +++ b/test/OptionsSpec.hs @@ -10,8 +10,18 @@ spec :: Spec spec = do describe "splitArgs" $ do - it "returns longest matching list of Hspec arguments from end of given list" $ do + it "returns longest matching list of Hspec options from end of given list" $ do splitArgs ["foo", "--bar", "-m", "FooSpec", "-a", "1000"] `shouldBe` (["foo", "--bar"], ["-m", "FooSpec", "-a", "1000"]) - it "assumes everything after the last '--' to be Hspec arguments" $ do + it "assumes everything after the last '--' to be Hspec options" $ do splitArgs ["foo", "bar", "--", "foo", "baz"] `shouldBe` (["foo", "bar"], ["foo", "baz"]) + + context "with -p" $ do + it "recognizes -p as an Hspec option" $ do + splitArgs ["-p"] `shouldBe` ([], ["-p"]) + + it "recognizes -pN as an Hspec option" $ do + splitArgs ["-p20"] `shouldBe` ([], ["-p20"]) + + it "recognizes -packageNAME as a GHC option" $ do + splitArgs ["-packagebase"] `shouldBe` (["-packagebase"], []) diff --git a/test/PagerSpec.hs b/test/PagerSpec.hs new file mode 100644 --- /dev/null +++ b/test/PagerSpec.hs @@ -0,0 +1,51 @@ +module PagerSpec (spec) where + +import Helper + +import System.IO +import System.Process hiding (createPipe) + +import Pager + +spec :: Spec +spec = do + describe "matchOptions" $ do + it "contains --incsearch" $ do + -- The `--incsearch` flag changes the behavior of `--pattern` in subtle + -- ways. A user might have `--incsearch` enabled globally. To ensure + -- consistent behavior across environments we always enable + -- `--incsearch`. + matchOptions `shouldContain` ["--incsearch"] + + describe "pagerWith" $ do + it "pipes the provided input into a pager" $ do + (readEnd, writeEnd) <- createPipe + let + process :: CreateProcess + process = (proc "cat" []) { std_out = UseHandle writeEnd } + + input :: String + input = "foo" + + bracket (pagerWith process input) id $ \ _ -> do + hGetContents readEnd `shouldReturn` input + + it "can be canceled" $ do + let + process :: CreateProcess + process = proc "sleep" ["1d"] + cancel <- pagerWith process "foo" + timeout cancel `shouldReturn` Just () + + context "when writing to stdin of the subprocess blocks" $ do + it "can still be canceled" $ do + (_, writeEnd) <- createPipe + let + process :: CreateProcess + process = (proc "cat" []) { std_out = UseHandle writeEnd } + + input :: String + input = cycle "foo\n" + + cancel <- pagerWith process input + timeout cancel `shouldReturn` Just () diff --git a/test/ReadHandleSpec.hs b/test/ReadHandleSpec.hs --- a/test/ReadHandleSpec.hs +++ b/test/ReadHandleSpec.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module ReadHandleSpec (spec) where import Helper import Test.QuickCheck -import qualified Data.ByteString as B +import qualified Data.ByteString as ByteString import ReadHandle @@ -14,7 +12,7 @@ go "" = return [] go xs = do n <- chooseInt size - let (chunk, rest) = B.splitAt n xs + let (chunk, rest) = ByteString.splitAt n xs (chunk :) <$> go rest fakeHandle :: [ByteString] -> IO ReadHandle @@ -28,13 +26,13 @@ let maxChunkSize = case chunkSizes of SmallChunks -> 4 - BigChunks -> B.length input + BigChunks -> ByteString.length input chunks <- chunkByteString (1, maxChunkSize) input return $ fakeHandle chunks >>= action partialMarker :: ByteString -partialMarker = B.take 5 marker +partialMarker = ByteString.take 5 marker spec :: Spec spec = do diff --git a/test/RunSpec.hs b/test/RunSpec.hs new file mode 100644 --- /dev/null +++ b/test/RunSpec.hs @@ -0,0 +1,70 @@ +module RunSpec (spec) where + +import Helper + +import EventQueue + +import Language.Haskell.GhciWrapper (Config(..)) +import Run hiding (defaultRunArgs) +import qualified Run + +defaultRunArgs :: IO RunArgs +defaultRunArgs = do + args <- Run.defaultRunArgs "startup.ghci" + return args { ignoreConfig = True, sessionConfig = args.sessionConfig { configEcho = silent } } + +spec :: Spec +spec = do + describe "runWith" $ do + context "on Done" $ do + it "terminates" $ do + runArgs <- defaultRunArgs + emitEvent runArgs.queue Done + timeout (runWith runArgs) `shouldReturn` Just () + + context "on RestartWith" $ do + it "restarts the session with the given extra arguments" $ do + withSpy $ \ spy -> do + RunArgs{..} <- defaultRunArgs + let + runArgs = RunArgs { + withSession = \ config sessionArgs action -> withSession config sessionArgs $ \ session -> do + spy sessionArgs + action session <* emitEvent runArgs.queue Done + , .. + } + emitEvent runArgs.queue (RestartWith ["-Wall"]) + timeout (runWith runArgs) `shouldReturn` Just () + `shouldReturn` [[], ["-Wall"]] + + context "with multiple occurrences of RestartWith" $ do + it "gives the last occurrence precedence" $ do + withSpy $ \ spy -> do + RunArgs{..} <- defaultRunArgs + let + runArgs = RunArgs { + withSession = \ config sessionArgs action -> withSession config sessionArgs $ \ session -> do + spy sessionArgs + action session <* emitEvent runArgs.queue Done + , .. + } + emitEvent runArgs.queue (RestartWith ["-Wall"]) + emitEvent runArgs.queue (RestartWith ["-Wdefault"]) + timeout (runWith runArgs) `shouldReturn` Just () + `shouldReturn` [[], ["-Wdefault"]] + + context "after a restart without arguments" $ do + it "remembers the last seen extra arguments" $ do + nextEvent <- stubAction [RestartWith ["-Wall"], FileEvent FileModified ".ghci", Done] + withSpy $ \ spy -> do + RunArgs{..} <- defaultRunArgs + let + runArgs = RunArgs { + withSession = \ config sessionArgs action -> withSession config sessionArgs $ \ session -> do + spy sessionArgs + nextEvent >>= emitEvent runArgs.queue + action session + , .. + } + timeout (runWith runArgs) `shouldReturn` Just () + `shouldReturn` [[], ["-Wall"], ["-Wall"]] diff --git a/test/SessionSpec.hs b/test/SessionSpec.hs --- a/test/SessionSpec.hs +++ b/test/SessionSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} module SessionSpec (spec) where import Helper @@ -7,45 +6,53 @@ import Language.Haskell.GhciWrapper (eval) import qualified Session -import Session (Config(..), Session(..), Summary(..), hspecFailureEnvName, hspecPreviousSummary, hspecCommand) +import Session hiding (withSession, runSpec) +withSession :: [String] -> (Session -> IO a) -> IO a +withSession = Session.withSession ghciConfig + spec :: Spec spec = do describe "withSession" $ do it "unsets HSPEC_FAILURES" $ do - setEnv hspecFailureEnvName "foo" True + setEnv "HSPEC_FAILURES" "foo" True withSession [] $ \ Session{..} -> do - eval sessionInterpreter ("System.Environment.lookupEnv " ++ show hspecFailureEnvName) `shouldReturn` "Nothing\n" + eval interpreter "System.Environment.lookupEnv \"HSPEC_FAILURES\"" `shouldReturn` "Nothing\n" context "with `:set +t +s`" $ do it "works just fine" $ do - withSomeSpec $ do - writeFile ".ghci" ":set +t +s" - Session.withSession ghciConfig {configIgnoreDotGhci = False} [] $ \ Session{..} -> do - eval sessionInterpreter "23" `shouldReturn` "23\n" + withTempDirectory $ \ dir -> do + let + config = ghciConfig { + configIgnoreDotGhci = False + , configWorkingDirectory = Just dir + } + writeFile (dir ".ghci") ":set +t +s" + Session.withSession config [] $ \ Session{..} -> do + eval interpreter "23" `shouldReturn` "23\n" context "with -XOverloadedStrings" $ do it "works just fine" $ do withSession ["-XOverloadedStrings", "-Wall", "-Werror"] $ \ Session{..} -> do - eval sessionInterpreter "23 :: Int" `shouldReturn` "23\n" + eval interpreter "23 :: Int" `shouldReturn` "23\n" describe "reload" $ do it "reloads" $ do withSession [] $ \session -> do - silence (Session.reload session) `shouldReturn` (modulesLoaded Ok [] ++ "\n") + Session.reload session `shouldReturn` (modulesLoaded Ok [] ++ "\n") - describe "hasSpec" $ around_ withSomeSpec $ do + describe "hasSpec" $ around withSomeSpec $ do context "when module contains spec" $ do - it "returns True" $ do - withSession ["Spec.hs"] $ \session -> do - _ <- silence (Session.reload session) + it "returns True" $ \ name -> do + withSession [name] $ \session -> do + _ <- Session.reload session Session.hasSpec hspecCommand session `shouldReturn` True context "when module does not contain spec" $ do - it "returns False" $ do - withSession ["Spec.hs"] $ \session -> do - writeFile "Spec.hs" "module Main where" - _ <- silence (Session.reload session) + it "returns False" $ \ name -> do + withSession [name] $ \session -> do + writeFile name "module Main where" + _ <- Session.reload session Session.hasSpec hspecCommand session `shouldReturn` False describe "hasHspecCommandSignature" $ do @@ -70,16 +77,16 @@ it "returns False" $ do Session.hasHspecCommandSignature hspecCommand "foo" `shouldBe` False - describe "runSpec" $ around_ withSomeSpec $ do + describe "runSpec" $ around withSomeSpec $ do let runSpec = Session.runSpec hspecCommand - it "stores summary of spec run" $ do - withSession ["Spec.hs"] $ \session -> do - _ <- silence (runSpec session >> runSpec session) + it "stores summary of spec run" $ \ name -> do + withSession [name] $ \session -> do + _ <- runSpec session >> runSpec session hspecPreviousSummary session `shouldReturn` Just (Summary 2 0) - it "accepts Hspec args" $ do - withSession ["Spec.hs", "--no-color", "-m", "foo"] $ \session -> do - _ <- silence (runSpec session >> runSpec session) + it "accepts Hspec args" $ \ name -> do + withSession [name, "--no-color", "-m", "foo"] $ \session -> do + _ <- runSpec session >> runSpec session hspecPreviousSummary session `shouldReturn` Just (Summary 1 0) describe "parseSummary" $ do diff --git a/test/SpecHook.hs b/test/SpecHook.hs new file mode 100644 --- /dev/null +++ b/test/SpecHook.hs @@ -0,0 +1,7 @@ +module SpecHook where + +import Test.Hspec +import GHC.Conc + +hook :: Spec -> Spec +hook spec = runIO (getNumProcessors >>= setNumCapabilities) >> parallel spec diff --git a/test/TriggerSpec.hs b/test/TriggerSpec.hs --- a/test/TriggerSpec.hs +++ b/test/TriggerSpec.hs @@ -3,36 +3,71 @@ import Helper -import Trigger +import qualified Session +import Session (Session) +import Language.Haskell.GhciWrapper (Config(..)) +import Trigger hiding (trigger, triggerAll) +import qualified Trigger + normalize :: String -> [String] -normalize = normalizeErrors . normalizeTiming . normalizeSeed . lines . stripAnsiColors +normalize = normalizeTiming . lines where normalizeTiming :: [String] -> [String] - normalizeTiming = mkNormalize "Finished in " - - normalizeSeed :: [String] -> [String] - normalizeSeed = mkNormalize "Randomized with seed " + normalizeTiming = normalizeLine "Finished in " - mkNormalize :: String -> [String] -> [String] - mkNormalize message = map f + normalizeLine :: String -> [String] -> [String] + normalizeLine message = map f where f line | message `isPrefixOf` line = message ++ "..." | otherwise = line - normalizeErrors :: [String] -> [String] - normalizeErrors xs = case xs of - y : ys | "Spec.hs:" `isPrefixOf` y -> "Spec.hs:..." : normalizeErrors ys - y : ys -> y : normalizeErrors ys - [] -> [] +withSession :: FilePath -> [String] -> (Session -> IO a) -> IO a +withSession specPath args = do + Session.withSession ghciConfig {configWorkingDirectory = Just dir} $ + "-fhide-source-paths" + : "-fno-diagnostics-show-caret" + : "-fdiagnostics-color=never" + : file + : args + ++ ["--no-color", "--seed=0"] + where + (dir, file) = splitFileName specPath - stripAnsiColors xs = case xs of - '\ESC' : '[' : ';' : ys | 'm' : zs <- dropWhile isNumber ys -> stripAnsiColors zs - '\ESC' : '[' : ys | 'm' : zs <- dropWhile isNumber ys -> stripAnsiColors zs - y : ys -> y : stripAnsiColors ys - [] -> [] +trigger :: Session -> IO (Result, [String]) +trigger session = triggerWithHooks session defaultHooks +triggerWithHooks :: Session -> Hooks -> IO (Result, [String]) +triggerWithHooks session hooks = fmap normalize <$> Trigger.trigger session hooks + +triggerAll :: Session -> IO (Result, [String]) +triggerAll session = fmap normalize <$> Trigger.triggerAll session defaultHooks + +requiresHspecMeta :: IO () -> IO () +requiresHspecMeta action = try action >>= \ case + Left (ExitFailure 1) -> expectationFailure $ unlines [ + "This tests requires `hspec-meta`, which is not available. To address this run" + , "" + , " echo | cabal repl sensei --build-depends hspec-meta" + , "" + , "once." + ] + Left err -> throwIO err + Right () -> pass + +data HookExecuted = BeforeReloadSucceeded | AfterReloadSucceeded + deriving (Eq, Show) + +withHooks :: (Hooks -> IO ()) -> IO [HookExecuted] +withHooks action = withSpy $ \ spy -> action defaultHooks { + beforeReload = spy BeforeReloadSucceeded >> return HookSuccess +, afterReload = spy AfterReloadSucceeded >> return HookSuccess +} + +failingHook :: Hook +failingHook = return $ HookFailure "hook failed" + spec :: Spec spec = do describe "reloadedSuccessfully" $ do @@ -58,37 +93,50 @@ it "detects success" $ do reloadedSuccessfully "Ok, four modules loaded." `shouldBe` True - describe "triggerAll" $ around_ withSomeSpec $ do + describe "removeProgress" $ do + it "removes transient output" $ do + (removeProgress . unlines) [ + "foo" + , "some progress output...\r \rbar" + , "baz" + ] `shouldBe` unlines [ + "foo" + , "bar" + , "baz" + ] + + describe "triggerAll" $ do it "runs all specs" $ do - withSession ["Spec.hs", "--no-color"] $ \session -> do - writeFile "Spec.hs" failingSpec - (False, xs) <- silence (trigger session >> triggerAll session) - normalize xs `shouldBe` [ - modulesLoaded Ok ["Spec"] - , "" - , "foo [✔]" - , "bar [✘]" - , "" - , "Failures:" - , "" - , " Spec.hs:8:3: " - , " 1) bar" - , "" - , " To rerun use: --match \"/bar/\"" - , "" - , "Randomized with seed ..." - , "" - , "Finished in ..." - , "2 examples, 1 failure" - , "Summary {summaryExamples = 2, summaryFailures = 1}" - ] + withSomeSpec $ \ name -> do + withSession name [] $ \ session -> do + writeFile name failingSpec + (trigger session >> triggerAll session) `shouldReturn` (Failure, [ + modulesLoaded Ok ["Spec"] + , withColor Green "RELOADING SUCCEEDED" + , "" + , "foo [✔]" + , "bar [✘]" + , "" + , "Failures:" + , "" + , " Spec.hs:8:3: " + , " 1) bar" + , "" + , " To rerun use: --match \"/bar/\" --seed 0" + , "" + , "Randomized with seed 0" + , "" + , "Finished in ..." + , "2 examples, 1 failure" + , "Summary {summaryExamples = 2, summaryFailures = 1}" + ]) - describe "trigger" $ around_ withSomeSpec $ do - it "reloads and runs specs" $ do - withSession ["Spec.hs", "--no-color"] $ \session -> do - result <- silence (trigger session >> trigger session) - fmap normalize result `shouldBe` (True, [ + describe "trigger" $ around withSomeSpec $ do + it "reloads and runs specs" $ \ name -> do + withSession name [] $ \ session -> do + trigger session `shouldReturn` (Success, [ modulesLoaded Ok ["Spec"] + , withColor Green "RELOADING SUCCEEDED" , "" , "foo [✔]" , "bar [✔]" @@ -98,32 +146,73 @@ , "Summary {summaryExamples = 2, summaryFailures = 0}" ]) + context "with hooks" $ do + it "executes hooks" $ \ name -> do + withHooks $ \ hooks -> do + withSession name [] $ \ session -> do + triggerWithHooks session hooks `shouldReturn` (Success, [ + modulesLoaded Ok ["Spec"] + , withColor Green "RELOADING SUCCEEDED" + , "" + , "foo [✔]" + , "bar [✔]" + , "" + , "Finished in ..." + , "2 examples, 0 failures" + , "Summary {summaryExamples = 2, summaryFailures = 0}" + ]) + `shouldReturn` [BeforeReloadSucceeded, AfterReloadSucceeded] + + context "when the before-reload hook fails" $ do + it "cancels the reload cycle" $ \ name -> do + withHooks $ \ hooks -> do + withSession name [] $ \ session -> do + triggerWithHooks session hooks { beforeReload = failingHook } `shouldReturn` (HookFailed, [ + "hook failed" + ]) + `shouldReturn` [] + + context "when the after-reload hook fails" $ do + it "cancels the reload cycle" $ \ name -> do + withHooks $ \ hooks -> do + withSession name [] $ \ session -> do + triggerWithHooks session hooks { afterReload = failingHook } `shouldReturn` (HookFailed, [ + modulesLoaded Ok ["Spec"] + , withColor Green "RELOADING SUCCEEDED" + , "hook failed" + ]) + `shouldReturn` [BeforeReloadSucceeded] + context "with a module that does not compile" $ do - it "stops after reloading" $ do - withSession ["-fno-diagnostics-show-caret", "Spec.hs"] $ \session -> do - writeFile "Spec.hs" (passingSpec ++ "foo = bar") - (False, xs) <- silence (trigger session >> trigger session) - normalize xs `shouldBe` [ - "[1 of 1] Compiling Spec ( Spec.hs, interpreted )" + it "stops after reloading" $ \ name -> do + withSession name [] $ \ session -> do + writeFile name (passingSpec ++ "foo = bar") + (trigger session >> trigger session) `shouldReturn` (Failure, [ + "[1 of 1] Compiling Spec" , "" - , "Spec.hs:..." +#if __GLASGOW_HASKELL__ >= 906 + , "Spec.hs:9:7: error: [GHC-88464] Variable not in scope: bar" +#else + , "Spec.hs:9:7: error: Variable not in scope: bar" +#endif , modulesLoaded Failed [] - ] + , withColor Red "RELOADING FAILED" + ]) context "with a failing spec" $ do - it "indicates failure" $ do - withSession ["Spec.hs"] $ \session -> do - writeFile "Spec.hs" failingSpec - (False, xs) <- silence (trigger session) - xs `shouldContain` modulesLoaded Ok ["Spec"] - xs `shouldContain` "2 examples, 1 failure" + it "indicates failure" $ \ name -> do + withSession name [] $ \ session -> do + writeFile name failingSpec + (Failure, xs) <- trigger session + xs `shouldContain` [modulesLoaded Ok ["Spec"]] + xs `shouldContain` ["2 examples, 1 failure"] - it "only reruns failing specs" $ do - withSession ["Spec.hs", "--no-color"] $ \session -> do - writeFile "Spec.hs" failingSpec - (False, xs) <- silence (trigger session >> trigger session) - normalize xs `shouldBe` [ + it "only reruns failing specs" $ \ name -> do + withSession name [] $ \ session -> do + writeFile name failingSpec + (trigger session >> trigger session) `shouldReturn` (Failure, [ modulesLoaded Ok ["Spec"] + , withColor Green "RELOADING SUCCEEDED" , "" , "bar [✘]" , "" @@ -132,29 +221,29 @@ , " Spec.hs:8:3: " , " 1) bar" , "" - , " To rerun use: --match \"/bar/\"" + , " To rerun use: --match \"/bar/\" --seed 0" , "" - , "Randomized with seed ..." + , "Randomized with seed 0" , "" , "Finished in ..." , "1 example, 1 failure" , "Summary {summaryExamples = 1, summaryFailures = 1}" - ] + ]) context "after a failing spec passes" $ do - it "runs all specs" $ do - withSession ["Spec.hs", "--no-color"] $ \session -> do - writeFile "Spec.hs" failingSpec - _ <- silence (trigger session) - writeFile "Spec.hs" passingSpec - (True, xs) <- silence (trigger session) - normalize xs `shouldBe` [ + it "runs all specs" $ \ name -> do + withSession name [] $ \ session -> do + writeFile name failingSpec + _ <- trigger session + writeFile name passingSpec + trigger session `shouldReturn` (Success, [ #if __GLASGOW_HASKELL__ < 904 - "[1 of 1] Compiling Spec ( Spec.hs, interpreted )" + "[1 of 1] Compiling Spec" #else - "[1 of 1] Compiling Spec ( Spec.hs, interpreted ) [Source file changed]" + "[1 of 1] Compiling Spec [Source file changed]" #endif , modulesLoaded Ok ["Spec"] + , withColor Green "RELOADING SUCCEEDED" , "" , "bar [✔]" , "" @@ -168,21 +257,24 @@ , "Finished in ..." , "2 examples, 0 failures" , "Summary {summaryExamples = 2, summaryFailures = 0}" - ] + ]) context "with a module that does not expose a spec" $ do - it "only reloads" $ do - withSession ["Spec.hs"] $ \session -> do - writeFile "Spec.hs" "module Foo where" - silence (trigger session >> trigger session) `shouldReturn` (True, modulesLoaded Ok ["Foo"] ++ "\n") + it "only reloads" $ \ name -> do + withSession name [] $ \ session -> do + writeFile name "module Foo where" + (trigger session >> trigger session) `shouldReturn` (Success, [ + modulesLoaded Ok ["Foo"] + , withColor Green "RELOADING SUCCEEDED" + ]) context "with an hspec-meta spec" $ do - it "reloads and runs spec" $ do - withSession ["-package hspec-meta", "Spec.hs", "--no-color"] $ \session -> do - writeFile "Spec.hs" passingMetaSpec - result <- silence (trigger session >> trigger session) - fmap normalize result `shouldBe` (True, [ + it "reloads and runs spec" $ \ name -> do + requiresHspecMeta $ withSession name ["-package hspec-meta"] $ \ session -> do + writeFile name passingMetaSpec + (trigger session >> trigger session) `shouldReturn` (Success, [ modulesLoaded Ok ["Spec"] + , withColor Green "RELOADING SUCCEEDED" , "" , "foo [✔]" , "bar [✔]" diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs --- a/test/UtilSpec.hs +++ b/test/UtilSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module UtilSpec (spec) where import Helper @@ -7,6 +6,16 @@ import Util +withDotGhci :: (FilePath -> IO a) -> IO a +withDotGhci action = withTempDirectory $ \ dir -> do + let dotGhci = dir ".ghci" + writeFile dotGhci "" + chmod "go-w" dotGhci + action dotGhci + +chmod :: String -> FilePath -> IO () +chmod mode file = callProcess "chmod" [mode, file] + spec :: Spec spec = do describe "isBoring" $ do @@ -27,15 +36,16 @@ let gitlessFeedback = Just (Cyan, "warning: not a git repository - .gitignore support not available\n") describe "filterGitIgnoredFiles_" $ do - around_ inTempDirectory $ do - it "discards files that are ignored by git" $ do - _ <- readProcess "git" ["init"] "" - writeFile ".gitignore" "foo" - filterGitIgnoredFiles_ ["foo", "bar"] `shouldReturn` (Nothing, ["bar"]) + it "discards files that are ignored by git" $ do + withTempDirectory $ \ dir -> do + _ <- readProcess "git" ["-C", dir, "init"] "" + writeFile (dir ".gitignore") "foo" + filterGitIgnoredFiles_ dir ["foo", "bar"] `shouldReturn` (Nothing, ["bar"]) - context "when used outside of a git repository" $ do - it "returns all files" $ do - filterGitIgnoredFiles_ ["foo", "bar"] `shouldReturn` (gitlessFeedback, ["foo", "bar"]) + context "when used outside of a git repository" $ do + it "returns all files" $ do + withTempDirectory $ \ dir -> do + filterGitIgnoredFiles_ dir ["foo", "bar"] `shouldReturn` (gitlessFeedback, ["foo", "bar"]) describe "gitCheckIgnoreFeedback" $ do context "when git reports no repository" $ do @@ -57,30 +67,34 @@ let err = "fatal: Unable to do such and such" gitCheckIgnoreFeedback err `shouldBe` Just (Red, err) - describe "dotGhciWritableByOthers" $ do - around_ inTempDirectory $ do - before_ (touch ".ghci" >> callCommand "chmod go-w .ghci") $ do - it "returns False" $ do - dotGhciWritableByOthers `shouldReturn` False + describe "isWritableByOthers" $ do + it "returns False" $ do + withDotGhci $ \ dotGhci -> do + isWritableByOthers dotGhci `shouldReturn` False - context "when writable by group" $ do - it "returns True" $ do - callCommand "chmod g+w .ghci" - dotGhciWritableByOthers `shouldReturn` True + context "when writable by group" $ do + it "returns True" $ do + withDotGhci $ \ dotGhci -> do + chmod "g+w" dotGhci + isWritableByOthers dotGhci `shouldReturn` True - context "when writable by others" $ do - it "returns True" $ do - callCommand "chmod o+w .ghci" - dotGhciWritableByOthers `shouldReturn` True + context "when writable by others" $ do + it "returns True" $ do + withDotGhci $ \ dotGhci -> do + chmod "o+w" dotGhci + isWritableByOthers dotGhci `shouldReturn` True - context "when directory is writable by group" $ do - it "returns True" $ do - callCommand "chmod g+w ." - dotGhciWritableByOthers `shouldReturn` True + context "when directory is writable by group" $ do + it "returns True" $ do + withDotGhci $ \ dotGhci -> do + chmod "g+w" (takeDirectory dotGhci) + isWritableByOthers dotGhci `shouldReturn` True - context "when .ghci does not exist" $ do - it "returns False" $ do - dotGhciWritableByOthers `shouldReturn` False + context "when .ghci does not exist" $ do + it "returns False" $ do + withTempDirectory $ \ dir -> do + let dotGhci = dir ".ghci" + isWritableByOthers dotGhci `shouldReturn` False describe "writableByOthers" $ do it "returns False for owner" $ do