diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,6 +3,10 @@ A file watcher and development tool, similar to Ruby's [Guard](https://github.com/guard/guard). +The main idea is that you have steeloverseer watch your files and then execute a series of shell +commands in response. The first command to fail short circuits the series. The watched files can +be selected using regular expressions and the commands may include capture groups. + [![Build Status](https://travis-ci.org/steeloverseer/steeloverseer.png?branch=master)](https://travis-ci.org/steeloverseer/steeloverseer) Installation @@ -20,9 +24,10 @@ See `sos --help` to get started: - Steel Overseer 2.0.1 + Steel Overseer 2.0.2 Usage: sos [TARGET] [--rcfile ARG] [-c|--command COMMAND] [-p|--pattern PATTERN] + [-e|--exclude PATTERN] A file watcher and development tool. Available options: @@ -34,16 +39,20 @@ -c,--command COMMAND Add command to run on file event. -p,--pattern PATTERN Add pattern to match on file path. Only relevant if the target is a directory. (default: .*) + -e,--exclude PATTERN Add pattern to exclude matches on file path. Only + relevant if the target is a directory. + Patterns and Commands ------------------- Capture groups can be created with `(` `)` and captured variables can be referred to with `\1`, `\2`, etc. (`\0` contains the entire match). -For example, for each change to a `.c` file in `src/`, we may want to compile -the file and run its corresponding unit test: +For example, for each change to a `.c` file in `src/` (excluding files +containing `"_test"`), we may want to compile the file and run its corresponding +unit test: - sos src/ -c "gcc -c \0 -o obj/\1.o" -c "make test --filter=test/\1_test.c" -p "src/(.*)\.c" + sos src/ -c "gcc -c \0 -o obj/\1.o" -c "make test --filter=test/\1_test.c" -p "src/(.*)\.c" -e "_test" Commands are run left-to-right, and one failed command will halt the entire pipeline. @@ -54,6 +63,7 @@ ```yaml - pattern: src/(.*)\.c + exclude: _test commands: - gcc -c \0 -o obj/\1.o - make test --filter=test/\1_test.c @@ -72,9 +82,14 @@ ### Grammar sosrc := [entry] - entry := { "pattern" | "patterns" : value | [value] - , "command" | "commands" : value | [value] + entry := { + pattern_entry, + exclude_entry?, -- Note: optional! + command_entry } + pattern_entry := "pattern" | "patterns" : value | [value] + exclude_entry := "exclude" | "excludes" | "excluding" : value | [value] + command_entry := "command" | "commands" : value | [value] value := [segment] segment := text_segment | var_segment text_segment := string diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,38 +1,53 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Main where -import Sos +import Sos.FileEvent +import Sos.Job +import Sos.Rule +import Sos.Template import Sos.Utils -import qualified System.FSNotify.Streaming as FSNotify - import Control.Concurrent.Async +import Control.Monad.Catch (MonadThrow(..)) +import Control.Monad.STM +import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM.TQueue.Extra +import Control.Exception import Control.Monad -import Control.Monad.Except -import Data.ByteString (ByteString) -import Data.List.NonEmpty (NonEmpty(..)) +import Control.Monad.Managed +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid -import Data.Yaml (decodeFileEither, prettyPrintParseException) +import Data.Yaml (decodeFileEither, prettyPrintParseException) import Options.Applicative import Streaming import System.Directory import System.Exit import System.FilePath -import System.IO +import Text.Printf (printf) +import Text.Regex.TDFA (match) -import qualified Data.Foldable as Foldable import qualified Streaming.Prelude as S - +import qualified System.FSNotify.Streaming as FSNotify version :: String -version = "Steel Overseer 2.0.1.0" +version = "Steel Overseer 2.0.2" data Options = Options { optTarget :: FilePath , optRCFile :: FilePath , optCommands :: [RawTemplate] , optPatterns :: [RawPattern] + , optExcludes :: [RawPattern] } deriving Show +-- The concurrent sources of input to the main worker thread. +data Input + = JobToEnqueue Job + | JobToRun Job + | JobResult Job (Maybe SomeException) + main :: IO () main = execParser opts >>= main' where @@ -63,6 +78,11 @@ <> short 'p' <> help "Add pattern to match on file path. Only relevant if the target is a directory. (default: .*)" <> metavar "PATTERN" ))) + <*> many (fmap packBS (strOption + ( long "exclude" + <> short 'e' + <> help "Add pattern to exclude matches on file path. Only relevant if the target is a directory." + <> metavar "PATTERN" ))) main' :: Options -> IO () main' Options{..} = do @@ -72,24 +92,25 @@ -- Parse cli rules, where one rule is created per pattern that executes -- each of @optCommands@ sequentially. cli_rules <- do - let patterns :: [RawPattern] - patterns = + let patterns, excludes :: [RawPattern] + (patterns, excludes) = case (rc_rules, optPatterns) of -- If there are no commands in .sosrc, and no patterns -- specified on the command line, default to ".*" - ([], []) -> [".*"] - _ -> optPatterns - runSos (mapM (`buildRule` optCommands) patterns) + ([], []) -> ([".*"], []) + _ -> (optPatterns, optExcludes) + mapM (\pattrn -> buildRule pattrn excludes optCommands) patterns + (target, rules) <- do is_dir <- doesDirectoryExist optTarget is_file <- doesFileExist optTarget case (is_dir, is_file) of (True, _) -> pure (optTarget, cli_rules ++ rc_rules) -- If the target is a single file, completely ignore the .sosrc - -- commands and the cli commands. + -- commands. (_, True) -> do - rule <- runSos (buildRule (packBS optTarget) optCommands) + rule <- buildRule (packBS optTarget) [] optCommands pure (takeDirectory optTarget, [rule]) _ -> do putStrLn ("Target " ++ optTarget ++ " is not a file or directory.") @@ -97,54 +118,132 @@ putStrLn "Hit Ctrl+C to quit." - job_queue <- newJobQueue + all_job_events :: TQueue Job <- newTQueueIO - let enqueue_thread :: IO a + let event_stream :: Stream (Of FileEvent) Managed () + event_stream = watchTree target + + job_stream :: Stream (Of Job) Managed () + job_stream = + S.for event_stream + (\event -> + liftIO (eventCommands rules event) >>= \case + [] -> pure () + (c:cs) -> S.yield (Job event (c :| cs))) + + enqueue_thread :: Managed () enqueue_thread = - runSos (sosEnqueueJobs rules (watchTree target) job_queue) + S.mapM_ (liftIO . atomically . writeTQueue all_job_events) job_stream -- Run jobs forever, only stopping to prompt whether or not to run -- enqueued jobs when a job fails. This way, the failing job's output -- will not be lost by subsequent jobs' outputs without the user's -- consent. dequeue_thread :: IO a - dequeue_thread = forever $ do - dequeueJob job_queue >>= \case - JobSuccess -> pure () - JobFailure -> do - jobQueueLength job_queue >>= \case - 0 -> pure () - n -> do - putStrLn (yellow (show n ++ " job(s) still pending.")) + dequeue_thread = do + -- Keep track of the subset of all job events to actually run. We don't + -- want to enqueue already-enqueued jobs, for example - once is enough. + jobs_to_run :: TQueue Job <- newTQueueIO - hSetBuffering stdin NoBuffering - continue <- fix (\prompt -> do - putStr (yellow "Press 'c' to continue, 'p' to print, or 'a' to abort: ") - hFlush stdout - (getChar <* putStrLn "") >>= \case - 'c' -> pure True - 'a' -> pure False - 'p' -> do - jobs <- jobQueueJobs job_queue - Foldable.forM_ (jobCommands <$> jobs) $ - (\(c:|cs) -> do - putStrLn ("- " ++ c) - mapM_ (putStrLn . (" " ++)) cs) - prompt - _ -> prompt) - hSetBuffering stdin LineBuffering + -- The second concurrent source of input: the result of the currently- + -- running job, if any. + running_job :: TMVar (Job, Async ()) <- newEmptyTMVarIO - unless continue $ do - n' <- jobQueueLength job_queue - clearJobQueue job_queue - putStrLn (red ("Aborted " ++ show n' ++ " job(s).")) + let runJobAsync :: Job -> IO () + runJobAsync job = do + putStrLn ("\n" <> cyan (showFileEvent (jobEvent job))) + a <- async (runJob job) + atomically (putTMVar running_job (job, a)) - race_ enqueue_thread dequeue_thread + forever $ do + let input1 :: STM Input + input1 = JobToEnqueue <$> readTQueue all_job_events -watchTree - :: forall m a. - MonadResource m - => FilePath -> Stream (Of FileEvent) m a + input2 :: STM Input + input2 = do + (job, a) <- takeTMVar running_job + result <- waitCatchSTM a + pure (JobResult job (either Just (const Nothing) result)) + + input3 :: STM Input + input3 = + isEmptyTMVar running_job >>= \case + True -> JobToRun <$> readTQueue jobs_to_run + False -> retry + + atomically (input1 <|> input2 <|> input3) >>= \case + -- A job event occurred. If it's equal to the running job, cancel it + -- (it will be restarted when we process its ThreadKilled result). + -- Otherwise, enqueue it if it doesn't already exist. + JobToEnqueue job -> + atomically (tryReadTMVar running_job) >>= \case + Just (job', a) | job == job' -> do + -- Slightly hacky here: replace the existing job with the new + -- one, because although they contain the same commands, when + -- we restart the job, we want to print the newer 'FileEvent', + -- which may be different. + _ <- atomically (swapTMVar running_job (job, a)) + cancel a + _ -> + atomically $ + elemTQueue jobs_to_run job >>= \case + True -> pure () + False -> writeTQueue jobs_to_run job + + JobResult job (Just ex) -> do + case fromException ex of + -- The currently-running job died via ThreadKilled. We will + -- assume we 'canceled' it to restart it. + Just ThreadKilled -> runJobAsync job + + -- The currently-running job died via some other means. We don't + -- want the output to get lost, so we'll just empty the job + -- queue for simplicity. + _ -> do + putStrLn (prettyPrintException ex) + + let exhaustJobsToRun :: STM () + exhaustJobsToRun = + tryReadTQueue jobs_to_run >>= \case + Nothing -> pure () + Just _ -> exhaustJobsToRun + + atomically exhaustJobsToRun + + -- Job ended successfully! + JobResult _ Nothing -> pure () + + JobToRun job -> runJobAsync job + + race_ (runManaged enqueue_thread) dequeue_thread + +eventCommands :: [Rule] -> FileEvent -> IO [ShellCommand] +eventCommands rules event = concat <$> mapM go rules + where + go :: Rule -> IO [ShellCommand] + go rule = + case (patternMatch, excludeMatch) of + -- Pattern doesn't match + ([], _) -> pure [] + -- Pattern matches, but so does exclude pattern + (_, True) -> pure [] + -- Pattern matches, and exclude pattern doesn't! + (xs, False) -> mapM (instantiateTemplate xs) (ruleTemplates rule) + + where + patternMatch :: [ByteString] + patternMatch = + case match (rulePattern rule) (fileEventPath event) of + [] -> [] + xs:_ -> xs + + excludeMatch :: Bool + excludeMatch = + case ruleExclude rule of + Nothing -> False + Just exclude -> match exclude (fileEventPath event) + +watchTree :: forall a. FilePath -> Stream (Of FileEvent) Managed a watchTree target = do cwd <- liftIO getCurrentDirectory @@ -152,7 +251,7 @@ config = FSNotify.defaultConfig { FSNotify.confDebounce = FSNotify.Debounce 0.1 } - stream :: Stream (Of FSNotify.Event) m a + stream :: Stream (Of FSNotify.Event) Managed a stream = FSNotify.watchTree config target (const True) S.for stream (\case @@ -163,6 +262,13 @@ go :: FilePath -> FilePath -> ByteString go cwd path = packBS (makeRelative cwd path) +prettyPrintException :: SomeException -> String +prettyPrintException ex = + case fromException ex of + Just ExitSuccess -> red (printf "Failure ✗ (0)") + Just (ExitFailure code) -> red (printf "Failure ✗ (%d)" code) + Nothing -> red (show ex) + -------------------------------------------------------------------------------- -- Parse a list of rules from an rcfile. @@ -173,12 +279,20 @@ then decodeFileEither sosrc >>= \case Left err -> do - putStrLn ("Error parsing " ++ show sosrc ++ ":\n" ++ prettyPrintParseException err) + putStrLn ("Error parsing " ++ show sosrc ++ ":\n" ++ + prettyPrintParseException err) exitFailure Right (raw_rules :: [RawRule]) -> do - rules <- runSos (mapM buildRawRule raw_rules) + rules <- mapM buildRawRule raw_rules putStrLn (case length raw_rules of 1 -> "Found 1 rule in " ++ show sosrc n -> "Found " ++ show n ++ " rules in " ++ show sosrc) pure (concat rules) else pure [] + +-------------------------------------------------------------------------------- +-- Orphan instances + +instance MonadThrow Managed where + throwM :: Exception e => e -> Managed a + throwM e = managed (\_ -> throwM e) diff --git a/src/Control/Concurrent/STM/TQueue/Extra.hs b/src/Control/Concurrent/STM/TQueue/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TQueue/Extra.hs @@ -0,0 +1,153 @@ +-- Source copied from Control.Concurrent.STM.TQueue. Exposes one additional +-- function (that can't be efficiently implemented with the existing API): +-- +-- elemTQueue :: Eq a => TQueue a -> a -> STM Bool +-- + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM.TQueue +-- Copyright : (c) The University of Glasgow 2012 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- A 'TQueue' is like a 'TChan', with two important differences: +-- +-- * it has faster throughput than both 'TChan' and 'Chan' (although +-- the costs are amortised, so the cost of individual operations +-- can vary a lot). +-- +-- * it does /not/ provide equivalents of the 'dupTChan' and +-- 'cloneTChan' operations. +-- +-- The implementation is based on the traditional purely-functional +-- queue representation that uses two lists to obtain amortised /O(1)/ +-- enqueue and dequeue operations. +-- +-- @since 2.4 +----------------------------------------------------------------------------- + +module Control.Concurrent.STM.TQueue.Extra ( + -- * TQueue + TQueue, + newTQueue, + newTQueueIO, + readTQueue, + tryReadTQueue, + peekTQueue, + tryPeekTQueue, + writeTQueue, + unGetTQueue, + isEmptyTQueue, + elemTQueue + ) where + +import GHC.Conc + +import Data.Typeable (Typeable) + +-- | 'TQueue' is an abstract type representing an unbounded FIFO channel. +-- +-- @since 2.4 +data TQueue a = TQueue {-# UNPACK #-} !(TVar [a]) + {-# UNPACK #-} !(TVar [a]) + deriving Typeable + +instance Eq (TQueue a) where + TQueue a _ == TQueue b _ = a == b + +-- |Build and returns a new instance of 'TQueue' +newTQueue :: STM (TQueue a) +newTQueue = do + read <- newTVar [] + write <- newTVar [] + return (TQueue read write) + +-- |@IO@ version of 'newTQueue'. This is useful for creating top-level +-- 'TQueue's using 'System.IO.Unsafe.unsafePerformIO', because using +-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't +-- possible. +newTQueueIO :: IO (TQueue a) +newTQueueIO = do + read <- newTVarIO [] + write <- newTVarIO [] + return (TQueue read write) + +-- |Write a value to a 'TQueue'. +writeTQueue :: TQueue a -> a -> STM () +writeTQueue (TQueue _read write) a = do + listend <- readTVar write + writeTVar write (a:listend) + +-- |Read the next value from the 'TQueue'. +readTQueue :: TQueue a -> STM a +readTQueue (TQueue read write) = do + xs <- readTVar read + case xs of + (x:xs') -> do writeTVar read xs' + return x + [] -> do ys <- readTVar write + case ys of + [] -> retry + _ -> case reverse ys of + [] -> error "readTQueue" + (z:zs) -> do writeTVar write [] + writeTVar read zs + return z + +-- | A version of 'readTQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTQueue :: TQueue a -> STM (Maybe a) +tryReadTQueue c = fmap Just (readTQueue c) `orElse` return Nothing + +-- | Get the next value from the @TQueue@ without removing it, +-- retrying if the channel is empty. +peekTQueue :: TQueue a -> STM a +peekTQueue c = do + x <- readTQueue c + unGetTQueue c x + return x + +-- | A version of 'peekTQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryPeekTQueue :: TQueue a -> STM (Maybe a) +tryPeekTQueue c = do + m <- tryReadTQueue c + case m of + Nothing -> return Nothing + Just x -> do + unGetTQueue c x + return m + +-- |Put a data item back onto a channel, where it will be the next item read. +unGetTQueue :: TQueue a -> a -> STM () +unGetTQueue (TQueue read _write) a = do + xs <- readTVar read + writeTVar read (a:xs) + +-- |Returns 'True' if the supplied 'TQueue' is empty. +isEmptyTQueue :: TQueue a -> STM Bool +isEmptyTQueue (TQueue read write) = do + xs <- readTVar read + case xs of + (_:_) -> return False + [] -> do ys <- readTVar write + case ys of + [] -> return True + _ -> return False + +elemTQueue :: Eq a => TQueue a -> a -> STM Bool +elemTQueue (TQueue read write) a = do + xs <- readTVar read + ys <- readTVar write + return (elem a xs || elem a ys) diff --git a/src/Sos.hs b/src/Sos.hs deleted file mode 100644 --- a/src/Sos.hs +++ /dev/null @@ -1,76 +0,0 @@ -module Sos - ( Sos - , runSos - , sosEnqueueJobs - , module Sos.Exception - , module Sos.FileEvent - , module Sos.Job - , module Sos.JobQueue - , module Sos.Rule - , module Sos.Template - ) where - -import Sos.Exception -import Sos.FileEvent -import Sos.Job -import Sos.JobQueue -import Sos.Rule -import Sos.Template - -import Control.Applicative -import Control.Monad.Except -import Control.Monad.Trans.Resource -import Data.List.NonEmpty (NonEmpty(..)) -import Streaming -import System.Exit -import Text.Regex.TDFA (match) - -import qualified Streaming.Prelude as S - - -type Sos a = ResourceT (ExceptT SosException IO) a - --- | Run an 'Sos' action in IO, exiting if any 'SosException's are thrown. -runSos :: Sos a -> IO a -runSos act = - runExceptT (runResourceT act) >>= \case - Left err -> do - print err - exitFailure - Right x -> return x - --- | Enqueue jobs on the given job queue resulting from to apply the given --- rules to each emitted file event from the given stream. This function --- returns when the stream is exhausted. -sosEnqueueJobs - :: (Applicative m, MonadError SosException m, MonadResource m) - => [Rule] - -> Stream (Of FileEvent) m a - -> JobQueue - -> m a -sosEnqueueJobs rules events queue = - S.mapM_ - (\(event, cmds) -> liftIO (enqueueJob event cmds queue)) - (jobStream rules events) - -jobStream - :: forall m a. - (Applicative m, MonadError SosException m) - => [Rule] - -> Stream (Of FileEvent) m a - -> Stream (Of (FileEvent, NonEmpty ShellCommand)) m a -jobStream rules events = - S.for events - (\event -> - lift (commands event) >>= \case - [] -> pure () - (c:cs) -> S.yield (event, c :| cs)) - where - commands :: FileEvent -> m [ShellCommand] - commands event = concat <$> mapM go rules - where - go :: Rule -> m [ShellCommand] - go rule = - case match (ruleRegex rule) (fileEventPath event) of - [] -> pure [] - (xs:_) -> mapM (instantiateTemplate xs) (ruleTemplates rule) diff --git a/src/Sos/Exception.hs b/src/Sos/Exception.hs --- a/src/Sos/Exception.hs +++ b/src/Sos/Exception.hs @@ -4,8 +4,9 @@ import Sos.Utils +import Control.Exception (Exception) import Data.ByteString (ByteString) - +import Data.Typeable (Typeable) data SosException -- Error compiling the given regex. @@ -20,7 +21,7 @@ [Either Int ByteString] -- template [ByteString] -- captured variables String -- string reason for failure - deriving Eq + deriving (Eq, Typeable) instance Show SosException where show (SosRegexException pattrn err) = @@ -35,3 +36,5 @@ (\case Left n -> '\\' : show n Right bs -> unpackBS bs) + +instance Exception SosException diff --git a/src/Sos/FileEvent.hs b/src/Sos/FileEvent.hs --- a/src/Sos/FileEvent.hs +++ b/src/Sos/FileEvent.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE LambdaCase #-} - module Sos.FileEvent ( FileEvent(..) , fileEventPath + , showFileEvent ) where +import Sos.Utils + import Data.ByteString (ByteString) +import Data.Monoid ((<>)) data FileEvent = FileAdded ByteString @@ -15,3 +17,8 @@ fileEventPath = \case FileAdded path -> path FileModified path -> path + +showFileEvent :: FileEvent -> String +showFileEvent = \case + FileAdded path -> unpackBS ("Added: " <> path) + FileModified path -> unpackBS ("Modified: " <> path) diff --git a/src/Sos/Job.hs b/src/Sos/Job.hs --- a/src/Sos/Job.hs +++ b/src/Sos/Job.hs @@ -1,106 +1,128 @@ +{-# LANGUAGE CPP #-} + module Sos.Job - ( Job(jobEvent, jobCommands) - , JobResult(..) + ( Job(..) , ShellCommand - , newJob , runJob - , restartJob - , unrestartJob - , shouldRestartJob ) where import Sos.FileEvent import Sos.Utils -import Control.Applicative -import Control.Concurrent.STM +import Control.Concurrent.MVar (readMVar) import Control.Exception -import Control.Monad -import Data.List.NonEmpty (NonEmpty) +import Data.Function (on) +import Data.List.NonEmpty (NonEmpty) import Data.Monoid import System.Exit +import System.IO +import System.IO.Error (tryIOError) +import System.Posix.Process (getProcessGroupID, getProcessGroupIDOf) +import System.Posix.Signals + (Handler(Ignore), Signal, installHandler, sigTERM, sigTTOU, + signalProcessGroup) +import System.Posix.Terminal (setTerminalProcessGroupID) +import System.Posix.Types (ProcessGroupID) import System.Process +import System.Process.Internals (ProcessHandle__(OpenHandle), phandle) import Text.Printf import qualified Data.List.NonEmpty as NonEmpty - type ShellCommand = String - -data JobResult = JobSuccess | JobFailure - - --- | A 'Job' is an interruptible list of shell commands to run. +-- | A 'Job' is a list of shell commands to run, along with the 'FileEvent' that +-- triggered the job. data Job = Job - { jobEvent :: FileEvent - -- ^ Event that triggered this job. - , jobCommands :: NonEmpty ShellCommand - -- ^ The list of shell commands to run. - , jobRestart :: TMVar () - -- ^ A TMVar that, when written to, indicates this job should be - -- immediately canceled and restarted. + { jobEvent :: FileEvent -- ^ Event that triggered this job. + , jobCommands :: NonEmpty ShellCommand -- ^ The list of shell commands to run. } -newJob :: FileEvent -> NonEmpty ShellCommand -> STM Job -newJob event cmds = do - tmvar <- newEmptyTMVar - pure (Job event cmds tmvar) - -restartJob :: Job -> STM () -restartJob job = void (tryPutTMVar (jobRestart job) ()) - --- | Clear any previous restart "ping"s that were sent to this job while it was --- sitting in the job queue (not at the front). -unrestartJob :: Job -> STM () -unrestartJob = void . tryTakeTMVar . jobRestart - --- | An STM action that returns when this job should be restarted, and retries --- otherwise. -shouldRestartJob :: Job -> STM () -shouldRestartJob = readTMVar . jobRestart +-- | Non-stanard Eq instance: Job equality compares only the shell commands it's +-- associated with. +instance Eq Job where + (==) = (==) `on` jobCommands -- | Run a Job's list of shell commands sequentially. If a command returns --- ExitFailure, or an exception is thrown, don't run the rest (but also don't --- propagate the exception). Return whether or not all commands completed --- successfully. -runJob :: Job -> IO JobResult +-- ExitFailure, or an exception is thrown, propagate the exception. +runJob :: Job -> IO () runJob (NonEmpty.toList . jobCommands -> cmds0) = go 1 cmds0 where - go :: Int -> [ShellCommand] -> IO JobResult - go _ [] = pure JobSuccess + go :: Int -> [ShellCommand] -> IO () + go _ [] = pure () go n (cmd:cmds) = do putStrLn (magenta (printf "[%d/%d] " n (length cmds0)) <> cmd) - let acquire :: IO ProcessHandle - acquire = do - (_, _, _, ph) <- createProcess (shell cmd) - pure ph + let flushStdin :: IO () + flushStdin = + hReady stdin >>= \case + True -> getLine >> flushStdin + False -> pure () - try (bracket acquire terminateProcess waitForProcess) >>= \case + flushStdin + + try (runForegroundProcess (shell cmd)) >>= \case Left (ex :: SomeException) -> do - -- We expect to get ThreadKilled exceptions when we get canceled and - -- restarted. Any other exception would be bizarre; just print it and - -- move on. - case fromException ex of - Just ThreadKilled -> - case length cmds0 of - -- If this was a one-command job, just print that it's been - -- canceled. Otherwise, print a little graphic showing how much - -- of the job was completed before being restarted - 1 -> putStrLn (yellow ("Restarting job: " ++ cmd)) - _ -> do - let (xs, ys) = splitAt (n-1) cmds0 - putStrLn (yellow "Restarting job:") - mapM_ (putStrLn . yellow . printf "[✓] %s") xs - mapM_ (putStrLn . yellow . printf "[ ] %s") ys - _ -> putStrLn (red ("Exception: " ++ show ex)) - pure JobFailure + case fromException ex of + Just ThreadKilled -> do + putStrLn (yellow "Job interrupted ✗") + throwIO ThreadKilled + _ -> do + putStrLn (red (show ex)) + throwIO ex Right ExitSuccess -> do putStrLn (green "Success ✓") go (n+1) cmds - Right (ExitFailure c) -> do - putStrLn (red (printf "Failure ✗ (%d)" c)) - pure JobFailure + Right (ExitFailure c) -> + throwIO (ExitFailure c) + +#ifdef mingw32_HOST_OS + +runForegroundProcess :: CreateProcess -> IO ExitCode +runForegroundProcess c = + bracket acquire release waitForProcess + where + acquire :: IO ProcessHandle + acquire = do + (_, _, _, ph) <- createProcess c { create_group = True } + pure ph + + release :: ProcessHandle -> IO () + release ph = do + _ <- tryIOError (interruptProcessGroupOf ph) + terminateProcess ph + +#else + +runForegroundProcess :: CreateProcess -> IO ExitCode +runForegroundProcess c = + bracket acquire release (\(ph, _) -> waitForProcess ph) + where + -- Create a process (inheriting all file descriptors) in a new process group + -- and give it terminal access. + acquire :: IO (ProcessHandle, ProcessGroupID) + acquire = do + (_, _, _, ph) <- createProcess (c { create_group = True }) + readMVar (phandle ph) >>= \case + OpenHandle pid -> do + pgid <- getProcessGroupIDOf pid + setTerminalProcessGroupID 0 pgid + pure (ph, pgid) + _ -> error "Sos.Job.runForegroundProcess: unexpected process handle" + + -- Terminate a process and take back control of the terminal. + release :: (ProcessHandle, ProcessGroupID) -> IO () + release (_, pgid) = do + _ <- tryIOError (signalProcessGroup sigTERM pgid) + getProcessGroupID >>= ignoring sigTTOU . setTerminalProcessGroupID 0 + + ignoring :: Signal -> IO a -> IO a + ignoring sig act = + bracket + (installHandler sig Ignore Nothing) + (\handler -> installHandler sig handler Nothing) + (\_ -> act) + +#endif diff --git a/src/Sos/JobQueue.hs b/src/Sos/JobQueue.hs deleted file mode 100644 --- a/src/Sos/JobQueue.hs +++ /dev/null @@ -1,104 +0,0 @@ -module Sos.JobQueue - ( JobQueue - , newJobQueue - , clearJobQueue - , jobQueueLength - , jobQueueJobs - , enqueueJob - , dequeueJob - ) where - -import Sos.FileEvent -import Sos.Job -import Sos.Utils - -import Control.Applicative -import Control.Concurrent.Async -import Control.Concurrent.STM -import Data.Foldable (find) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Monoid -import Data.Sequence (Seq, ViewL(..), (|>), viewl) - -import qualified Data.Sequence as Sequence - --- | A 'JobQueue' is a mutable linked list of jobs. The job at the head of the --- list is assumed to be currently running, however, it is left in the list so --- it can be interrupted and restarted. -newtype JobQueue = JobQueue (TVar (Seq Job)) - -newJobQueue :: IO JobQueue -newJobQueue = JobQueue <$> newTVarIO mempty - -clearJobQueue :: JobQueue -> IO () -clearJobQueue (JobQueue queue) = atomically (writeTVar queue mempty) - -jobQueueLength :: JobQueue -> IO Int -jobQueueLength queue = Sequence.length <$> jobQueueJobs queue - -jobQueueJobs :: JobQueue -> IO (Seq Job) -jobQueueJobs (JobQueue queue_tv) = atomically (readTVar queue_tv) - -enqueueJob :: FileEvent -> NonEmpty ShellCommand -> JobQueue -> IO () -enqueueJob event cmds (JobQueue queue_tv) = atomically $ do - queue <- readTVar queue_tv - - case find (\j -> jobCommands j == cmds) queue of - -- If the job is not already enqueued, enqueue it. - Nothing -> do - job <- newJob event cmds - writeTVar queue_tv (queue |> job) - -- Otherwise, if it's already been enqueued, put into its reset var. - -- This should only have an effect on the currently running job. - Just job -> restartJob job - --- | Run the first job in the job queue, restarting it if signaled to do so. --- When this function returns, the job is popped off the job queue, and its --- result is returned. -dequeueJob :: JobQueue -> IO JobResult -dequeueJob (JobQueue queue_tv) = do - -- Read the first job, but don't actually pop it off of the queue - job <- atomically $ do - queue <- readTVar queue_tv - case viewl queue of - j :< _ -> do - unrestartJob j - pure j - _ -> retry - - putStrLn ("\n" <> cyan (showFileEvent (jobEvent job))) - - a <- async (runJob job) - - let doRunJob :: STM JobResult - doRunJob = do - r <- waitSTM a - -- seqTail is safe here because this is the only function that pops - -- jobs off of the job queue, and we already saw one job in the queue - -- above. - modifyTVar' queue_tv seqTail - pure r - - atomically (doRunJob <|||> shouldRestartJob job) >>= \case - -- Commands finished either successfully or unsuccessfully. - Left result -> pure result - - -- Another filesystem event triggered this list of commands - -- to be run again - cancel the previous run and start over. - Right () -> do - cancel a - _ <- waitCatch a - dequeueJob (JobQueue queue_tv) - --------------------------------------------------------------------------------- - -seqTail :: Seq a -> Seq a -seqTail s = - case viewl s of - _ :< xs -> xs - _ -> error "seqTail: empty sequence" - -showFileEvent :: FileEvent -> String -showFileEvent = \case - FileAdded path -> unpackBS ("Added: " <> path) - FileModified path -> unpackBS ("Modified: " <> path) diff --git a/src/Sos/Rule.hs b/src/Sos/Rule.hs --- a/src/Sos/Rule.hs +++ b/src/Sos/Rule.hs @@ -10,14 +10,17 @@ import Sos.Template import Control.Applicative -import Control.Monad.Except +import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson.Types -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) +import Data.ByteString.Internal (c2w) import Data.Either -import Data.Text (Text) +import Data.Foldable (asum) +import Data.Text (Text) import Text.Regex.TDFA import Text.Regex.TDFA.ByteString (compile) +import qualified Data.ByteString as ByteString (intercalate, singleton) import qualified Data.Text.Encoding as Text @@ -25,11 +28,12 @@ type RawPattern = ByteString --- A Rule is a regex paired with a list of templates to execute on files --- that match the regex. Any mismatching of captured variables with the --- associated templates will be caught at runtime. +-- A Rule is a pattern to match, optional pattern to exclude, and a list of +-- templates to execute on files that match the regex. -- --- For example, this definition from a .sosrc yaml file is incorrect: +-- Any mismatching of captured variables with the associated templates will be +-- caught at runtime. For example, this definition from a .sosrc yaml file is +-- incorrect: -- -- - pattern: .*.c -- - commands: @@ -38,63 +42,89 @@ -- because there is only one capture variable, and it has with index 0. -- data Rule = Rule - { ruleRegex :: Regex -- Compiled regex of command pattern. - , ruleTemplates :: [Template] -- Command template. + { rulePattern :: Regex -- Compiled regex of file pattern. + , ruleExclude :: Maybe Regex -- Compiled regex of file patterns to exclude. + , ruleTemplates :: [Template] -- Command template. } --- Build a 'Rule' from a 'RawPattern' and a list of 'RawTemplate' by compiling --- the pattern regex and parsing each template. +-- Build a 'Rule' from a 'RawPattern', a list of 'RawPattern' (patterns to +-- exclude), and a list of 'RawTemplate' by: +-- +-- - Compiling the pattern regex +-- - Compiling the exclude regexes combined with || +-- - Parsing each template. +-- buildRule - :: forall m. MonadError SosException m - => RawPattern - -> [RawTemplate] - -> m Rule -buildRule pattrn templates0 = do + :: forall m. + MonadThrow m + => RawPattern -> [RawPattern] -> [RawTemplate] -> m Rule +buildRule pattrn excludes templates0 = do templates <- mapM parseTemplate templates0 - -- Improve performance for patterns with no capture groups. - let (comp_opt, exec_opt) = - case concatMap lefts templates of - [] -> ( CompOption - { caseSensitive = True - , multiline = False - , rightAssoc = True - , newSyntax = True - , lastStarGreedy = True - } - , ExecOption - { captureGroups = False } - ) - _ -> (defaultCompOpt, defaultExecOpt) - regex <- - case compile comp_opt exec_opt pattrn of - Left err -> throwError (SosRegexException pattrn err) - Right x -> return x + -- Improve performance for patterns with no capture groups. + case concatMap lefts templates of + [] -> + compileRegex + (CompOption + { caseSensitive = True + , multiline = False + , rightAssoc = True + , newSyntax = True + , lastStarGreedy = True + }) + (ExecOption + { captureGroups = False }) + pattrn + _ -> compileRegex defaultCompOpt defaultExecOpt pattrn - return (Rule regex templates) + case excludes of + [] -> + pure (Rule + { rulePattern = regex + , ruleExclude = Nothing + , ruleTemplates = templates + }) + _ -> do + exclude <- + compileRegex defaultCompOpt defaultExecOpt + (ByteString.intercalate (ByteString.singleton (c2w '|')) excludes) + pure (Rule + { rulePattern = regex + , ruleExclude = Just exclude + , ruleTemplates = templates + }) + where + compileRegex :: CompOption -> ExecOption -> RawPattern -> m Regex + compileRegex co eo patt = + case compile co eo patt of + Left err -> throwM (SosRegexException patt err) + Right x -> pure x -- A "raw" Rule that is post-processed after being parsed from a yaml --- file. Namely, the regex is compiled and the commands are parsed into --- templates. -data RawRule = RawRule [RawPattern] [RawTemplate] +-- file. +data RawRule = RawRule [RawPattern] [RawPattern] [RawTemplate] instance FromJSON RawRule where - parseJSON (Object o) = RawRule <$> parsePatterns <*> parseCommands + parseJSON (Object o) = + RawRule <$> parsePatterns <*> parseExcludes <*> parseCommands where parsePatterns :: Parser [RawPattern] - parsePatterns = fmap go (o .: "pattern" <|> o .: "patterns") + parsePatterns = go ["pattern", "patterns"] + parseExcludes :: Parser [RawPattern] + parseExcludes = go ["exclude", "excludes", "excluding"] <|> pure [] + parseCommands :: Parser [RawTemplate] - parseCommands = fmap go (o .: "command" <|> o .: "commands") + parseCommands = go ["command", "commands"] - go :: OneOrList Text -> [ByteString] - go = map Text.encodeUtf8 . listify + go :: [Text] -> Parser [ByteString] + go = fmap (map Text.encodeUtf8 . listify) . asum . map (o .:) parseJSON v = typeMismatch "command" v -buildRawRule :: forall m. MonadError SosException m => RawRule -> m [Rule] -buildRawRule (RawRule patterns templates) = - mapM (\pattrn -> buildRule pattrn templates) patterns +buildRawRule :: MonadThrow m => RawRule -> m [Rule] +buildRawRule (RawRule patterns excludes templates) = + mapM (\pattrn -> buildRule pattrn excludes templates) patterns -------------------------------------------------------------------------------- diff --git a/src/Sos/Template.hs b/src/Sos/Template.hs --- a/src/Sos/Template.hs +++ b/src/Sos/Template.hs @@ -6,17 +6,17 @@ ) where import Sos.Exception -import Sos.Job (ShellCommand) +import Sos.Job (ShellCommand) import Sos.Utils import Control.Applicative -import Control.Monad.Except -import Data.ByteString (ByteString) +import Control.Monad.Catch (MonadThrow, throwM) +import Data.ByteString (ByteString) import Data.Monoid import Text.ParserCombinators.ReadP -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as LText +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Builder as LText @@ -38,11 +38,11 @@ type Template = [Either Int ByteString] -parseTemplate :: MonadError SosException m => RawTemplate -> m Template +parseTemplate :: MonadThrow m => RawTemplate -> m Template parseTemplate raw_template = case readP_to_S parser (unpackBS raw_template) of - [(template, "")] -> return template - _ -> throwError (SosCommandParseException raw_template) + [(template, "")] -> pure template + _ -> throwM (SosCommandParseException raw_template) where parser :: ReadP Template parser = some (capturePart <|||> textPart) <* eof @@ -63,10 +63,7 @@ -- instantiateTemplate ["ONE", "TWO"] [Right "foo", Left 0, Right "bar", Left 1] == "fooONEbarTWO" -- instantiateTemplate - :: forall m. MonadError SosException m - => [ByteString] - -> Template - -> m ShellCommand + :: forall m. MonadThrow m => [ByteString] -> Template -> m ShellCommand instantiateTemplate vars0 template0 = go 0 vars0 template0 where go :: Int -> [ByteString] -> Template -> m ShellCommand @@ -74,8 +71,8 @@ case flattenTemplate template of Left n -> let err = "uninstantiated template variable: \\" ++ show n - in throwError (SosCommandApplyException template0 vars0 err) - Right x -> return x + in throwM (SosCommandApplyException template0 vars0 err) + Right x -> pure x go n (t:ts) template = go (n+1) ts (map f template) where f :: Either Int ByteString -> Either Int ByteString diff --git a/src/Sos/Utils.hs b/src/Sos/Utils.hs --- a/src/Sos/Utils.hs +++ b/src/Sos/Utils.hs @@ -10,6 +10,7 @@ (<|||>) :: Alternative f => f a -> f b -> f (Either a b) fa <|||> fb = Left <$> fa <|> Right <$> fb +infixl 3 <|||> -- The proper way to make a ByteString from a String - Data.ByteString.Char8 -- will snip each Char to 8 bits. diff --git a/src/System/FSNotify/Streaming.hs b/src/System/FSNotify/Streaming.hs --- a/src/System/FSNotify/Streaming.hs +++ b/src/System/FSNotify/Streaming.hs @@ -11,18 +11,28 @@ ) where import Control.Concurrent.Chan +import Control.Exception (bracket) import Control.Monad -import Control.Monad.Trans.Resource +import Control.Monad.Managed import Streaming import Streaming.Prelude (yield) import System.FSNotify watchTree - :: MonadResource m - => WatchConfig -> FilePath -> (Event -> Bool) -> Stream (Of Event) m a + :: WatchConfig -> FilePath -> (Event -> Bool) -> Stream (Of Event) Managed a watchTree config path predicate = do - chan <- liftIO newChan - (_, manager) <- allocate (startManagerConf config) stopManager - _ <- allocate (watchTreeChan manager path predicate chan) id + chan <- liftIO newChan + manager <- lift (managed (withManagerConf config)) + + lift (managed_ (withTreeChan manager path predicate chan)) + forever (liftIO (readChan chan) >>= yield) + +withTreeChan + :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO a -> IO a +withTreeChan manager path predicate chan act = + bracket + (watchTreeChan manager path predicate chan) + id + (\_ -> act) diff --git a/steeloverseer.cabal b/steeloverseer.cabal --- a/steeloverseer.cabal +++ b/steeloverseer.cabal @@ -1,14 +1,16 @@ --- This file has been generated from package.yaml by hpack version 0.14.1. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: e0468a343c9d01e573c139ad9fedc221aecdc503cfb35a1e36094f14f2b4e93c name: steeloverseer -version: 2.0.1.0 +version: 2.0.2.0 cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE -maintainer: efsubenovex@gmail.com +maintainer: schell@takt.com stability: stable homepage: https://github.com/schell/steeloverseer#readme bug-reports: https://github.com/schell/steeloverseer/issues @@ -27,64 +29,70 @@ library exposed-modules: - Sos + Control.Concurrent.STM.TQueue.Extra Sos.Exception Sos.FileEvent Sos.Job - Sos.JobQueue Sos.Rule Sos.Template Sos.Utils System.FSNotify.Streaming + other-modules: + Paths_steeloverseer default-language: Haskell2010 build-depends: - async >= 2.0 - , base >= 4.0 && < 5.0 - , bytestring >= 0.10 - , fsnotify >= 0.2 - , mtl >= 2.2 - , regex-tdfa >= 1.2 - , resourcet >= 1.0 - , semigroups >= 0.16 - , stm >= 2.4 - , streaming >= 0.1.0 && < 0.1.5 - , text >= 1.2 - , yaml >= 0.8 - , aeson >= 0.8 - , ansi-terminal >= 0.6.2 - , containers >= 0.5 - , process >= 1.2 + aeson >=0.8 + , ansi-terminal >=0.6.2 + , async >=2.0 + , base >=4.0 && <5.0 + , bytestring >=0.10 + , containers >=0.5 + , exceptions + , fsnotify >=0.2 + , managed >=1.0.1 + , mtl >=2.2 + , process >=1.6 && <1.7 + , regex-tdfa >=1.2 + , semigroups >=0.16 + , stm >=2.4 + , streaming >=0.1.0 && <0.3 + , text >=1.2 + , unix + , yaml >=0.8 hs-source-dirs: src - default-extensions: BangPatterns DeriveFunctor FlexibleContexts LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns + default-extensions: BangPatterns DeriveDataTypeable DeriveFunctor FlexibleContexts InstanceSigs LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns ghc-options: -Wall executable sos main-is: Main.hs build-depends: - async >= 2.0 - , base >= 4.0 && < 5.0 - , bytestring >= 0.10 - , fsnotify >= 0.2 - , mtl >= 2.2 - , regex-tdfa >= 1.2 - , resourcet >= 1.0 - , semigroups >= 0.16 - , stm >= 2.4 - , streaming >= 0.1.0 && < 0.1.5 - , text >= 1.2 - , yaml >= 0.8 + async >=2.0 + , base >=4.0 && <5.0 + , bytestring >=0.10 + , directory >=1.2 + , exceptions + , filepath >=1.3 + , fsnotify >=0.2 + , managed >=1.0.1 + , mtl >=2.2 + , optparse-applicative >=0.11 + , regex-tdfa >=1.2 + , semigroups >=0.16 , steeloverseer - , directory >= 1.2 - , filepath >= 1.3 - , optparse-applicative >= 0.11 + , stm >=2.4 + , streaming >=0.1.0 && <0.3 + , text >=1.2 + , yaml >=0.8 if os(darwin) build-depends: - hfsevents >= 0.1.3 + hfsevents >=0.1.3 + other-modules: + Paths_steeloverseer default-language: Haskell2010 hs-source-dirs: app - default-extensions: BangPatterns DeriveFunctor FlexibleContexts LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns + default-extensions: BangPatterns DeriveDataTypeable DeriveFunctor FlexibleContexts InstanceSigs LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns ghc-options: -Wall -threaded test-suite spec @@ -92,24 +100,25 @@ main-is: Spec.hs hs-source-dirs: test - default-extensions: BangPatterns DeriveFunctor FlexibleContexts LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns + default-extensions: BangPatterns DeriveDataTypeable DeriveFunctor FlexibleContexts InstanceSigs LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns ghc-options: -Wall build-depends: - async >= 2.0 - , base >= 4.0 && < 5.0 - , bytestring >= 0.10 - , fsnotify >= 0.2 - , mtl >= 2.2 - , regex-tdfa >= 1.2 - , resourcet >= 1.0 - , semigroups >= 0.16 - , stm >= 2.4 - , streaming >= 0.1.0 && < 0.1.5 - , text >= 1.2 - , yaml >= 0.8 - , steeloverseer + async >=2.0 + , base >=4.0 && <5.0 + , bytestring >=0.10 + , exceptions + , fsnotify >=0.2 , hspec + , managed >=1.0.1 + , mtl >=2.2 + , regex-tdfa >=1.2 + , semigroups >=0.16 + , steeloverseer + , stm >=2.4 + , streaming >=0.1.0 && <0.3 + , text >=1.2 + , yaml >=0.8 other-modules: - Sos.JobQueueSpec Sos.TemplateSpec + Paths_steeloverseer default-language: Haskell2010 diff --git a/test/Sos/JobQueueSpec.hs b/test/Sos/JobQueueSpec.hs deleted file mode 100644 --- a/test/Sos/JobQueueSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Sos.JobQueueSpec where - -import Sos.FileEvent -import Sos.JobQueue - -import Test.Hspec - -import qualified Data.List.NonEmpty as NonEmpty - -spec :: Spec -spec = - describe "enqueueJob" $ do - it "enqueues jobs" $ do - queue <- newJobQueue - enqueueJob (FileAdded "foo.txt") (NonEmpty.fromList ["a","b","c"]) queue - enqueueJob (FileAdded "bar.txt") (NonEmpty.fromList ["d","e","f"]) queue - jobQueueLength queue `shouldReturn` 2 - - it "does not double-enqueue" $ do - queue <- newJobQueue - enqueueJob (FileAdded "foo.txt") (NonEmpty.fromList ["a","b","c"]) queue - enqueueJob (FileAdded "bar.txt") (NonEmpty.fromList ["a","b","c"]) queue - jobQueueLength queue `shouldReturn` 1 diff --git a/test/Sos/TemplateSpec.hs b/test/Sos/TemplateSpec.hs --- a/test/Sos/TemplateSpec.hs +++ b/test/Sos/TemplateSpec.hs @@ -1,5 +1,6 @@ module Sos.TemplateSpec where +import Sos.Exception import Sos.Template import Test.Hspec @@ -8,27 +9,27 @@ spec = do describe "parseTemplate" $ do it "fails on the empty string" $ - parseTemplate "" `shouldSatisfy` isLeft + parseTemplate "" `shouldThrow` anySosException it "parses templates" $ do - parseTemplate "hi" `shouldBe` Right [Right "hi"] - parseTemplate "foo bar" `shouldBe` Right [Right "foo bar"] - parseTemplate "\\25" `shouldBe` Right [Left 25] - parseTemplate "gcc \\0" `shouldBe` Right [Right "gcc ", Left 0] + parseTemplate "hi" `shouldReturn` [Right "hi"] + parseTemplate "foo bar" `shouldReturn` [Right "foo bar"] + parseTemplate "\\25" `shouldReturn` [Left 25] + parseTemplate "gcc \\0" `shouldReturn` [Right "gcc ", Left 0] describe "instantiateTemplate" $ do it "ignores capture groups in templates with no captures" $ do - instantiateTemplate [] [Right "z"] `shouldBe` Right "z" - instantiateTemplate ["a"] [Right "z"] `shouldBe` Right "z" - instantiateTemplate ["a","b","c"] [Right "z"] `shouldBe` Right "z" + instantiateTemplate [] [Right "z"] `shouldReturn` "z" + instantiateTemplate ["a"] [Right "z"] `shouldReturn` "z" + instantiateTemplate ["a","b","c"] [Right "z"] `shouldReturn` "z" it "substitutes capture groups" $ do - instantiateTemplate ["a","b","c"] [Left 2, Left 1, Left 0] `shouldBe` Right "cba" + instantiateTemplate ["a","b","c"] [Left 2, Left 1, Left 0] + `shouldReturn` "cba" it "errors when there are not enough capture groups" $ do - instantiateTemplate [] [Left 0] `shouldSatisfy` isLeft - instantiateTemplate ["a"] [Left 1] `shouldSatisfy` isLeft + instantiateTemplate [] [Left 0] `shouldThrow` anySosException + instantiateTemplate ["a"] [Left 1] `shouldThrow` anySosException -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft _ = False +anySosException :: Selector SosException +anySosException = const True