diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Rhys Keepence (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Rhys Keepence nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,76 @@ +# Trigger + +`Trigger` is a cross platform file system watcher for super fast build-and-restart workflows. When files change, it can be configured to: + - run build tasks + - restart your app in the background + +`fswatch` and others are good general purpose tools for triggering tasks on filesystem changes. +However, they don't support stopping and starting background processes. + +# How does it work? + +``` + ------------------------------- + | start processes in background | + ------------------------------- + | + wait for change <----------- + | | + ------------------------------- | + | stop background processes | | + ------------------------------- | + | | + ------------------------------- | + | run build tasks sequentially | | + ------------------------------- | + | | + ------------------------------- | + | start processes in background | | + ------------------------------- | + | | + --------------------- + +``` + +# Installation + +It's Haskell, so download Stack. + +Clone and run `stack build --install` + +This should install `trigger` on your PATH. + +If you get linking issues on Windows, see [this issue](https://github.com/commercialhaskell/stack/issues/425) + +# Configuration + +Create a file named `trigger.yaml` + +Here is an example: +```yaml +- dirs: + - "src" + files: + - "**/*.hs" + ignore: + - "**/Ignored.hs" + tasks: + - "stack build" + run: + - command: "project/stack exec" + workingDir: "project" + env: + - ["HOST", "localhost"] + - ["PORT", "1234"] +``` + +Which consists of: + +- `dirs`: one or more directories to watch for changes +- `files`: one or more file globs. Files that don't match will not trigger. +- `ignore`: (optional) one or more file globs. Overrides the above file globs to exclude particular files. +- `tasks`: (optional) one or more tasks, which are run sequentially in the foreground. Any error will stop subsequent tasks. +- `run`: (optional) one or more background processes. *Note: this executes the command directly, rather than using the shell, to improve shutdown behaviour.* + - `command`: command and arguments to run in background. *Note: this command is relative to where you start trigger, not the `workingDir`.* + - `workingDir`: (optional) override the working directory of the process. + - `env`: (optional) additional environment variables for the process diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/main/Main.hs b/main/Main.hs new file mode 100644 --- /dev/null +++ b/main/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Protolude + +import Parser +import Trigger + +main :: IO () +main = do + config <- loadAndParse "trigger.yaml" + run config diff --git a/src/Console.hs b/src/Console.hs new file mode 100644 --- /dev/null +++ b/src/Console.hs @@ -0,0 +1,82 @@ +module Console where + +import Data.Time +import Formatting +import Formatting.Clock +import Protolude +import System.Clock +import System.Console.ANSI +import qualified System.IO as IO + +printFileChanged :: FilePath -> IO () +printFileChanged file = do + putStr "\nFile " + printCommand $ toS file + putStr " changed.\n" + IO.hFlush stdout + +printStartingRunTask :: Text -> IO () +printStartingRunTask = printCommandAndDescription $ toS "Starting" + +printRunningTask :: Text -> IO () +printRunningTask = printCommandAndDescription $ toS "Runnning" + +printTerminatingRunTask :: Text -> IO () +printTerminatingRunTask = printCommandAndDescription $ toS "Terminating" + +printTaskFinished :: ExitCode -> IO () +printTaskFinished exitCode = do + printExitCode exitCode + IO.hFlush stdout + +printCompleted :: TimeSpec -> TimeSpec -> IO () +printCompleted start end = do + currentTime <- getCurrentTime + let duration = format timeSpecs start end + setSGR [SetColor Foreground Vivid Cyan] + putStr $ "\nCompleted in " <> toS duration <> " at " <> show currentTime + setSGR [Reset] + putStrLn " - Waiting..." + +printTerminated :: Text -> ExitCode -> IO () +printTerminated command exitCode = do + putStr "Terminated " + printCommand command + putStr "\n" + printExitCode exitCode + setSGR [Reset] + IO.hFlush stdout + +printAlreadyTerminated :: Text -> ExitCode -> IO () +printAlreadyTerminated command exitCode = do + printCommand command + putStr " had already terminated.\n" + printExitCode exitCode + IO.hFlush stdout + +printExitCode :: ExitCode -> IO () +printExitCode ExitSuccess = do + setSGR [SetColor Foreground Vivid Green] + putStrLn "[SUCCESS]" + setSGR [Reset] +printExitCode (ExitFailure intCode) = do + setSGR [SetColor Foreground Vivid Red] + putStrLn $ "[FAILED " <> show intCode <> "]" + setSGR [Reset] + +printCommandAndDescription :: Text -> Text -> IO () +printCommandAndDescription description command = do + setSGR [SetUnderlining SingleUnderline] + putStr $ "\n" <> toS description <> " " + printCommand command + putStr "\n" + setSGR [Reset] + IO.hFlush stdout + +printCommand :: Text -> IO () +printCommand command = do + setSGR [SetColor Foreground Vivid White] + putStr "\"" + putStr command + putStr "\"" + setSGR [Reset] diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Parser + ( Config(..) + , RunConfig(..) + , loadAndParse + ) where + +import Data.Aeson.Types +import qualified Data.Yaml as Y +import Protolude + +data Config = Config + { _dirs :: [Text] + , _files :: [Text] + , _ignore :: Maybe [Text] + , _tasks :: Maybe [Text] + , _run :: Maybe [RunConfig] + } deriving (Eq, Show, Generic) + +instance Y.FromJSON Config where + parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = drop 1} + +data RunConfig = RunConfig + { _workingDir :: Maybe Text + , _command :: Text + , _env :: Maybe [(Text,Text)] + } deriving (Eq, Show, Generic) + +instance Y.FromJSON RunConfig where + parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = drop 1} + +loadAndParse :: FilePath -> IO [Config] +loadAndParse filePath = do + config <- Y.decodeFileEither filePath + eitherToIo config + where + eitherToIo (Left configError) = throwIO configError + eitherToIo (Right config) = return config diff --git a/src/Trigger.hs b/src/Trigger.hs new file mode 100644 --- /dev/null +++ b/src/Trigger.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE RecordWildCards #-} + +module Trigger + ( run + ) where + +import Console +import qualified Control.Arrow as A +import qualified Control.Monad.Catch as C +import qualified Data.List as L +import qualified Data.Text as T +import Parser +import Protolude +import qualified System.Clock as C +import qualified System.FSNotify as FS +import qualified System.Process as P +import Watcher + +data RunningProcess = RunningProcess + { cmd :: Text + , processHandle :: P.ProcessHandle + } + +type RunningProcesses = [RunningProcess] + +run :: [Config] -> IO () +run configs = do + runningState <- newMVar [] + managers <- mapM (runConfig runningState) configs + putStrLn "Waiting..." + _ <- getLine + mapM_ FS.stopManager managers + +runConfig :: MVar RunningProcesses -> Config -> IO FS.WatchManager +runConfig runningState config = do + modifyMVar_ runningState (initialStartProcesses config) + watch config (handleFileChange runningState config) + +handleFileChange :: MVar RunningProcesses -> Config -> FilePath -> IO () +handleFileChange runningState config file = do + printFileChanged file + modifyMVar_ runningState (restartProcesses config) + +initialStartProcesses :: Config -> RunningProcesses -> IO RunningProcesses +initialStartProcesses Config {..} _ = mapM startProcess (concat _run) + +restartProcesses :: Config -> RunningProcesses -> IO RunningProcesses +restartProcesses config runningProcesses = do + start <- C.getTime C.Monotonic + mapM_ terminate runningProcesses + processes <- attemptStart config + end <- C.getTime C.Monotonic + printCompleted start end + threadDelay 200000 + return processes + +attemptStart :: Config -> IO RunningProcesses +attemptStart Config {..} = + swallowErrors $ do + runTasks _tasks + mapM startProcess (concat _run) + where + swallowErrors :: IO RunningProcesses -> IO RunningProcesses + swallowErrors = C.handleAll (\_ -> return []) + +runTasks :: Maybe [Text] -> IO () +runTasks tasks = mapM_ runTask (concat tasks) + +runTask :: Text -> IO () +runTask cmd = do + printRunningTask cmd + exitCode <- P.system $ toS cmd + printTaskFinished exitCode + case exitCode of + ExitSuccess -> return () + ExitFailure _ -> throwIO exitCode + +startProcess :: RunConfig -> IO RunningProcess +startProcess RunConfig {..} = do + (_, _, _, processHandle) <- P.createProcess_ (toS _command) $ process _workingDir _env _command + printStartingRunTask _command + return $ RunningProcess _command processHandle + +terminate :: RunningProcess -> IO () +terminate RunningProcess {..} = do + printTerminatingRunTask cmd + exit <- P.getProcessExitCode processHandle + case exit of + Nothing -> do + P.terminateProcess processHandle + exitCode <- P.waitForProcess processHandle + printTerminated cmd exitCode + Just exitCode -> printAlreadyTerminated cmd exitCode + +process :: Maybe Text -> Maybe [(Text, Text)] -> Text -> P.CreateProcess +process workingDir env command = + P.CreateProcess + { cmdspec = splitCommand command + , cwd = map toS workingDir + , env = map (map (toS A.*** toS)) env + , std_in = P.Inherit + , std_out = P.Inherit + , std_err = P.Inherit + , close_fds = False + , create_group = False + , delegate_ctlc = False + , detach_console = False + , create_new_console = False + , new_session = False + , child_group = Nothing + , child_user = Nothing + } + +splitCommand :: Text -> P.CmdSpec +splitCommand command = + let cmdAndArgs = T.words command + cmd = fromMaybe T.empty (head cmdAndArgs) + args = L.tail cmdAndArgs + in P.RawCommand (toS cmd) (map toS args) diff --git a/src/Watcher.hs b/src/Watcher.hs new file mode 100644 --- /dev/null +++ b/src/Watcher.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE RecordWildCards #-} + +module Watcher + ( watch + ) where + +import Data.String (fromString) +import Parser +import Protolude +import System.Directory +import System.FilePath +import qualified System.FilePath.Glob as G +import qualified System.FSNotify as FS +import qualified Twitch as T + +type Handler = FilePath -> IO () + +watch :: Config -> Handler -> IO FS.WatchManager +watch config handler = do + currentDir <- getCurrentDirectory + baseDirectories <- mapM toAbsoluteDirectory (_dirs config) + directoriesToWatch <- getDirectoriesToWatch baseDirectories + let ignoringHandler = handlerWithIgnore (ignoredFilePatterns currentDir config) handler + T.runWithConfig currentDir (twitchConfig directoriesToWatch) $ registerAllHandlers config ignoringHandler + +registerAllHandlers :: Config -> Handler -> T.Dep +registerAllHandlers config handler = mapM_ (registerHandler handler) (allFilePaths config) + +registerHandler :: Handler -> FilePath -> T.Dep +registerHandler handler fileGlob = T.addModify handler (fromString $ toS fileGlob) + +handlerWithIgnore :: [G.Pattern] -> Handler -> Handler +handlerWithIgnore ignored handler filePath = + if any (\pattern -> G.match pattern filePath) ignored + then return () + else (handler filePath) + +ignoredFilePatterns :: FilePath -> Config -> [G.Pattern] +ignoredFilePatterns currentDirectory Config {..} = + let + absoluteIgnoreDir :: Text -> [FilePath] + absoluteIgnoreDir dir = createFilePaths (toS (currentDirectory toS dir)) (concat _ignore) + allIgnored = foldl (\acc dir -> acc ++ (absoluteIgnoreDir dir)) [] _dirs + in map (G.compile) allIgnored + +allFilePaths :: Config -> [FilePath] +allFilePaths Config {..} = foldl (\acc dir -> acc ++ createFilePaths dir _files) [] _dirs + +createFilePaths :: Text -> [Text] -> [FilePath] +createFilePaths dir = map (\file -> toS dir toS file) + +watchConfig :: FS.WatchConfig +watchConfig = FS.WatchConfig {FS.confDebounce = FS.DebounceDefault, FS.confPollInterval = 0, FS.confUsePolling = False} + +twitchConfig :: [FilePath] -> T.Config +twitchConfig dirsToWatch = T.Config {logger = const $ return (), dirs = dirsToWatch, watchConfig = watchConfig} + +toAbsoluteDirectory :: Text -> IO FilePath +toAbsoluteDirectory filePath = do + currentDir <- getCurrentDirectory + makeAbsolute $ currentDir toS filePath + +getDirectoriesToWatch :: [FilePath] -> IO [FilePath] +getDirectoriesToWatch = foldMap getDirectories + where + getDirectories baseDirectory = do + subDirs <- findAllDirs baseDirectory + return $ baseDirectory : subDirs + +findAllDirs :: FilePath -> IO [FilePath] +findAllDirs path = do + dirs <- findImmediateDirs path + nestedDirs <- mapM findAllDirs dirs + return (dirs ++ concat nestedDirs) + +findImmediateDirs :: FilePath -> IO [FilePath] +findImmediateDirs = getDirectoryContentsPath >=> filterM doesDirectoryExist >=> canonicalize + where + canonicalize :: [FilePath] -> IO [FilePath] + canonicalize = mapM canonicalizeDirPath + +getDirectoryContentsPath :: FilePath -> IO [FilePath] +getDirectoryContentsPath path = map (path ) . filter (`notElem` [".", ".."]) <$> getDirectoryContents path + +canonicalizeDirPath :: FilePath -> IO FilePath +canonicalizeDirPath path = addTrailingPathSeparator <$> canonicalizePath path diff --git a/test/ParserSpec.hs b/test/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/ParserSpec.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ParserSpec where + +import Parser +import Protolude +import Test.Hspec + +spec :: Spec +spec = describe "Parser" $ do + it "can parse example.yaml" $ do + config <- loadAndParse "example/example.yaml" + config `shouldBe` + [ Config ["src"] ["**/*.hs"] Nothing (Just ["stack build"]) (Just [ (RunConfig (Just "code") "stack exec" (Just [("HOST", "localhost"), ("PORT", "1234")]))]) + , Config ["client"] ["**/*.elm"] (Just ["Api.elm"]) (Just ["elm-make"]) Nothing] 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 #-} diff --git a/trigger.cabal b/trigger.cabal new file mode 100644 --- /dev/null +++ b/trigger.cabal @@ -0,0 +1,65 @@ +name: trigger +version: 1.0.0.0 +homepage: https://github.com/rhyskeepence/trigger +license: MIT +license-file: LICENSE +author: Rhys Keepence +maintainer: rhys@rhyskeepence.com +copyright: 2017 Rhys Keepence +synopsis: Cross platform file system watcher +description: Trigger is a cross platform file system watcher for super fast build-and-restart workflows. When files change, it can be configured to: + * run build tasks + * restart your app in the background +category: Build +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +library + hs-source-dirs: src + build-depends: base >= 4.7 && < 5 + , aeson + , ansi-terminal + , clock + , directory + , exceptions + , filepath + , formatting + , fsnotify + , Glob + , process + , protolude + , text + , time + , twitch + , yaml + ghc-options: -Wall + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + exposed-modules: Console + , Parser + , Trigger + , Watcher + +executable trigger + hs-source-dirs: main + main-is: Main.hs + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + build-depends: base >= 4.7 && < 5 + , protolude + , trigger + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +test-suite trigger-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: base >= 4.7 && < 5 + , protolude + , trigger + , hspec + other-modules: ParserSpec