trigger (empty) → 1.0.0.0

raw patch · 11 files changed

+526/−0 lines, 11 filesdep +Globdep +aesondep +ansi-terminalsetup-changed

Dependencies added: Glob, aeson, ansi-terminal, base, clock, directory, exceptions, filepath, formatting, fsnotify, hspec, process, protolude, text, time, trigger, twitch, yaml

Files

• LICENSE +30/−0
• README.md +76/−0
• Setup.hs +2/−0
• main/Main.hs +11/−0
• src/Console.hs +82/−0
• src/Parser.hs +39/−0
• src/Trigger.hs +119/−0
• src/Watcher.hs +86/−0
• test/ParserSpec.hs +15/−0
• test/Spec.hs +1/−0
• trigger.cabal +65/−0

@@ -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.

@@ -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

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,11 @@+module Main where++import           Protolude++import           Parser+import           Trigger++main :: IO ()+main = do+  config <- loadAndParse "trigger.yaml"+  run config

@@ -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]

@@ -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

@@ -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)

@@ -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

@@ -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]

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -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