diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2015-2016 Simon Hengel + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/doctest/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs b/doctest/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs new file mode 100644 --- /dev/null +++ b/doctest/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE RecordWildCards #-} +module Language.Haskell.GhciWrapper ( + Interpreter +, Config(..) +, defaultConfig +, new +, close +, eval +, evalEcho +) where + +import System.IO hiding (stdin, stdout, stderr) +import System.Process +import System.Exit +import Control.Monad +import Control.Exception +import Data.List +import Data.Maybe + +data Config = Config { + configGhci :: String +, configVerbose :: Bool +, configIgnoreDotGhci :: Bool +} deriving (Eq, Show) + +defaultConfig :: Config +defaultConfig = Config { + configGhci = "ghci" +, configVerbose = False +, configIgnoreDotGhci = True +} + +-- | Truly random marker, used to separate expressions. +-- +-- IMPORTANT: This module relies upon the fact that this marker is unique. It +-- has been obtained from random.org. Do not expect this module to work +-- properly, if you reuse it for any purpose! +marker :: String +marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1" + +data Interpreter = Interpreter { + hIn :: Handle + , hOut :: Handle + , process :: ProcessHandle + } + +new :: Config -> [String] -> IO Interpreter +new Config{..} args_ = do + (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc configGhci args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit} + setMode stdin_ + setMode stdout_ + let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle} + _ <- eval interpreter "import System.IO" + _ <- eval interpreter "import GHC.IO.Handle" + -- The buffering of stdout and stderr is NoBuffering + _ <- eval interpreter "hDuplicateTo stdout stderr" + -- Now the buffering of stderr is BlockBuffering Nothing + -- In this situation, GHC 7.7 does not flush the buffer even when + -- error happens. + _ <- eval interpreter "hSetBuffering stdout LineBuffering" + _ <- eval interpreter "hSetBuffering stderr LineBuffering" + + -- this is required on systems that don't use utf8 as default encoding (e.g. + -- Windows) + _ <- eval interpreter "hSetEncoding stdout utf8" + _ <- eval interpreter "hSetEncoding stderr utf8" + + _ <- eval interpreter ":m - System.IO" + _ <- eval interpreter ":m - GHC.IO.Handle" + + return interpreter + where + args = args_ ++ catMaybes [ + if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing + , if configVerbose then Nothing else Just "-v0" + ] + setMode h = do + hSetBinaryMode h False + hSetBuffering h LineBuffering + hSetEncoding h utf8 + +close :: Interpreter -> IO () +close repl = do + hClose $ hIn repl + + -- It is crucial not to close `hOut` before calling `waitForProcess`, + -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang + -- around consuming 100% CPU. This happens when ghci tries to print + -- something to stdout in its signal handler (e.g. when it is blocked in + -- threadDelay it writes "Interrupted." on SIGINT). + e <- waitForProcess $ process repl + hClose $ hOut repl + + when (e /= ExitSuccess) $ do + throwIO (userError $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")") + +putExpression :: Interpreter -> String -> IO () +putExpression Interpreter{hIn = stdin} e = do + hPutStrLn stdin e + hPutStrLn stdin marker + hFlush stdin + +getResult :: Bool -> Interpreter -> IO String +getResult echoMode Interpreter{hOut = stdout} = go + where + go = do + line <- hGetLine stdout + if marker `isSuffixOf` line + then do + let xs = stripMarker line + echo xs + return xs + else do + echo (line ++ "\n") + result <- go + return (line ++ "\n" ++ result) + stripMarker l = take (length l - length marker) l + + echo :: String -> IO () + echo + | echoMode = putStr + | otherwise = (const $ return ()) + +-- | Evaluate an expression +eval :: Interpreter -> String -> IO String +eval repl expr = do + putExpression repl expr + getResult False repl + +-- | Evaluate an expression +evalEcho :: Interpreter -> String -> IO String +evalEcho repl expr = do + putExpression repl expr + getResult True repl diff --git a/driver/Client.hs b/driver/Client.hs new file mode 100644 --- /dev/null +++ b/driver/Client.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import System.Exit +import Control.Monad +import qualified Data.ByteString.Lazy as L + +import Client + +main :: IO () +main = do + (success, output) <- client + L.putStr output + unless success exitFailure diff --git a/driver/Main.hs b/driver/Main.hs new file mode 100644 --- /dev/null +++ b/driver/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import System.Environment + +import Run + +main :: IO () +main = getArgs >>= run diff --git a/driver/Web.hs b/driver/Web.hs new file mode 100644 --- /dev/null +++ b/driver/Web.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import System.Environment + +import Run + +main :: IO () +main = getArgs >>= runWeb diff --git a/sensei.cabal b/sensei.cabal new file mode 100644 --- /dev/null +++ b/sensei.cabal @@ -0,0 +1,166 @@ +-- This file has been generated from package.yaml by hpack version 0.8.0. +-- +-- see: https://github.com/sol/hpack + +name: sensei +version: 0.0.0 +synopsis: Automatically run Hspec tests on file modifications +category: Development +homepage: https://github.com/hspec/sensei#readme +bug-reports: https://github.com/hspec/sensei/issues +maintainer: Simon Hengel +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/hspec/sensei + +library + hs-source-dirs: + src + , doctest/ghci-wrapper/src/ + ghc-options: -Wall + build-depends: + base >= 4.7 && < 5 + , base-compat >= 0.8 + , process + , fsnotify + , time + , wai + , warp + , http-types + , stm + , text + , network + , ansi-terminal + , directory + , http-client + , bytestring + , filepath + , unix + exposed-modules: + Client + EventQueue + HTTP + Options + Run + Session + Trigger + Util + Language.Haskell.GhciWrapper + default-language: Haskell2010 + +executable sensei-web + main-is: driver/Web.hs + ghc-options: -Wall + build-depends: + base >= 4.7 && < 5 + , base-compat >= 0.8 + , process + , fsnotify + , time + , wai + , warp + , http-types + , stm + , text + , network + , ansi-terminal + , directory + , http-client + , bytestring + , filepath + , unix + , sensei + default-language: Haskell2010 + +executable seito + main-is: driver/Client.hs + ghc-options: -Wall + build-depends: + base >= 4.7 && < 5 + , base-compat >= 0.8 + , process + , fsnotify + , time + , wai + , warp + , http-types + , stm + , text + , network + , ansi-terminal + , directory + , http-client + , bytestring + , filepath + , unix + , sensei + default-language: Haskell2010 + +executable sensei + main-is: driver/Main.hs + ghc-options: -Wall + build-depends: + base >= 4.7 && < 5 + , base-compat >= 0.8 + , process + , fsnotify + , time + , wai + , warp + , http-types + , stm + , text + , network + , ansi-terminal + , directory + , http-client + , bytestring + , filepath + , unix + , sensei + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base >= 4.7 && < 5 + , base-compat >= 0.8 + , process + , fsnotify + , time + , wai + , warp + , http-types + , stm + , text + , network + , ansi-terminal + , directory + , http-client + , bytestring + , filepath + , unix + , sensei + , hspec >= 2.2.1 + , hspec-wai + , mockery + , silently + , interpolate + other-modules: + ClientSpec + Helper + HTTPSpec + OptionsSpec + SessionSpec + TriggerSpec + UtilSpec + default-language: Haskell2010 diff --git a/src/Client.hs b/src/Client.hs new file mode 100644 --- /dev/null +++ b/src/Client.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +module Client (client) where + +import Prelude () +import Prelude.Compat +import Control.Monad.Compat +import Control.Exception +import Data.String +import System.IO.Error +import Network.HTTP.Client +import Network.HTTP.Client.Internal +import Network.HTTP.Types +import Network.Socket hiding (recv) +import Network.Socket.ByteString (sendAll, recv) +import qualified Data.ByteString.Lazy as L + +import HTTP (newSocket, socketAddr, socketName) + +client :: IO (Bool, L.ByteString) +client = either (const $ connectError) id <$> tryJust p go + where + connectError :: (Bool, L.ByteString) + connectError = (False, "could not connect to " <> fromString socketName <> "\n") + + p :: HttpException -> Maybe () + p e = case e of + FailedConnectionException2 _ _ _ se -> guard (isDoesNotExistException se) >> Just () + _ -> Nothing + + isDoesNotExistException :: SomeException -> Bool + isDoesNotExistException = maybe False isDoesNotExistError . fromException + + go = do + manager <- newManager defaultManagerSettings {managerRawConnection = return newConnection} + request <- parseUrl "http://localhost/" + Response{..} <- httpLbs request {checkStatus = \_ _ _ -> Nothing} manager + return (statusIsSuccessful responseStatus, responseBody) + + newConnection _ _ _ = do + sock <- newSocket + connect sock socketAddr + socketConnection sock 8192 + +socketConnection :: Socket -> Int -> IO Connection +socketConnection sock chunksize = makeConnection (recv sock chunksize) (sendAll sock) (sClose sock) diff --git a/src/EventQueue.hs b/src/EventQueue.hs new file mode 100644 --- /dev/null +++ b/src/EventQueue.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE LambdaCase #-} +module EventQueue ( + EventQueue +, newQueue +, emitTriggerAll +, emitModified +, emitDone +, processQueue +) where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Compat +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM.TChan +import Control.Monad.STM +import Data.List.Compat + +import Util + +type EventQueue = TChan Event + +data Event = TriggerAll | Modified FilePath | Done + deriving Eq + +newQueue :: IO EventQueue +newQueue = atomically $ newTChan + +emitTriggerAll :: EventQueue -> IO () +emitTriggerAll chan = atomically $ writeTChan chan TriggerAll + +emitModified :: FilePath -> EventQueue -> IO () +emitModified path chan = atomically $ writeTChan chan (Modified path) + +emitDone :: EventQueue -> IO () +emitDone chan = atomically $ writeTChan chan Done + +readEvents :: EventQueue -> IO [Event] +readEvents chan = do + e <- atomically $ readTChan chan + unless (isKeyboardInput e) $ do + threadDelay 100000 + es <- atomically emptyQueue + return (e : es) + where + isKeyboardInput :: Event -> Bool + isKeyboardInput event = event == Done || event == TriggerAll + + emptyQueue :: STM [Event] + emptyQueue = do + mEvent <- tryReadTChan chan + case mEvent of + Nothing -> return [] + Just e -> (e :) <$> emptyQueue + +processQueue :: EventQueue -> IO () -> IO () -> IO () +processQueue chan triggerAll trigger = go + where + go = do + readEvents chan >>= \case + events | Done `elem` events -> return () + events | TriggerAll `elem` events -> do + triggerAll + go + events -> do + let files = (nub . sort) [p | Modified p <- events] + withInfoColor $ do + mapM_ putStrLn (map ("--> " ++) files) + trigger + go diff --git a/src/HTTP.hs b/src/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/HTTP.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +module HTTP ( + withServer +, socketName +, newSocket +, socketAddr + +-- exported for testing +, app +) where + +import Prelude () +import Prelude.Compat +import Data.String +import Data.Text.Lazy.Encoding (encodeUtf8) +import Control.Exception +import Control.Monad +import Control.Concurrent +import System.IO.Error +import System.Directory +import Network.Wai +import Network.HTTP.Types +import Network.Wai.Handler.Warp +import Network.Socket + +socketName :: String +socketName = ".sensei.sock" + +socketAddr :: 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 + +withServer :: IO (Bool, String) -> IO a -> IO a +withServer trigger = withApplication (app trigger) + +withApplication :: Application -> IO a -> IO a +withApplication application action = do + removeSocketFile + withSocket $ \sock -> do + bracket_ (bind sock socketAddr) removeSocketFile $ do + listen sock maxListenQueue + withThread (runSettingsSocket defaultSettings sock application) action + +removeSocketFile :: IO () +removeSocketFile = void $ tryJust (guard . isDoesNotExistError) (removeFile socketName) + +withThread :: IO () -> IO a -> IO a +withThread asyncAction action = do + mvar <- newEmptyMVar + tid <- forkIO $ do + asyncAction `finally` putMVar mvar () + r <- action + killThread tid + takeMVar mvar + return r + +app :: IO (Bool, String) -> Application +app trigger _ respond = trigger >>= textPlain + where + textPlain (success, xs) = respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ xs) + where + status + | success = ok200 + | otherwise = internalServerError500 diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,38 @@ +module Options (splitArgs) where + +import Data.List +import System.Console.GetOpt + +splitArgs :: [String] -> ([String], [String]) +splitArgs args = case break (== "--") $ reverse args of + (xs, "--" : ys) -> (reverse ys, reverse xs) + _ -> case filter isHspecArgs $ tails args of + x : _ -> (dropEnd (length x) args, x) + [] -> (args, []) + where + isHspecArgs xs = case getOpt Permute options xs of + (_, [], []) -> True + _ -> 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 [] ["dry-run"] (NoArg ()) + , Option [] ["fail-fast"] (NoArg ()) + , Option "r" ["rerun"] (NoArg ()) + ] diff --git a/src/Run.hs b/src/Run.hs new file mode 100644 --- /dev/null +++ b/src/Run.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +module Run where +import Prelude () +import Prelude.Compat + +import Control.Concurrent +import Control.Exception +import Control.Monad (void, forever, when) +import Data.Foldable +import System.Exit +import System.FSNotify + +import qualified HTTP +import qualified Session +import Session (Session) + +import EventQueue +import Trigger +import Util + +waitForever :: IO () +waitForever = forever $ threadDelay 10000000 + +watchFiles :: EventQueue -> IO () +watchFiles queue = void . forkIO $ do + withManager $ \manager -> do + _ <- watchTree manager "." (not . isBoring . eventPath) (\event -> emitModified (eventPath event) queue) + waitForever + +watchInput :: EventQueue -> IO () +watchInput queue = void . forkIO $ do + input <- getContents + forM_ (lines input) $ \_ -> do + emitTriggerAll queue + emitDone queue + +run :: [String] -> IO () +run args = do + withSession args $ \session -> 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 + triggerAction = saveOutput (trigger session) + triggerAllAction = saveOutput (triggerAll session) + triggerAction + processQueue queue triggerAllAction triggerAction + +runWeb :: [String] -> IO () +runWeb args = do + withSession args $ \session -> do + _ <- trigger session + lock <- newMVar () + HTTP.withServer (withMVar lock $ \() -> trigger session) $ do + waitForever + +withSession :: [String] -> (Session -> IO ()) -> IO () +withSession 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 + bracket (Session.new args) Session.close action diff --git a/src/Session.hs b/src/Session.hs new file mode 100644 --- /dev/null +++ b/src/Session.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE RecordWildCards #-} +module Session ( + Session(..) +, hspecFailureEnvName +, new +, close +, reload + +, Summary(..) +, isFailure +, isSuccess +, hasSpec +, hasHspecCommandSignature +, runSpec +, hspecPreviousSummary +, resetSummary +, parseSummary +) where + +import Data.IORef +import Data.List.Compat +import Data.Maybe (listToMaybe, catMaybes) +import Prelude () +import Prelude.Compat +import Text.Read.Compat + +import qualified Language.Haskell.GhciWrapper as GhciWrapper +import Language.Haskell.GhciWrapper hiding (new, close) + +import Util +import Options + +hspecFailureEnvName :: String +hspecFailureEnvName = "HSPEC_FAILURES" + +data Session = Session { + sessionInterpreter :: Interpreter +, sessionHspecArgs :: [String] +, sessionHspecPreviousSummary :: IORef (Maybe Summary) +} + +resetSummary :: Session -> IO () +resetSummary Session{..} = writeIORef sessionHspecPreviousSummary (Just $ Summary 0 0) + +hspecPreviousSummary :: Session -> IO (Maybe Summary) +hspecPreviousSummary Session{..} = readIORef sessionHspecPreviousSummary + +new :: [String] -> IO Session +new args = do + let (ghciArgs, hspecArgs) = splitArgs args + ghci <- GhciWrapper.new defaultConfig{configVerbose = True, configIgnoreDotGhci = False} ghciArgs + _ <- eval ghci (":set prompt " ++ show "") + _ <- eval ghci ("import qualified System.Environment") + _ <- eval ghci ("import qualified Test.Hspec.Runner") + _ <- eval ghci ("System.Environment.unsetEnv " ++ show hspecFailureEnvName) + ref <- newIORef (Just $ Summary 0 0) + return (Session ghci hspecArgs ref) + +close :: Session -> IO () +close = GhciWrapper.close . sessionInterpreter + +reload :: Session -> IO String +reload Session{..} = evalEcho sessionInterpreter ":reload" + +data Summary = Summary { + summaryExamples :: Int +, summaryFailures :: Int +} deriving (Eq, Show, Read) + +hspecCommand :: String +hspecCommand = "Test.Hspec.Runner.hspecResult spec" + +hasSpec :: Session -> IO Bool +hasSpec Session{..} = hasHspecCommandSignature <$> eval sessionInterpreter (":type " ++ hspecCommand) + +hasHspecCommandSignature :: String -> Bool +hasHspecCommandSignature = any match . lines . normalizeTypeSignatures + where + match line = (hspecCommand ++ " :: IO ") `isPrefixOf` line && "Summary" `isSuffixOf` line + +runSpec :: Session -> IO String +runSpec session@Session{..} = do + failedPreviously <- isFailure <$> hspecPreviousSummary session + let args = "--color" : (if failedPreviously then addRerun else id) sessionHspecArgs + r <- evalEcho sessionInterpreter $ "System.Environment.withArgs " ++ show args ++ " $ " ++ hspecCommand + writeIORef sessionHspecPreviousSummary (parseSummary r) + return r + where + addRerun :: [String] -> [String] + addRerun args = "--rerun" : args + +isFailure :: Maybe Summary -> Bool +isFailure = maybe True ((/= 0) . summaryFailures) + +isSuccess :: Maybe Summary -> Bool +isSuccess = not . isFailure + +parseSummary :: String -> Maybe Summary +parseSummary = findJust . map (readMaybe . dropAnsiEscapeSequences) . reverse . lines + where + findJust = listToMaybe . catMaybes + + dropAnsiEscapeSequences xs + | "Summary" `isPrefixOf` xs = xs + | otherwise = case xs of + _ : ys -> dropAnsiEscapeSequences ys + [] -> [] diff --git a/src/Trigger.hs b/src/Trigger.hs new file mode 100644 --- /dev/null +++ b/src/Trigger.hs @@ -0,0 +1,41 @@ +module Trigger ( + trigger +, triggerAll +) where + +import Prelude () +import Prelude.Compat +import Data.List + +import Session (Session, isFailure, isSuccess, hspecPreviousSummary, resetSummary) +import qualified Session + +triggerAll :: Session -> IO (Bool, String) +triggerAll session = do + resetSummary session + trigger session + +trigger :: Session -> IO (Bool, String) +trigger session = do + xs <- Session.reload session + fmap (xs ++) <$> if "Ok, modules loaded:" `isInfixOf` xs + then hspec + else return (False, "") + where + hspec = do + hasSpec <- Session.hasSpec session + if hasSpec + then runSpecs + else return (True, "") + + runSpecs = do + failedPreviously <- isFailure <$> hspecPreviousSummary session + (success, xs) <- runSpec + fmap (xs ++) <$> if success && failedPreviously + then runSpec + else return (success, "") + + runSpec = do + xs <- Session.runSpec session + success <- isSuccess <$> hspecPreviousSummary session + return (success, xs) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings, LambdaCase #-} +module Util where + +import Prelude () +import Prelude.Compat + +import Control.Exception +import Data.List.Compat +import System.Console.ANSI +import System.FilePath +import System.Posix.Files +import System.Posix.Types + +withInfoColor :: IO a -> IO a +withInfoColor = bracket_ set reset + where + set = setSGR [SetColor Foreground Dull Magenta] + reset = setSGR [] + +isBoring :: FilePath -> Bool +isBoring p = ".git" `elem` dirs || "dist" `elem` dirs || isEmacsAutoSave p + where + dirs = splitDirectories p + isEmacsAutoSave = isPrefixOf ".#" . takeFileName + +normalizeTypeSignatures :: String -> String +normalizeTypeSignatures = normalize . concatMap replace + where + normalize = \case + xs | "\n :: " `isPrefixOf` xs -> normalizeTypeSignatures (drop 2 xs) + x : xs -> x : normalizeTypeSignatures xs + [] -> [] + + replace c = case c of + '\8759' -> "::" + '\8594' -> "->" + _ -> [c] + +dotGhciWritableByOthers :: IO Bool +dotGhciWritableByOthers = do + exists <- fileExist ".ghci" + if exists then do + mode <- fileMode <$> getFileStatus ".ghci" + dirMode <- fileMode <$> getFileStatus "." + return (writableByOthers mode || writableByOthers dirMode) + else + return False + +writableByOthers :: FileMode -> Bool +writableByOthers mode = m /= nullFileMode + where + m = intersectFileModes (unionFileModes otherWriteMode groupWriteMode) mode diff --git a/test/ClientSpec.hs b/test/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/ClientSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +module ClientSpec (spec) where + +import Helper + +import HTTP +import Client + +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") + + it "indicates failure" $ do + inTempDirectory $ do + withServer (return (False, "hello")) $ do + client `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") diff --git a/test/HTTPSpec.hs b/test/HTTPSpec.hs new file mode 100644 --- /dev/null +++ b/test/HTTPSpec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +module HTTPSpec (spec) where + +import Test.Hspec +import Test.Hspec.Wai + +import HTTP + +spec :: Spec +spec = do + describe "app" $ do + with (return $ app $ return (True, "hello")) $ do + it "returns 200 on success" $ do + get "/" `shouldRespondWith` 200 + + with (return $ app $ return (False, "hello")) $ do + it "return 500 on failure" $ do + get "/" `shouldRespondWith` 500 diff --git a/test/Helper.hs b/test/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Helper.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE QuasiQuotes #-} +module Helper ( + module Test.Hspec +, module Test.Mockery.Directory +, module Control.Applicative +, module System.IO.Silently +, withSession +, withSomeSpec +, passingSpec +, failingSpec +) where + +import Control.Applicative +import Control.Exception +import Data.String.Interpolate +import System.IO.Silently +import Test.Hspec +import Test.Mockery.Directory + +import Run () +import qualified Session +import Session (Session) + +withSession :: [String] -> (Session -> IO a) -> IO a +withSession args action = bracket (Session.new $ "-ignore-dot-ghci" : args) Session.close action + +withSomeSpec :: IO a -> IO a +withSomeSpec = (inTempDirectory . (writeFile "Spec.hs" passingSpec >>)) + +passingSpec :: String +passingSpec = [i| +module Spec (spec) where + +import Test.Hspec + +spec :: Spec +spec = do + it "foo" True + it "bar" True +|] + +failingSpec :: String +failingSpec = [i| +module Spec (spec) where + +import Test.Hspec + +spec :: Spec +spec = do + it "foo" True + it "bar" False +|] diff --git a/test/OptionsSpec.hs b/test/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/OptionsSpec.hs @@ -0,0 +1,17 @@ +module OptionsSpec (main, spec) where + +import Test.Hspec + +import Options + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "splitArgs" $ do + it "returns longest matching list of Hspec arguments 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 + splitArgs ["foo", "bar", "--", "foo", "baz"] `shouldBe` (["foo", "bar"], ["foo", "baz"]) diff --git a/test/SessionSpec.hs b/test/SessionSpec.hs new file mode 100644 --- /dev/null +++ b/test/SessionSpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE RecordWildCards #-} +module SessionSpec (spec) where + +import Language.Haskell.GhciWrapper (eval) +import System.Environment.Compat + +import Helper + +import qualified Session +import Session (Session(..), Summary(..), hspecFailureEnvName, hspecPreviousSummary) + +spec :: Spec +spec = do + describe "new" $ do + it "unsets HSPEC_FAILURES" $ do + setEnv hspecFailureEnvName "foo" + withSession [] $ \Session{..} -> do + _ <- eval sessionInterpreter "import System.Environment" + eval sessionInterpreter ("lookupEnv " ++ show hspecFailureEnvName) `shouldReturn` "Nothing\n" + + describe "reload" $ do + it "reloads" $ do + withSession [] $ \session -> do + silence (Session.reload session) `shouldReturn` "Ok, modules loaded: none.\n" + + describe "hasSpec" $ around_ withSomeSpec $ do + context "when module contains spec" $ do + it "returns True" $ do + withSession ["Spec.hs"] $ \session -> do + _ <- silence (Session.reload session) + Session.hasSpec 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) + Session.hasSpec session `shouldReturn` False + + describe "hasHspecCommandSignature" $ do + let signature = "Test.Hspec.Runner.hspecResult spec :: IO Test.Hspec.Core.Runner.Summary" + + context "when input contains qualified Hspec command signature" $ do + it "returns True" $ do + Session.hasHspecCommandSignature signature `shouldBe` True + + it "ignores additional output after summary" $ do + (Session.hasHspecCommandSignature . unlines) [ + "bar" + , signature + , "foo" + ] `shouldBe` True + + context "when input contains unqualified Hspec command signature" $ do + it "returns True" $ do + Session.hasHspecCommandSignature "Test.Hspec.Runner.hspecResult spec :: IO Summary" `shouldBe` True + + context "when input dose not contain Hspec command signature" $ do + it "returns False" $ do + Session.hasHspecCommandSignature "foo" `shouldBe` False + + describe "runSpec" $ around_ withSomeSpec $ do + it "stores summary of spec run" $ do + withSession ["Spec.hs"] $ \session -> do + _ <- silence (Session.runSpec session >> 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 (Session.runSpec session >> Session.runSpec session) + hspecPreviousSummary session `shouldReturn` Just (Summary 1 0) + + describe "parseSummary" $ do + let summary = Summary 2 0 + + it "parses summary" $ do + Session.parseSummary (show summary) `shouldBe` Just summary + + it "ignores additional output before / after summary" $ do + (Session.parseSummary . unlines) [ + "foo" + , show summary + , "bar" + ] `shouldBe` Just summary + + it "gives last occurrence precedence" $ do + (Session.parseSummary . unlines) [ + show (Summary 3 0) + , show summary + ] `shouldBe` Just summary + + it "ignores additional output at the beginning of a line (to cope with ansi escape sequences)" $ do + Session.parseSummary ("foo " ++ show summary) `shouldBe` Just (Summary 2 0) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TriggerSpec.hs b/test/TriggerSpec.hs new file mode 100644 --- /dev/null +++ b/test/TriggerSpec.hs @@ -0,0 +1,137 @@ +module TriggerSpec (spec) where + +import Helper +import Data.List + +import Trigger + +normalize :: String -> [String] +normalize = normalizeErrors . normalizeTiming . normalizeSeed . lines + where + normalizeErrors :: [String] -> [String] + normalizeErrors = mkNormalize "Spec.hs:" + + normalizeTiming :: [String] -> [String] + normalizeTiming = mkNormalize "Finished in " + + normalizeSeed :: [String] -> [String] + normalizeSeed = mkNormalize "Randomized with seed " + + mkNormalize :: String -> [String] -> [String] + mkNormalize message = map f + where + f line + | message `isPrefixOf` line = message ++ "..." + | otherwise = line + +spec :: Spec +spec = do + describe "triggerAll" $ around_ withSomeSpec $ 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` [ + "Ok, modules loaded: Spec." + , "" + , "foo" + , "bar FAILED [1]" + , "" + , "Failures:" + , "" + , " Spec.hs:9: " + , " 1) bar" + , "" + , "Randomized with seed ..." + , "" + , "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, [ + "Ok, modules loaded: Spec." + , "" + , "foo" + , "bar" + , "" + , "Finished in ..." + , "2 examples, 0 failures" + , "Summary {summaryExamples = 2, summaryFailures = 0}" + ]) + + context "with a module that does not compile" $ do + it "stops after reloading" $ do + withSession ["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 )" + , "" + , "Spec.hs:..." + , "Failed, modules loaded: none." + ] + + 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` "Ok, modules loaded:" + 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` [ + "Ok, modules loaded: Spec." + , "" + , "bar FAILED [1]" + , "" + , "Failures:" + , "" + , " Spec.hs:9: " + , " 1) bar" + , "" + , "Randomized with seed ..." + , "" + , "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` [ + "[1 of 1] Compiling Spec ( Spec.hs, interpreted )" + , "Ok, modules loaded: Spec." + , "" + , "bar" + , "" + , "Finished in ..." + , "1 example, 0 failures" + , "Summary {summaryExamples = 1, summaryFailures = 0}" + , "" + , "foo" + , "bar" + , "" + , "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 Main where" + silence (trigger session >> trigger session) `shouldReturn` (True, "Ok, modules loaded: Main.\n") diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/UtilSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +module UtilSpec (spec) where + +import Helper + +import System.Posix.Files +import System.Process + +import Util + +spec :: Spec +spec = do + describe "isBoring" $ do + it "ignores files in .git/" $ do + isBoring "/foo/bar/.git/baz/foo.txt" `shouldBe` True + + it "ignores files in dist/" $ do + isBoring "/foo/bar/dist/baz/foo.txt" `shouldBe` True + + describe "normalizeTypeSignatures" $ do + it "removes newlines from type signatures" $ do + normalizeTypeSignatures "foo\n :: Int" `shouldBe` "foo :: Int" + + it "replaces unicode characters" $ do + normalizeTypeSignatures "head ∷ [a] → a" `shouldBe` "head :: [a] -> a" + + describe "dotGhciWritableByOthers" $ do + around_ inTempDirectory $ do + before_ (touch ".ghci" >> callCommand "chmod go-w .ghci") $ do + it "returns False" $ do + dotGhciWritableByOthers `shouldReturn` False + + context "when writable by group" $ do + it "returns True" $ do + callCommand "chmod g+w .ghci" + dotGhciWritableByOthers `shouldReturn` True + + context "when writable by others" $ do + it "returns True" $ do + callCommand "chmod o+w .ghci" + dotGhciWritableByOthers `shouldReturn` True + + context "when directory is writable by group" $ do + it "returns True" $ do + callCommand "chmod g+w ." + dotGhciWritableByOthers `shouldReturn` True + + context "when .ghci does not exist" $ do + it "returns False" $ do + dotGhciWritableByOthers `shouldReturn` False + + describe "writableByOthers" $ do + it "returns False for owner" $ do + writableByOthers ownerWriteMode `shouldBe` False + + it "returns True for group" $ do + writableByOthers groupWriteMode `shouldBe` True + + it "returns True for others" $ do + writableByOthers otherWriteMode `shouldBe` True