diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,66 +1,91 @@ Steel Overseer ============== -> ![flavor text](https://raw.github.com/schell/steeloverseer/master/rsrc/pic.jpg) -> -> The world is already run by all manner of machines. One day, they'll remind us of that fact. -> -> -Sargis Haz, artificer -[![Build Status](https://travis-ci.org/schell/steeloverseer.png?branch=master)](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. +[![Build Status](https://travis-ci.org/steeloverseer/steeloverseer.png?branch=master)](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). -![steeloverseer screencast](http://zyghost.com/images/sos.gif) +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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/src/ANSI.hs b/src/ANSI.hs new file mode 100644 --- /dev/null +++ b/src/ANSI.hs @@ -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] diff --git a/src/Job.hs b/src/Job.hs new file mode 100644 --- /dev/null +++ b/src/Job.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 diff --git a/src/Rule.hs b/src/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Rule.hs @@ -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 + diff --git a/src/SOS.hs b/src/SOS.hs deleted file mode 100644 --- a/src/SOS.hs +++ /dev/null @@ -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] diff --git a/src/Sos.hs b/src/Sos.hs new file mode 100644 --- /dev/null +++ b/src/Sos.hs @@ -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 diff --git a/src/Template.hs b/src/Template.hs new file mode 100644 --- /dev/null +++ b/src/Template.hs @@ -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) + diff --git a/steeloverseer.cabal b/steeloverseer.cabal --- a/steeloverseer.cabal +++ b/steeloverseer.cabal @@ -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 +