module Main where
import Sos
import Sos.Utils
import qualified System.FSNotify.Streaming as FSNotify
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.Except
import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Monoid
import Data.Yaml (decodeFileEither, prettyPrintParseException)
import Options.Applicative
import Streaming
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import qualified Data.Foldable as Foldable
import qualified Streaming.Prelude as S
version :: String
version = "Steel Overseer 2.0.1.0"
data Options = Options
{ 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 )
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 optRCFile
-- 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 (packBS optTarget) optCommands)
pure (takeDirectory optTarget, [rule])
_ -> do
putStrLn ("Target " ++ optTarget ++ " is not a file or directory.")
exitFailure
putStrLn "Hit Ctrl+C to quit."
job_queue <- newJobQueue
let enqueue_thread :: IO a
enqueue_thread =
runSos (sosEnqueueJobs rules (watchTree target) job_queue)
-- 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."))
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
unless continue $ do
n' <- jobQueueLength job_queue
clearJobQueue job_queue
putStrLn (red ("Aborted " ++ show n' ++ " job(s)."))
race_ enqueue_thread dequeue_thread
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 }
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)
--------------------------------------------------------------------------------
-- 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 []