diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,19 +20,23 @@ See `sos --help` to get started: - Steel Overseer 2.0 + Steel Overseer 2.0.1 - Usage: sos [TARGET] [-c|--command COMMAND] [-p|--pattern PATTERN] + Usage: sos [TARGET] [--rcfile ARG] [-c|--command COMMAND] [-p|--pattern PATTERN] A file watcher and development tool. Available options: -h,--help Show this help text - TARGET File or directory to watch for + TARGET Optional file or directory to watch for changes. (default: ".") + --rcfile ARG Optional rcfile to read patterns and commands + from. (default: ".sosrc") -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: .*) +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). @@ -43,8 +47,10 @@ Commands are run left-to-right, and one failed command will halt the entire pipeline. -As a shortcut, we may want to write the above only once and save it in `.sosrc`, which is -an alternative to the command-line interface (yaml syntax): +The RCFile +---------- +As a shortcut, we may want to write the above only once and save it in `.sosrc`, +which is an alternative to the command-line interface (yaml syntax): ```yaml - pattern: src/(.*)\.c @@ -53,29 +59,17 @@ - make test --filter=test/\1_test.c ``` -Then, we only need to run +Then, we only need to run: sos -to start watching the current directory. - -Pipelines of commands are immediately canceled and re-run if a subsequent -filesystem event triggers the *same* list of commands. Otherwise, commands are -are enqueued and run sequentially to keep the terminal output clean and readable. - -For example, we may wish to run `hlint` on any modified `.hs` file: - -```yaml -- pattern: .*\.hs - command: hlint \0 -``` +to start watching the current directory. If you'd like to use multiple rcfiles, +or just don't like the name `.sosrc` you can specify the rcfile on the command +line like so: -We can modify `foo.hs` and trigger `hlint foo.hs` to run. During its execution, -modifying `bar.hs` will *enqueue* `hlint bar.hs`, while modifying `foo.hs` again -will *re-run* `hlint foo.hs`. + sos --rcfile my-rcfile -.sosrc grammar -============== +### Grammar sosrc := [entry] entry := { "pattern" | "patterns" : value | [value] @@ -89,3 +83,20 @@ The .sosrc grammar is somewhat flexible with respect to the command specifications. Both singular and plural keys are allowed, and both strings and lists of strings are allowed for values. + +Pipelining Explaned +------------------- +Pipelines of commands are immediately canceled and re-run if a subsequent +filesystem event triggers the *same* list of commands. Otherwise, commands are +are enqueued and run sequentially to keep the terminal output clean and readable. + +For example, we may wish to run `hlint` on any modified `.hs` file: + +```yaml +- pattern: .*\.hs + command: hlint \0 +``` + +We can modify `foo.hs` and trigger `hlint foo.hs` to run. During its execution, +modifying `bar.hs` will *enqueue* `hlint bar.hs`, while modifying `foo.hs` again +will *re-run* `hlint foo.hs`. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,152 +1,184 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Main where -import Job -import Rule import Sos -import Template +import Sos.Utils +import qualified System.FSNotify.Streaming as FSNotify + +import Control.Concurrent.Async import Control.Monad -import Data.ByteString (ByteString) -import Data.Function +import Control.Monad.Except +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid -import Data.Yaml (decodeFileEither, prettyPrintParseException) -import Prelude hiding (FilePath) +import Data.Yaml (decodeFileEither, prettyPrintParseException) import Options.Applicative +import Streaming import System.Directory import System.Exit import System.FilePath -import System.FSNotify -import Text.Regex.TDFA +import System.IO -import qualified Data.ByteString.Char8 as BS -import qualified Data.List.NonEmpty as NE +import qualified Data.Foldable as Foldable +import qualified Streaming.Prelude as S + version :: String -version = "Steel Overseer 2.0" +version = "Steel Overseer 2.0.1.0" data Options = Options - { optTarget :: FilePath - , optCommands :: [ByteString] - , optPatterns :: [ByteString] - } deriving Show + { optTarget :: FilePath + , optRCFile :: FilePath + , optCommands :: [RawTemplate] + , optPatterns :: [RawPattern] + } deriving Show main :: IO () main = execParser opts >>= main' - where - opts = info (helper <*> optsParser) - ( fullDesc - <> progDesc "A file watcher and development tool." - <> header version ) + where + opts = info (helper <*> optsParser) + ( fullDesc + <> progDesc "A file watcher and development tool." + <> header version ) - optsParser :: Parser Options - optsParser = Options - <$> strArgument - ( help "File or directory to watch for changes." - <> metavar "TARGET" - <> value "." - <> showDefault ) - <*> many (fmap BS.pack (strOption - ( long "command" - <> short 'c' - <> help "Add command to run on file event." - <> metavar "COMMAND" ))) - <*> many (fmap BS.pack (strOption - ( long "pattern" - <> short 'p' - <> help "Add pattern to match on file path. Only relevant if the target is a directory. (default: .*)" - <> metavar "PATTERN" ))) + optsParser :: Parser Options + optsParser = Options + <$> strArgument + ( help "Optional file or directory to watch for changes." + <> metavar "TARGET" + <> value "." + <> showDefault ) + <*> strOption + ( help "Optional rcfile to read patterns and commands from." + <> long "rcfile" + <> value ".sosrc" + <> showDefault ) + <*> many (fmap packBS (strOption + ( long "command" + <> short 'c' + <> help "Add command to run on file event." + <> metavar "COMMAND" ))) + <*> many (fmap packBS (strOption + ( long "pattern" + <> short 'p' + <> help "Add pattern to match on file path. Only relevant if the target is a directory. (default: .*)" + <> metavar "PATTERN" ))) main' :: Options -> IO () main' Options{..} = do - -- Parse .sosrc rules. - rc_rules <- parseSosrc + -- Parse .sosrc rules. + rc_rules <- parseSosrc optRCFile - -- Parse cli rules, where one rule is created per pattern that executes each - -- of commands sequentially. - cli_rules <- do - let patterns = - 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 (\pattern -> buildRule pattern optCommands) patterns) + -- Parse cli rules, where one rule is created per pattern that executes + -- each of @optCommands@ sequentially. + cli_rules <- do + let patterns :: [RawPattern] + patterns = + 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) - (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. - (_, True) -> do - rule <- runSos (buildRule (BS.pack optTarget) optCommands) - pure (takeDirectory optTarget, [rule]) - _ -> do - putStrLn ("Target " ++ optTarget ++ " is not a file or directory.") - exitFailure + (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. + (_, True) -> do + rule <- runSos (buildRule (packBS optTarget) optCommands) + pure (takeDirectory optTarget, [rule]) + _ -> do + putStrLn ("Target " ++ optTarget ++ " is not a file or directory.") + exitFailure - putStrLn "Hit Ctrl+C to quit." + putStrLn "Hit Ctrl+C to quit." - withManager $ \wm -> do - job_queue <- newJobQueue - spawnFileWatcherThread wm job_queue target rules - forever (dequeueJob job_queue >>= runJob job_queue) + job_queue <- newJobQueue -spawnFileWatcherThread :: WatchManager -> JobQueue -> FilePath -> [Rule] -> IO () -spawnFileWatcherThread wm job_queue target rules = do - cwd <- getCurrentDirectory + let enqueue_thread :: IO a + enqueue_thread = + runSos (sosEnqueueJobs rules (watchTree target) job_queue) - let eventRelPath :: Event -> FilePath - eventRelPath event = makeRelative cwd (eventPath event) + -- 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.")) - predicate :: Event -> Bool - predicate event = any (\rule -> match (ruleRegex rule) (eventRelPath event)) rules + 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 - _ <- watchTree wm target predicate $ \event -> do - let path = BS.pack (eventRelPath event) + unless continue $ do + n' <- jobQueueLength job_queue + clearJobQueue job_queue + putStrLn (red ("Aborted " ++ show n' ++ " job(s).")) - commands <- concat <$> mapM (instantiateTemplates path) rules - when (commands /= []) - (enqueueJob (showEvent event cwd) (NE.fromList commands) job_queue) + race_ enqueue_thread dequeue_thread - pure () - where - instantiateTemplates :: ByteString -> Rule -> IO [ShellCommand] - instantiateTemplates path Rule{..} = - case match ruleRegex path of - [] -> pure [] - (captures:_) -> runSos (mapM (instantiateTemplate captures) ruleTemplates) +watchTree + :: forall m a. + MonadResource m + => FilePath -> Stream (Of FileEvent) m a +watchTree target = do + cwd <- liftIO getCurrentDirectory --------------------------------------------------------------------------------- + let config :: FSNotify.WatchConfig + config = FSNotify.defaultConfig + { FSNotify.confDebounce = FSNotify.Debounce 0.1 } --- Parse a list of rules from .sosrc. -parseSosrc :: IO [Rule] -parseSosrc = do - exists <- doesFileExist ".sosrc" - if exists - then - decodeFileEither ".sosrc" >>= \case - Left err -> do - putStrLn ("Error parsing .sosrc:\n" ++ prettyPrintParseException err) - exitFailure - Right (raw_rules :: [RawRule]) -> do - rules <- runSos (mapM buildRawRule raw_rules) - putStrLn (case length raw_rules of - 1 -> "Found 1 rule in .sosrc" - n -> "Found " ++ show n ++ " rules in .sosrc") - pure (concat rules) - else pure [] + stream :: Stream (Of FSNotify.Event) m a + stream = FSNotify.watchTree config target (const True) + S.for stream (\case + FSNotify.Added path _ -> S.yield (FileAdded (go cwd path)) + FSNotify.Modified path _ -> S.yield (FileModified (go cwd path)) + FSNotify.Removed _ _ -> pure ()) + where + go :: FilePath -> FilePath -> ByteString + go cwd path = packBS (makeRelative cwd path) + -------------------------------------------------------------------------------- -showEvent :: Event -> FilePath -> String -showEvent (Added fp _) cwd = "Added: " ++ makeRelative cwd fp -showEvent (Modified fp _) cwd = "Modified: " ++ makeRelative cwd fp -showEvent (Removed fp _) cwd = "Removed: " ++ makeRelative cwd fp +-- Parse a list of rules from an rcfile. +parseSosrc :: FilePath -> IO [Rule] +parseSosrc sosrc = do + exists <- doesFileExist sosrc + if exists + then + decodeFileEither sosrc >>= \case + Left err -> do + putStrLn ("Error parsing " ++ show sosrc ++ ":\n" ++ prettyPrintParseException err) + exitFailure + Right (raw_rules :: [RawRule]) -> do + rules <- runSos (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 [] diff --git a/src/ANSI.hs b/src/ANSI.hs deleted file mode 100644 --- a/src/ANSI.hs +++ /dev/null @@ -1,13 +0,0 @@ -module ANSI where - -import Data.Monoid -import System.Console.ANSI - -colored :: Color -> String -> String -colored c s = color c <> s <> reset - -color :: Color -> String -color c = setSGRCode [SetColor Foreground Dull c] - -reset :: String -reset = setSGRCode [Reset] diff --git a/src/Job.hs b/src/Job.hs deleted file mode 100644 --- a/src/Job.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} - -module Job - ( Job - , JobQueue - , ShellCommand - , newJobQueue - , enqueueJob - , dequeueJob - , runJob - ) where - -import ANSI - -import Control.Applicative -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import Control.Monad.STM -import Data.Function (fix) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Monoid -import Data.Sequence (Seq, ViewL(..), (|>), viewl) -import Lens.Micro hiding (to) -import System.Console.ANSI -import System.Exit -import System.IO -import System.Process -import Text.Printf - -import qualified Data.List.NonEmpty as NE - -type ShellCommand = String - -data Job = Job - { jobHeader :: String - , jobCommands :: NonEmpty ShellCommand - , jobTMVar :: TMVar () - } - -makeJob :: String -> NonEmpty ShellCommand -> STM Job -makeJob header cmds = do - tmvar <- newEmptyTMVar - pure (Job header cmds tmvar) - -jobEquals :: NonEmpty ShellCommand -> Job -> Bool -jobEquals cmds job = cmds == jobCommands job - -data JobQueue - = JobQueue - (TVar (Maybe Job)) -- Currently running job - (TVar (Seq Job)) -- Queue of jobs to run - -newJobQueue :: IO JobQueue -newJobQueue = JobQueue <$> newTVarIO Nothing <*> newTVarIO mempty - -enqueueJob :: String -> NonEmpty ShellCommand -> JobQueue -> IO () -enqueueJob header cmds (JobQueue running_tv queue_tv) = atomically $ - readTVar running_tv >>= \case - Just job | cmds `jobEquals` job -> - restartJob job - _ -> do - queue <- readTVar queue_tv - unless (seqContains jobEquals cmds queue) $ do - new_job <- makeJob header cmds - modifyTVar' queue_tv (|> new_job) - --- | Dequeue a Job from a JobQueue. This assumes that there is no currently --- running job, but does not actually check. -dequeueJob :: JobQueue -> IO Job -dequeueJob (JobQueue running_tv queue_tv) = atomically $ do - queue <- readTVar queue_tv - case viewl queue of - EmptyL -> retry - (job :< jobs) -> do - writeTVar running_tv (Just job) - writeTVar queue_tv jobs - pure job - -runJob :: JobQueue -> Job -> IO () -runJob job_queue@(JobQueue running_tv queue_tv) - job@(Job header cmds tmvar) = do - - putStrLn ("\n" <> colored Cyan header) - - a <- async (runShellCommands (NE.toList cmds)) - - let lhs :: STM (Either SomeException JobResult) - lhs = waitCatchSTM a <* writeTVar running_tv Nothing - - rhs :: STM () - rhs = takeTMVar tmvar - - atomically (lhs <|||> rhs) >>= \case - -- Job threw an exception - a ThreadKilled we are - -- okay with, but anything else we should print to the - -- console. - Left (Left ex) -> - case fromException ex of - Just ThreadKilled -> pure () - _ -> putStrLn (colored Red ("Exception: " ++ show ex)) - - -- Commands finished successfully. - Left (Right JobSuccess) -> pure () - - -- A command failed - if there is another enqueued list - -- of commands to run, prompt the user to continue or - -- abort. - Left (Right JobFailure) -> do - queue <- atomically (readTVar queue_tv) - case length queue of - 0 -> pure () - n -> do - putStrLn (colored Yellow (show n ++ " job(s) still pending.")) - - hSetBuffering stdin NoBuffering - continue <- fix (\prompt -> do - putStr (colored 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 - mapM_ (\(c:|cs) -> do - putStrLn ("- " ++ c) - mapM_ (putStrLn . (" " ++)) cs) - (queue^..traversed.to jobCommands) - prompt - _ -> prompt) - hSetBuffering stdin LineBuffering - - -- Here, it's possible we've reported that - -- `n` jobs were enqueued, but by the time - -- the user decides to abort them, more - -- were added. Oh well, delete them all. - unless continue $ do - n' <- atomically (length <$> swapTVar queue_tv mempty) - putStrLn (colored Red ("Aborted " ++ show n' ++ " job(s).")) - - -- 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 - runJob job_queue job - -restartJob :: Job -> STM () -restartJob job = void (tryPutTMVar (jobTMVar job) ()) - -data JobResult = JobSuccess | JobFailure - --- Run a list of shell commands sequentially. If a command returns ExitFailure, --- don't run the rest. Return whether or not all commands completed --- successfully. -runShellCommands :: [ShellCommand] -> IO JobResult -runShellCommands cmds0 = go 1 cmds0 - where - go :: Int -> [ShellCommand] -> IO JobResult - go _ [] = pure JobSuccess - go n (cmd:cmds) = do - putStrLn (colored Magenta (printf "[%d/%d] " n (length cmds0)) <> cmd) - - let create = (\(_, _, _, ph) -> ph) <$> createProcess (shell cmd) - teardown ph = do - putStrLn (colored Yellow ("Canceling: " ++ cmd)) - terminateProcess ph - bracketOnError create teardown waitForProcess >>= \case - ExitSuccess -> do - putStrLn (colored Green "Success ✓") - go (n+1) cmds - _ -> do - putStrLn (colored Red "Failure ✗") - pure JobFailure - - -seqContains :: (a -> b -> Bool) -> a -> Seq b -> Bool -seqContains _ _ (viewl -> EmptyL) = False -seqContains p x (viewl -> y :< ys) - | p x y = True - | otherwise = seqContains p x ys - --------------------------------------------------------------------------------- - -to :: (s -> a) -> (a -> Const r a) -> s -> Const r s -to f g s = Const (getConst (g (f s))) - -(<|||>) :: Alternative f => f a -> f b -> f (Either a b) -fa <|||> fb = Left <$> fa <|> Right <$> fb diff --git a/src/Rule.hs b/src/Rule.hs deleted file mode 100644 --- a/src/Rule.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Rule - ( Rule(..) - , RawRule(..) - , buildRule - , buildRawRule - ) where - -import Sos -import Template - -import Control.Applicative -import Control.Monad.Except -import Data.Aeson.Types -import Data.ByteString (ByteString) -import Data.Either -import Data.Text (Text) -import Text.Regex.TDFA -import Text.Regex.TDFA.ByteString (compile) - -import qualified Data.Text.Encoding as T - - --- 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. --- --- For example, this definition from a .sosrc yaml file is incorrect: --- --- - pattern: .*.c --- - commands: --- - gcc -c {1} --- --- because there is only one capture variable, and it has with index 0. --- -data Rule = Rule - { rulePattern :: ByteString -- Text from which the regex was compiled. - , ruleRegex :: Regex -- Compiled regex of command pattern. - , ruleTemplates :: [Template] -- Command template. - } - --- Build a Rule from a RawRule by compiling the regex and parsing each Template. -buildRule :: forall m. MonadError SosException m => ByteString -> [ByteString] -> m Rule -buildRule pattern 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 pattern of - Left err -> throwError (SosRegexException pattern err) - Right x -> pure x - - pure (Rule pattern regex templates) - --- 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 - [ByteString] -- patterns - [ByteString] -- commands - -instance FromJSON RawRule where - parseJSON (Object o) = RawRule <$> parsePatterns <*> parseCommands - where - parsePatterns = fmap go (o .: "pattern" <|> o .: "patterns") - parseCommands = fmap go (o .: "command" <|> o .: "commands") - - go :: OneOrList Text -> [ByteString] - go = map T.encodeUtf8 . listify - parseJSON v = typeMismatch "command" v - -buildRawRule :: forall m. MonadError SosException m => RawRule -> m [Rule] -buildRawRule (RawRule patterns templates) = - mapM (\pattern -> buildRule pattern templates) patterns - --------------------------------------------------------------------------------- - -data OneOrList a - = One a - | List [a] - deriving Functor - -instance FromJSON a => FromJSON (OneOrList a) where - parseJSON v@(String _) = One <$> parseJSON v - parseJSON v@(Array _) = List <$> parseJSON v - parseJSON v = typeMismatch "element or list of elements" v - -listify :: OneOrList a -> [a] -listify (One x) = [x] -listify (List xs) = xs - diff --git a/src/Sos.hs b/src/Sos.hs --- a/src/Sos.hs +++ b/src/Sos.hs @@ -1,46 +1,76 @@ -{-# LANGUAGE LambdaCase #-} +module Sos + ( Sos + , runSos + , sosEnqueueJobs + , module Sos.Exception + , module Sos.FileEvent + , module Sos.Job + , module Sos.JobQueue + , module Sos.Rule + , module Sos.Template + ) where -module Sos 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 Data.ByteString (ByteString) +import Control.Monad.Trans.Resource +import Data.List.NonEmpty (NonEmpty(..)) +import Streaming import System.Exit -import Text.Megaparsec (ParseError) +import Text.Regex.TDFA (match) -import qualified Data.ByteString.Char8 as BS +import qualified Streaming.Prelude as S -data SosException - -- Error compiling the given regex. - = SosRegexException - ByteString -- pattern - String -- string reason for failure - -- Error parsing a command template. - | SosCommandParseException - ByteString -- template - ParseError -- failure - -- Error applying a list of captured variables to a command template. - | SosCommandApplyException - [Either Int ByteString] -- template - [ByteString] -- captured variables - String -- string reason for failure -instance Show SosException where - show (SosRegexException pattern err) = "Error compiling regex '" ++ BS.unpack pattern ++ "': " ++ err - show (SosCommandParseException template err) = "Error parsing command '" ++ BS.unpack template ++ "': " ++ show err - show (SosCommandApplyException template vars err) = "Error applying template '" ++ reconstruct template ++ "' to " ++ show vars ++ ": " ++ err - where - reconstruct :: [Either Int ByteString] -> String - reconstruct = concatMap - (\case - Left n -> '\\' : show n - Right bs -> BS.unpack bs) - -type Sos a = ExceptT SosException IO a +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 act >>= \case - Left err -> do - print err - exitFailure - Right x -> pure x + 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 new file mode 100644 --- /dev/null +++ b/src/Sos/Exception.hs @@ -0,0 +1,37 @@ +module Sos.Exception + ( SosException(..) + ) where + +import Sos.Utils + +import Data.ByteString (ByteString) + + +data SosException + -- Error compiling the given regex. + = SosRegexException + ByteString -- pattern + String -- string reason for failure + -- Error parsing a command template. + | SosCommandParseException + ByteString -- template + -- Error applying a list of captured variables to a command template. + | SosCommandApplyException + [Either Int ByteString] -- template + [ByteString] -- captured variables + String -- string reason for failure + deriving Eq + +instance Show SosException where + show (SosRegexException pattrn err) = + "Error compiling regex '" ++ unpackBS pattrn ++ "': " ++ err + show (SosCommandParseException template) = + "Error parsing command '" ++ unpackBS template ++ "'" + show (SosCommandApplyException template vars err) = + "Error applying template '" ++ reconstruct template ++ "' to " ++ show vars ++ ": " ++ err + where + reconstruct :: [Either Int ByteString] -> String + reconstruct = concatMap + (\case + Left n -> '\\' : show n + Right bs -> unpackBS bs) diff --git a/src/Sos/FileEvent.hs b/src/Sos/FileEvent.hs new file mode 100644 --- /dev/null +++ b/src/Sos/FileEvent.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE LambdaCase #-} + +module Sos.FileEvent + ( FileEvent(..) + , fileEventPath + ) where + +import Data.ByteString (ByteString) + +data FileEvent + = FileAdded ByteString + | FileModified ByteString + +fileEventPath :: FileEvent -> ByteString +fileEventPath = \case + FileAdded path -> path + FileModified path -> path diff --git a/src/Sos/Job.hs b/src/Sos/Job.hs new file mode 100644 --- /dev/null +++ b/src/Sos/Job.hs @@ -0,0 +1,106 @@ +module Sos.Job + ( Job(jobEvent, jobCommands) + , JobResult(..) + , ShellCommand + , newJob + , runJob + , restartJob + , unrestartJob + , shouldRestartJob + ) where + +import Sos.FileEvent +import Sos.Utils + +import Control.Applicative +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid +import System.Exit +import System.Process +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. +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. + } + +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 + +-- | 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 +runJob (NonEmpty.toList . jobCommands -> cmds0) = go 1 cmds0 + where + go :: Int -> [ShellCommand] -> IO JobResult + go _ [] = pure JobSuccess + 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 + + try (bracket acquire terminateProcess waitForProcess) >>= \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 + + Right ExitSuccess -> do + putStrLn (green "Success ✓") + go (n+1) cmds + + Right (ExitFailure c) -> do + putStrLn (red (printf "Failure ✗ (%d)" c)) + pure JobFailure diff --git a/src/Sos/JobQueue.hs b/src/Sos/JobQueue.hs new file mode 100644 --- /dev/null +++ b/src/Sos/JobQueue.hs @@ -0,0 +1,104 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Sos/Rule.hs @@ -0,0 +1,113 @@ +module Sos.Rule + ( Rule(..) + , RawRule(..) + , RawPattern + , buildRule + , buildRawRule + ) where + +import Sos.Exception +import Sos.Template + +import Control.Applicative +import Control.Monad.Except +import Data.Aeson.Types +import Data.ByteString (ByteString) +import Data.Either +import Data.Text (Text) +import Text.Regex.TDFA +import Text.Regex.TDFA.ByteString (compile) + +import qualified Data.Text.Encoding as Text + + +-- | A 'ByteString' representing a pattern, e.g. "foo\.hs" or ".*\.c" +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. +-- +-- For example, this definition from a .sosrc yaml file is incorrect: +-- +-- - pattern: .*.c +-- - commands: +-- - gcc -c \1 +-- +-- 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. + } + +-- Build a 'Rule' from a 'RawPattern' and a list of 'RawTemplate' by compiling +-- the pattern regex and parsing each template. +buildRule + :: forall m. MonadError SosException m + => RawPattern + -> [RawTemplate] + -> m Rule +buildRule pattrn 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 + + return (Rule regex templates) + +-- 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] + +instance FromJSON RawRule where + parseJSON (Object o) = RawRule <$> parsePatterns <*> parseCommands + where + parsePatterns :: Parser [RawPattern] + parsePatterns = fmap go (o .: "pattern" <|> o .: "patterns") + + parseCommands :: Parser [RawTemplate] + parseCommands = fmap go (o .: "command" <|> o .: "commands") + + go :: OneOrList Text -> [ByteString] + go = map Text.encodeUtf8 . listify + parseJSON v = typeMismatch "command" v + +buildRawRule :: forall m. MonadError SosException m => RawRule -> m [Rule] +buildRawRule (RawRule patterns templates) = + mapM (\pattrn -> buildRule pattrn templates) patterns + +-------------------------------------------------------------------------------- + +data OneOrList a + = One a + | List [a] + deriving Functor + +instance FromJSON a => FromJSON (OneOrList a) where + parseJSON v@(String _) = One <$> parseJSON v + parseJSON v@(Array _) = List <$> parseJSON v + parseJSON v = typeMismatch "element or list of elements" v + +listify :: OneOrList a -> [a] +listify (One x) = [x] +listify (List xs) = xs diff --git a/src/Sos/Template.hs b/src/Sos/Template.hs new file mode 100644 --- /dev/null +++ b/src/Sos/Template.hs @@ -0,0 +1,98 @@ +module Sos.Template + ( RawTemplate + , Template + , parseTemplate + , instantiateTemplate + ) where + +import Sos.Exception +import Sos.Job (ShellCommand) +import Sos.Utils + +import Control.Applicative +import Control.Monad.Except +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.Lazy.Builder as LText + + +-- | A 'RawTemplate' represents a shell command, possibly containing capture +-- groups, e.g. "ghc \0" +type RawTemplate = ByteString + +-- A 'Template' is a parsed 'RawTemplate' that replaces all capture groups with +-- Lefts. +-- +-- For example, the raw template +-- +-- "gcc -c \1.c -o \1.c" +-- +-- will become +-- +-- [Right "gcc -c ", Left 1, Right ".c -o ", Left 1, Right ".c"] +-- +type Template = [Either Int ByteString] + + +parseTemplate :: MonadError SosException m => RawTemplate -> m Template +parseTemplate raw_template = + case readP_to_S parser (unpackBS raw_template) of + [(template, "")] -> return template + _ -> throwError (SosCommandParseException raw_template) + where + parser :: ReadP Template + parser = some (capturePart <|||> textPart) <* eof + where + capturePart :: ReadP Int + capturePart = read <$> (char '\\' *> munch1 digit) + where + digit :: Char -> Bool + digit c = c >= '0' && c <= '9' + + textPart :: ReadP ByteString + textPart = packBS <$> munch1 (/= '\\') + +-- Instantiate a template with a list of captured variables, per their indices. +-- +-- For example, +-- +-- instantiateTemplate ["ONE", "TWO"] [Right "foo", Left 0, Right "bar", Left 1] == "fooONEbarTWO" +-- +instantiateTemplate + :: forall m. MonadError SosException m + => [ByteString] + -> Template + -> m ShellCommand +instantiateTemplate vars0 template0 = go 0 vars0 template0 + where + go :: Int -> [ByteString] -> Template -> m ShellCommand + go _ [] template = + case flattenTemplate template of + Left n -> + let err = "uninstantiated template variable: \\" ++ show n + in throwError (SosCommandApplyException template0 vars0 err) + Right x -> return x + go n (t:ts) template = go (n+1) ts (map f template) + where + f :: Either Int ByteString -> Either Int ByteString + f (Left n') + | n == n' = Right t + | otherwise = Left n' + f x = x + +-- Attempt to flatten a list of Rights to a single string. +flattenTemplate :: Template -> Either Int ShellCommand +flattenTemplate = go mempty + where + go :: LText.Builder -> Template -> Either Int ShellCommand + go !acc [] = Right (LText.unpack (LText.toLazyText acc)) + go !acc (x:xs) = + case x of + Right s -> + let acc' = acc <> LText.fromText (Text.decodeUtf8 s) + in go acc' xs + Left n -> Left n diff --git a/src/Sos/Utils.hs b/src/Sos/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Sos/Utils.hs @@ -0,0 +1,36 @@ +module Sos.Utils where + +import Control.Applicative +import Data.Monoid +import Data.ByteString (ByteString) +import System.Console.ANSI + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +(<|||>) :: Alternative f => f a -> f b -> f (Either a b) +fa <|||> fb = Left <$> fa <|> Right <$> fb + +-- The proper way to make a ByteString from a String - Data.ByteString.Char8 +-- will snip each Char to 8 bits. +packBS :: String -> ByteString +packBS = Text.encodeUtf8 . Text.pack + +unpackBS :: ByteString -> String +unpackBS = Text.unpack . Text.decodeUtf8 + +colored :: Color -> String -> String +colored c s = color c <> s <> reset + +color :: Color -> String +color c = setSGRCode [SetColor Foreground Dull c] + +reset :: String +reset = setSGRCode [Reset] + +cyan, green, magenta, red, yellow :: String -> String +cyan = colored Cyan +green = colored Green +magenta = colored Magenta +red = colored Red +yellow = colored Yellow diff --git a/src/System/FSNotify/Streaming.hs b/src/System/FSNotify/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/System/FSNotify/Streaming.hs @@ -0,0 +1,28 @@ +-- | A streaming wrapper around System.FSNotify. + +module System.FSNotify.Streaming + ( System.FSNotify.Streaming.watchTree + -- * Re-exports + , Event(..) + , WatchManager + , WatchConfig(..) + , Debounce(..) + , defaultConfig + ) where + +import Control.Concurrent.Chan +import Control.Monad +import Control.Monad.Trans.Resource +import Streaming +import Streaming.Prelude (yield) +import System.FSNotify + +watchTree + :: MonadResource m + => WatchConfig -> FilePath -> (Event -> Bool) -> Stream (Of Event) m a +watchTree config path predicate = do + chan <- liftIO newChan + (_, manager) <- allocate (startManagerConf config) stopManager + _ <- allocate (watchTreeChan manager path predicate chan) id + + forever (liftIO (readChan chan) >>= yield) diff --git a/src/Template.hs b/src/Template.hs deleted file mode 100644 --- a/src/Template.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Template - ( Template - , parseTemplate - , instantiateTemplate - ) where - -import Sos - -import Control.Monad.Except -import Data.ByteString (ByteString) -import Data.Monoid -import Text.Megaparsec - -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.ByteString.Builder as BS - --- A template is a string that may contain anti-quoted capture groups. --- For example, --- --- "gcc -c \1.c -o \1.c" --- --- will become --- --- [Right "gcc -c ", Left 1, Right ".c -o ", Left 1, Right ".c"] -type Template - = [Either Int ByteString] - -parseTemplate :: MonadError SosException m => ByteString -> m Template -parseTemplate template = - case runParser parser "" template of - Left err -> throwError (SosCommandParseException template err) - Right x -> pure x - where - parser :: Parsec ByteString Template - parser = some (Right <$> textPart - <|> Left <$> capturePart) - where - textPart :: Parsec ByteString ByteString - textPart = BS.pack <$> some (satisfy (/= '\\')) - - capturePart :: Parsec ByteString Int - capturePart = read <$> (char '\\' *> some digitChar) - --- Instantiate a template with a list of captured variables, per their indices. --- --- For example, --- --- instantiateTemplate ["ONE", "TWO"] [Right "foo", Left 0, Right "bar", Left 1] == "fooONEbarTWO" --- -instantiateTemplate :: forall m. MonadError SosException m => [ByteString] -> Template -> m String -instantiateTemplate vars0 template0 = go 0 vars0 template0 - where - go :: Int -> [ByteString] -> Template -> m String - go _ [] template = - case flattenTemplate template of - Left err -> throwError (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 - f (Left n') - | n == n' = Right t - | otherwise = Left n' - f x = x - --- Attempt to flatten a list of Rights to a single string. -flattenTemplate :: Template -> Either String String -flattenTemplate = go mempty - where - go :: BS.Builder -> Template -> Either String String - go acc [] = Right (BSL.unpack (BS.toLazyByteString acc)) - go acc (Right x : xs) = go (acc <> BS.byteString x) xs - go _ (Left n : _) = Left ("uninstantiated template variable \\" <> show n) - diff --git a/steeloverseer.cabal b/steeloverseer.cabal --- a/steeloverseer.cabal +++ b/steeloverseer.cabal @@ -1,73 +1,115 @@ -name: steeloverseer --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- http://www.haskell.org/haskellwiki/Package_versioning_policy --- +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 2.0.0.1 -cabal-version: >=1.8 -build-type: Simple -license: BSD3 -license-file: LICENSE -maintainer: schell.scivally@synapsegrop.com -stability: stable -homepage: https://github.com/schell/steeloverseer -bug-reports: https://github.com/schell/steeloverseer/issues -synopsis: A file watcher and development tool. -description: - A command line tool that responds to filesystem events. - Allows the user to automatically execute commands after - files are added or updated. Watches files using regular - expressions. -category: Development -author: Schell Scivally, Mitchell Rosen +-- This file has been generated from package.yaml by hpack version 0.14.1. +-- +-- see: https://github.com/sol/hpack + +name: steeloverseer +version: 2.0.1.0 +cabal-version: >= 1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: efsubenovex@gmail.com +stability: stable +homepage: https://github.com/schell/steeloverseer#readme +bug-reports: https://github.com/schell/steeloverseer/issues +synopsis: A file watcher and development tool. +description: A command line tool that responds to filesystem events. Allows the user to automatically execute commands after files are added or updated. Watches files using regular expressions. +category: Development +author: Schell Scivally, + Mitchell Rosen + extra-source-files: - README.md + README.md source-repository head type: git - location: git://github.com/schell/steeloverseer.git + location: https://github.com/schell/steeloverseer library exposed-modules: - ANSI - Job - Rule - Sos - Template + Sos + Sos.Exception + Sos.FileEvent + Sos.Job + Sos.JobQueue + Sos.Rule + Sos.Template + Sos.Utils + System.FSNotify.Streaming + default-language: Haskell2010 build-depends: - base >= 4.0 && < 6.0 - , aeson >= 0.8 - , ansi-terminal >= 0.6.2 - , async >= 2.0 - , bytestring >= 0.10 - , containers >= 0.5 - , megaparsec >= 4.2 && < 5.0 - , microlens >= 0.2 - , mtl >= 2.2 - , process >= 1.2 - , semigroups >= 0.16 - , regex-tdfa >= 1.2 - , stm >= 2.4 - , text >= 1.2 - , yaml >= 0.8 - hs-source-dirs: src + 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 + hs-source-dirs: + src + default-extensions: BangPatterns DeriveFunctor FlexibleContexts LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns ghc-options: -Wall executable sos main-is: Main.hs build-depends: - base >= 4.0 && < 6.0 - , steeloverseer - , bytestring >= 0.10 - , directory >= 1.2 - , fsnotify >= 0.2 - , filepath >= 1.4 - , optparse-applicative >= 0.11 - , regex-tdfa >= 1.2 - , semigroups >= 0.16 - , yaml >= 0.8 - hs-source-dirs: app + 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 + , directory >= 1.2 + , filepath >= 1.3 + , optparse-applicative >= 0.11 + if os(darwin) + build-depends: + hfsevents >= 0.1.3 + default-language: Haskell2010 + hs-source-dirs: + app + default-extensions: BangPatterns DeriveFunctor FlexibleContexts LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables ViewPatterns ghc-options: -Wall -threaded +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: BangPatterns DeriveFunctor FlexibleContexts 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 + , hspec + other-modules: + Sos.JobQueueSpec + Sos.TemplateSpec + default-language: Haskell2010 diff --git a/test/Sos/JobQueueSpec.hs b/test/Sos/JobQueueSpec.hs new file mode 100644 --- /dev/null +++ b/test/Sos/JobQueueSpec.hs @@ -0,0 +1,23 @@ +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 new file mode 100644 --- /dev/null +++ b/test/Sos/TemplateSpec.hs @@ -0,0 +1,34 @@ +module Sos.TemplateSpec where + +import Sos.Template + +import Test.Hspec + +spec :: Spec +spec = do + describe "parseTemplate" $ do + it "fails on the empty string" $ + parseTemplate "" `shouldSatisfy` isLeft + + 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] + + 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" + + it "substitutes capture groups" $ do + instantiateTemplate ["a","b","c"] [Left 2, Left 1, Left 0] `shouldBe` Right "cba" + + it "errors when there are not enough capture groups" $ do + instantiateTemplate [] [Left 0] `shouldSatisfy` isLeft + instantiateTemplate ["a"] [Left 1] `shouldSatisfy` isLeft + +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft _ = False 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 #-}