steeloverseer 1.1.1.0 → 2.0
raw patch · 10 files changed
+726/−261 lines, 10 filesdep +aesondep +asyncdep +bytestringdep −timedep −unixdep ~ansi-terminaldep ~basedep ~filepath
Dependencies added: aeson, async, bytestring, containers, directory, megaparsec, microlens, mtl, optparse-applicative, semigroups, steeloverseer, stm, text, yaml
Dependencies removed: time, unix
Dependency ranges changed: ansi-terminal, base, filepath, fsnotify, process, regex-tdfa
Files
- README.md +74/−49
- app/Main.hs +152/−0
- src/ANSI.hs +13/−0
- src/Job.hs +190/−0
- src/Main.hs +0/−59
- src/Rule.hs +110/−0
- src/SOS.hs +0/−121
- src/Sos.hs +46/−0
- src/Template.hs +78/−0
- steeloverseer.cabal +63/−32
README.md view
@@ -1,66 +1,91 @@ Steel Overseer ==============-> ->-> The world is already run by all manner of machines. One day, they'll remind us of that fact. -> -> -Sargis Haz, artificer -[](https://travis-ci.org/schell/steeloverseer)+A file watcher and development tool, similar to Ruby's [Guard](https://github.com/guard/guard). -It is-------A development tool that runs commands when certain files are updated, added or-deleted.+[](https://travis-ci.org/steeloverseer/steeloverseer) -Steeloverseer watches files whose names match a regular expression and then -runs a series of commands when those files are updated. +Installation+============ -Specifically--------------A filesystem event occurs when a file is added, deleted or updated. -If this event happens on a file that matches one of the patterns provided with -the `-p PATTERN` flag then steeloverseer will run the commands provided -with the `-c COMMAND` flag. These commands will be performed in serial until -one hangs, fails or all exit successfully.+Download and install the [stack](https://github.com/commercialhaskell/stack) build tool. -You can provide multiple patterns and multiple commands, ie:+ stack install steeloverseer - sos -c "git status" -c "echo hi world" -p "hs" -p "md"+This will create a binary deep inside `~/.stack/`, and symlink to it at+`~/.local/bin/sos`. -You can seperately specify the directory to run in with `-d DIRECTORY`. The -default is `.`.- -This will execute `git status` followed by `echo hi world` -whenever files matching "hs" or "md" are changed. `-d DIRECTORY` -is not provided above, so it's assumed to be `./`.+Usage+===== -Also, since `-p PATTERN` are regular expressions we can do the same as above with:+See `sos --help` to get started: - sos -c "git status" -c "echo hi world" -p "hs|md"- -Of course this would run whenever any match on "hs|md" is found, -for instance on the filepath `/Users/home/mdman/file.txt`.-For extensions it may make sense to use the endline matcher:+ Steel Overseer 2.0 - sos -c "git status" -c "echo hi world" -p "hs$|md$"+ Usage: sos [TARGET] [-c|--command COMMAND] [-p|--pattern PATTERN]+ A file watcher and development tool. -Installation--------------Using cabal, `cabal install steeloverseer`.+ Available options:+ -h,--help Show this help text+ TARGET File or directory to watch for+ changes. (default: ".")+ -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: .*) -Usage------- sos: Usage: sos [v] -c command -p pattern- -v --version show version info- -c COMMAND --command=COMMAND add command to run on file event- -p PATTERN --pattern=PATTERN add pattern to match on file path- -d DIRECTORY --directory=DIRECTORY set directory to watch for changes (default is ./)+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: -Future--------Project `.sosrc` file for specifying multiple sos commands while working on a project (@see issue #4)+ sos src/ -c "gcc -c \0 -o obj/\1.o" -c "make test --filter=test/\1_test.c" -p "src/(.*)\.c" -[Art above by Chris Rahn for Wizards of the Coast](http://gatherer.wizards.com/Pages/Card/Details.aspx?multiverseid=205036 "Steel Overseer")+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):++```yaml+- pattern: src/(.*)\.c+ commands:+ - gcc -c \0 -o obj/\1.o+ - make test --filter=test/\1_test.c+```++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+```++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`.++.sosrc grammar+==============++ sosrc := [entry]+ entry := { "pattern" | "patterns" : value | [value]+ , "command" | "commands" : value | [value]+ }+ value := [segment]+ segment := text_segment | var_segment+ text_segment := string+ var_segment := '\' integer++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.
+ app/Main.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Job+import Rule+import Sos+import Template++import Control.Monad+import Data.ByteString (ByteString)+import Data.Function+import Data.Monoid+import Data.Yaml (decodeFileEither, prettyPrintParseException)+import Prelude hiding (FilePath)+import Options.Applicative+import System.Directory+import System.Exit+import System.FilePath+import System.FSNotify+import Text.Regex.TDFA++import qualified Data.ByteString.Char8 as BS+import qualified Data.List.NonEmpty as NE++version :: String+version = "Steel Overseer 2.0"++data Options = Options+ { optTarget :: FilePath+ , optCommands :: [ByteString]+ , optPatterns :: [ByteString]+ } deriving Show++main :: IO ()+main = execParser opts >>= main'+ 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" )))++main' :: Options -> IO ()+main' Options{..} = do+ -- Parse .sosrc rules.+ rc_rules <- parseSosrc++ -- 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)++ (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++ 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)++spawnFileWatcherThread :: WatchManager -> JobQueue -> FilePath -> [Rule] -> IO ()+spawnFileWatcherThread wm job_queue target rules = do+ cwd <- getCurrentDirectory++ let eventRelPath :: Event -> FilePath+ eventRelPath event = makeRelative cwd (eventPath event)++ predicate :: Event -> Bool+ predicate event = any (\rule -> match (ruleRegex rule) (eventRelPath event)) rules++ _ <- watchTree wm target predicate $ \event -> do+ let path = BS.pack (eventRelPath event)++ commands <- concat <$> mapM (instantiateTemplates path) rules+ when (commands /= [])+ (enqueueJob (showEvent event cwd) (NE.fromList commands) job_queue)++ pure ()+ where+ instantiateTemplates :: ByteString -> Rule -> IO [ShellCommand]+ instantiateTemplates path Rule{..} =+ case match ruleRegex path of+ [] -> pure []+ (captures:_) -> runSos (mapM (instantiateTemplate captures) ruleTemplates)++--------------------------------------------------------------------------------++-- 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 []++--------------------------------------------------------------------------------++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
+ src/ANSI.hs view
@@ -0,0 +1,13 @@+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]
+ src/Job.hs view
@@ -0,0 +1,190 @@+{-# 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
− src/Main.hs
@@ -1,59 +0,0 @@-{-#LANGUAGE RecordWildCards #-}-module Main where--import System.Environment (getArgs)-import System.Console.GetOpt-import Control.Monad-import SOS--main :: IO ()-main = do- args <- getArgs- case getOpt Permute options args of- ( [], _, []) -> error $ usageInfo header options- ( opts, _, []) -> startWithOpts $ foldl (flip id) defaultOptions opts- ( _, _, msgs) -> error $ concat msgs ++ usageInfo header options--data Options = Options { optShowVersion :: Bool- , optCommands :: [String]- , optPatterns :: [String]- , optDirectory :: FilePath- } deriving (Show, Eq)--defaultOptions :: Options-defaultOptions = Options { optShowVersion = False- , optCommands = []- , optPatterns = []- , optDirectory = "."- }--options :: [OptDescr (Options -> Options)]-options = [ Option "v" ["version"]- (NoArg (\opts -> opts { optShowVersion = True }))- "Show version info."- , Option "c" ["command"]- (ReqArg (\c opts -> opts { optCommands = optCommands opts ++ [c] }) "command")- "Add command to run on file event."- , Option "p" ["pattern"]- (ReqArg (\e opts -> opts { optPatterns = optPatterns opts ++ [e] }) "pattern")- "Add pattern to match on file path."- , Option "d" ["directory"]- (ReqArg (\d opts -> opts { optDirectory = d }) "directory")- "Set directory to watch for changes (default is ./)."- ]--header :: String-header = "Usage: sos [vb] -c command -p pattern"--version :: String-version = "\nSteel Overseer 1.1.0.4\n"--startWithOpts :: Options -> IO ()-startWithOpts opts = do- let Options{..} = opts- haveOptions = not (null optPatterns)- patternsValid = and $ fmap (not . null) optPatterns- when optShowVersion $ putStrLn version- unless patternsValid $ error "One or more patterns are empty."- let runSteelOverseer = steelOverseer optDirectory optCommands optPatterns- when (haveOptions && patternsValid) runSteelOverseer
+ src/Rule.hs view
@@ -0,0 +1,110 @@+{-# 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+
− src/SOS.hs
@@ -1,121 +0,0 @@-module SOS where--import System.FSNotify-import System.Process-import System.Exit-import System.FilePath-import System.Console.ANSI-import Control.Monad-import Control.Concurrent-import Data.Maybe-import Text.Regex.TDFA-import Prelude hiding ( FilePath )---- | A structure to hold our changed file events,--- list of commands to run and possibly the currently running process,--- in case it's one that hasn't terminated.-data SOSState = SOSIdle- | SOSPending { accumulatedEvents :: [Event] }- | SOSRunning { runningProccess :: ProcessHandle- , pendingCommands :: [String]- }---- | Starts sos in a `dir` watching `ptns` to execute `cmds`.-steelOverseer :: FilePath -> [String] -> [String] -> IO ()-steelOverseer dir cmds ptns = do- putStrLn "Hit enter to quit.\n"- wm <- startManager- mvar <- newEmptyMVar-- let predicate = actionPredicateForRegexes ptns- action = performCommand mvar cmds- _ <- watchTree wm dir predicate action- _ <- getLine- cleanup wm mvar---- | Cleans up sos on close.-cleanup :: WatchManager -> MVar SOSState -> IO ()-cleanup wm mvar = do- putStrLn "Cleaning up."- mState <- tryTakeMVar mvar- case mState of- Just (SOSRunning pid _) -> terminatePID pid- _ -> return ()- stopManager wm--actionPredicateForRegexes :: [String] -> Event -> Bool-actionPredicateForRegexes ptns event =- or (fmap (eventPath event =~) ptns :: [Bool])--performCommand :: MVar SOSState -> [String] -> Event -> IO ()-performCommand mvar cmds event = do- cyanPrint event- mSosState <- tryTakeMVar mvar- sosState <- case mSosState of- Nothing -> do- -- This is the first file to change and there is no running process.- startWriteProcess mvar cmds 1000000- return $ SOSPending [event]-- Just (SOSRunning pid _) -> do- -- There is a hanging process.- mExCode <- getProcessExitCode pid- when (isNothing mExCode) $ terminatePID pid- startWriteProcess mvar cmds 1000000- return $ SOSPending [event]-- Just (SOSPending events) ->- -- SOS is waiting the 1sec delay for events before running the process.- return $ SOSPending $ event:events-- Just state -> return state-- putMVar mvar sosState--startWriteProcess :: MVar SOSState -> [String] -> Int -> IO ()-startWriteProcess mvar [] _ = do- _ <- tryTakeMVar mvar- return ()--startWriteProcess mvar (cmd:cmds) delay = void $ forkIO $ do- threadDelay delay-- setSGR [SetColor Foreground Dull Green]- putStr "\n> "- setSGR [Reset]- putStrLn cmd-- pId <- runCommand cmd- mEvProcCurrent <- tryTakeMVar mvar- case mEvProcCurrent of- -- This shouldn't ever happen.- Nothing -> putMVar mvar $ SOSRunning pId cmds-- Just _ -> void $ forkIO $ do- putMVar mvar $ SOSRunning pId cmds- exitCode <- waitForProcess pId- case exitCode of- ExitSuccess -> do- greenPrint exitCode- startWriteProcess mvar cmds 0- _ -> redPrint exitCode--terminatePID :: ProcessHandle -> IO ()-terminatePID pid = do- terminateProcess pid- putStrLnColor Red "Terminated hanging process."--cyanPrint :: Show a => a -> IO ()-cyanPrint = putStrLnColor Cyan . show--redPrint :: Show a => a -> IO ()-redPrint = putStrLnColor Red . show--greenPrint :: Show a => a -> IO ()-greenPrint = putStrLnColor Green . show--putStrLnColor :: Color -> String -> IO ()-putStrLnColor c s = do- setSGR [SetColor Foreground Dull c]- putStrLn s- setSGR [Reset]
+ src/Sos.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE LambdaCase #-}++module Sos where++import Control.Monad.Except+import Data.ByteString (ByteString)+import System.Exit+import Text.Megaparsec (ParseError)++import qualified Data.ByteString.Char8 as BS++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++runSos :: Sos a -> IO a+runSos act =+ runExceptT act >>= \case+ Left err -> do+ print err+ exitFailure+ Right x -> pure x
+ src/Template.hs view
@@ -0,0 +1,78 @@+{-# 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)+
steeloverseer.cabal view
@@ -1,36 +1,67 @@--- Initial steeloverseer.cabal generated by cabal init. For further--- documentation, see http://haskell.org/cabal/users-guide/--name: steeloverseer-version: 1.1.1.0-synopsis: A file watcher.-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.-license: BSD3-license-file: LICENSE-author: Schell Scivally-maintainer: efsubenovex@gmail.com-stability: stable-bug-reports: https://github.com/schell/steeloverseer/issues-homepage: https://github.com/schell/steeloverseer-category: Development-build-type: Simple-cabal-version: >=1.8-extra-source-files: README.md+name: steeloverseer+version: 2.0+cabal-version: >=1.8+build-type: Simple+license: BSD3+license-file: LICENSE+maintainer: schell.scivally@synapsegrop.com+stability: stable+homepage: https://github.com/steeloverseer/steeloverseer+bug-reports: https://github.com/steeloverseer/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 source-repository head- type: git- location: git://github.com/schell/steeloverseer.git+ type: git+ location: git://github.com/steeloverseer/steeloverseer.git +library+ exposed-modules:+ ANSI+ Job+ Rule+ Sos+ Template+ build-depends:+ base >= 4.0 && < 6.0,+ aeson -any,+ ansi-terminal -any,+ async -any,+ bytestring -any,+ containers -any,+ megaparsec -any,+ microlens -any,+ mtl -any,+ process -any,+ semigroups -any,+ regex-tdfa -any,+ stm -any,+ text -any,+ yaml -any+ hs-source-dirs: src+ ghc-options: -Wall+ executable sos- ghc-options: -Wall -threaded- hs-source-dirs: src- main-is: Main.hs- other-modules: SOS- build-depends: base >=4.5 && <4.9,- fsnotify >=0.2 && < 0.3,- filepath >= 1.4 && < 1.5,- ansi-terminal >= 0.6 && < 0.7,- process >= 1.1.0.2,- time >=1.4,- regex-tdfa >=1.1.8,- unix >=2.6.0.1+ main-is: Main.hs+ build-depends:+ base >= 4.0 && < 6.0,+ bytestring -any,+ directory -any,+ fsnotify -any,+ filepath -any,+ optparse-applicative -any,+ regex-tdfa -any,+ semigroups -any,+ steeloverseer -any,+ yaml -any+ hs-source-dirs: app+ ghc-options: -Wall -threaded+