diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,5 @@ -![travis build status](https://travis-ci.org/jfischoff/twitch.svg?branch=master) +[![Hackage](https://img.shields.io/hackage/v/twitch.svg?style=flat)](https://hackage.haskell.org/package/twitch) +[![travis build status](https://travis-ci.org/jfischoff/twitch.svg?branch=master)](https://travis-ci.org/jfischoff/twitch/builds) Twitch is monadic DSL and library for file watching. It conveniently utilizes 'do' notation in the style of diff --git a/src/Twitch.hs b/src/Twitch.hs --- a/src/Twitch.hs +++ b/src/Twitch.hs @@ -81,14 +81,34 @@ -- * Running as a library , Issue (..) , InternalRule + , Rule + , RuleIssue , Config (..) , run , runWithConfig -- * Extra , DepM ) where -import Twitch.Internal -import Twitch.InternalRule (Config (..), Issue (..), InternalRule) +import Twitch.Internal + ( Dep, + DepM, + (|+), + (|%), + (|-), + (|>), + (|#), + add, + modify, + delete, + addModify, + name ) +import Twitch.InternalRule ( Config(..), Issue(..), InternalRule ) import Twitch.Main -import Twitch.Run -import Twitch.Rule (Rule, RuleAction, Name, PatternText) + ( DebounceType(..), + Options(Options, currentDir, debounce, debounceAmount, dirsToWatch, + logFile, pollInterval, recurseThroughDirectories, usePolling), + LoggerType(..), + defaultMain, + defaultMainWithOptions ) +import Twitch.Run ( run, runWithConfig ) +import Twitch.Rule ( Rule, RuleIssue ) diff --git a/src/Twitch/Internal.hs b/src/Twitch/Internal.hs --- a/src/Twitch/Internal.hs +++ b/src/Twitch/Internal.hs @@ -1,37 +1,29 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Twitch.Internal where -import Data.Map (Map) -import Control.Applicative -import Control.Monad -import Filesystem.Path -import Filesystem.Path.CurrentOS -import Prelude hiding (FilePath) -import Data.List -import Control.Monad.Reader -import Control.Monad.State as State -import System.Directory -import System.FilePath.Glob +import Control.Applicative ( Applicative ) +import Filesystem.Path ( FilePath ) +import Control.Monad.Trans.State as State + ( State, put, modify, execState ) import qualified Twitch.Rule as Rule -import Twitch.Rule (Rule) -import Data.Monoid -import Data.Time.Clock -import Data.String -import Data.Default -import Control.Arrow -import Data.Either -import System.FSNotify (WatchManager) + ( addF, modifyF, deleteF, nameF ) +import Twitch.Rule ( Rule ) +import Data.Monoid ( Monoid(mempty, mappend) ) +import Data.String ( IsString(..) ) +import Prelude hiding (FilePath) -- | A polymorphic 'Dep'. Exported for completeness, ignore. newtype DepM a = DepM { unDepM :: State [Rule] a} deriving ( Functor , Applicative , Monad - , MonadState [Rule] ) +instance Monoid a => Monoid (DepM a) where + mempty = return mempty + mappend x y = x >> y + -- | This is the key type of the package, it is where rules are accumulated. type Dep = DepM () @@ -45,12 +37,12 @@ runDepWithState xs = flip execState xs . unDepM addRule :: Rule -> Dep -addRule r = State.modify (r :) +addRule r = DepM $ State.modify (r :) modHeadRule :: Dep -> (Rule -> Rule) -> Dep modHeadRule dep f = do let res = runDep dep - case res of + DepM $ case res of x:xs -> put $ f x : xs r -> put r diff --git a/src/Twitch/InternalRule.hs b/src/Twitch/InternalRule.hs --- a/src/Twitch/InternalRule.hs +++ b/src/Twitch/InternalRule.hs @@ -1,20 +1,20 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} module Twitch.InternalRule where -import Filesystem.Path -import Data.Time.Clock -import System.FSNotify ( Event (..) - , WatchConfig - , watchDir - , startManagerConf - , WatchManager - , defaultConfig - ) -import Data.Default -import Control.Monad -import Data.Monoid +import Filesystem.Path ( FilePath ) +import Data.Time.Clock ( UTCTime ) +import System.FSNotify + ( Event(..), + WatchConfig, + watchDir, + startManagerConf, + WatchManager, + defaultConfig ) +import Data.Default ( Default(..) ) +import Control.Monad ( when, void, forM_ ) +import Data.Monoid ( Monoid(mempty), (<>) ) +import Twitch.Rule ( Rule, RuleIssue ) import Prelude hiding (FilePath) -import Twitch.Rule (Rule, RuleIssue) import qualified Twitch.Rule as Rule -- | The actions that are run when file events are triggered @@ -53,7 +53,7 @@ toInternalRule :: FilePath -> Rule -> Either RuleIssue InternalRule toInternalRule currentDir rule = do test <- Rule.compilePattern currentDir $ Rule.pattern rule - return $ InternalRule + return InternalRule { name = Rule.name rule , fileTest = \x _ -> test x , add = \x _ -> Rule.add rule x @@ -109,9 +109,9 @@ -- | Run the Rule action associated with the an event fireRule :: Event -> InternalRule -> IO () fireRule event rule = case event of - Added file time -> modify rule file time - Modified file time -> add rule file time - Removed file time -> delete rule file time + Added file tyme -> modify rule file tyme + Modified file tyme -> add rule file tyme + Removed file tyme -> delete rule file tyme -- | Test to see if the rule should fire and fire it testAndFireRule :: Config -> Event -> InternalRule -> IO () @@ -125,7 +125,7 @@ -- when appropiate -- | Start watching a directory, and run the rules on it. setupRuleForDir :: Config -> WatchManager -> [InternalRule] -> FilePath -> IO () -setupRuleForDir config@(Config {..}) man rules dirPath = do +setupRuleForDir config@(Config {..}) man rules dirPath = -- TODO Instead of const True, this should use the rule's fileTests void $ watchDir man dirPath (const True) $ \event -> do logger $ IEvent event diff --git a/src/Twitch/Main.hs b/src/Twitch/Main.hs --- a/src/Twitch/Main.hs +++ b/src/Twitch/Main.hs @@ -1,27 +1,54 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} module Twitch.Main where -import Data.Monoid +import Prelude hiding (log, FilePath) +import Data.Monoid ( (<>) ) import Options.Applicative -import Data.Default + ( Applicative((<*>)) + , (<$>) + , Parser + , helper + , execParser + , value + , short + , progDesc + , option + , metavar + , long + , info + , help + , header + , fullDesc + , auto + , eitherReader + , many + , switch + , flag + , ParserInfo + ) +import Data.Default ( Default(..) ) import qualified System.FSNotify as FS -import Twitch.Path +import Twitch.Path ( findAllDirs ) import qualified Twitch.InternalRule as IR import System.IO -import Data.Foldable (for_) -import Twitch.Run -import Twitch.Internal -import System.Directory -import Data.Maybe -import Prelude hiding (log) -import qualified Filesystem.Path as F + ( IOMode(AppendMode), + Handle, + hPrint, + openFile, + hClose ) +import Data.Foldable ( for_ ) +import Twitch.Run ( runWithConfig ) +import Twitch.Internal ( Dep ) +import System.Directory ( getCurrentDirectory ) +import Data.Maybe ( fromMaybe ) +import Filesystem.Path (FilePath) import qualified Filesystem.Path.CurrentOS as F -import Data.Time.Clock -import Control.Concurrent +import Control.Monad ( liftM ) -- parse the command line -- -concatMapM f = fmap concat . mapM f +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f = liftM concat . mapM f data LoggerType = LogToStdout @@ -35,44 +62,45 @@ toLogger filePath lt = case lt of LogToStdout -> return (print, Nothing) LogToFile -> do - handle <- openFile filePath AppendMode + handle <- openFile (F.encodeString filePath) AppendMode return (hPrint handle, Just handle) NoLogger -> return (const $ return (), Nothing) data Options = Options - { log :: LoggerType + { log :: LoggerType -- ^ The logger type. -- This cooresponds to the --log or -l argument. The valid options -- are "LogToStdout", "LogToFile", and "NoLogger" -- If "LogToFile" a file can provide with the 'logFile' field. - , logFile :: Maybe FilePath + , logFile :: Maybe FilePath -- ^ The file to log to -- This is only used if the 'log' field is set to "LogToFile". -- This cooresponds to the --log-file or -f argument - , dirsToWatch :: [FilePath] + , dirsToWatch :: [FilePath] -- ^ The directories to watch. - -- This cooresponds to the --directories and -d argument + -- This cooresponds to the --directories and -d argument. + -- By default this is empty and the current directory is used , recurseThroughDirectories :: Bool -- ^ If true, main will recurse throug all subdirectories of the 'dirsToWatch' -- field. Otherwise the 'dirsToWatch' will be used literally. - -- By default this is empty and the currentDirectory is used. - , debounce :: DebounceType + -- By default this is true, and disabled with the --no-recurse-flag + , debounce :: DebounceType -- ^ This corresponds to the debounce type used in the fsnotify library -- The argument for default main is --debounce or -b . -- Valid options are "DebounceDefault", "Debounce", "NoDebounce" -- If "Debounce" is used then a debounce amount must be specified with the -- 'debounceAmount' - , debounceAmount :: Double + , debounceAmount :: Double -- ^ The amount to debounce. This is only meaningful when 'debounce' is set -- to 'Debounce'. -- It cooresponds to the --debounce-amount or -a argument - , pollInterval :: Int + , pollInterval :: Int -- ^ poll interval if polling is used. -- This cooresponds to the --poll-interval or -i argument - , usePolling :: Bool - -- ^ If true polling is used instead of events. - -- This cooresponds to the --poll or -p argument - , currentDir :: Maybe FilePath + , usePolling :: Bool + -- ^ Sets polling to true if used + -- This cooresponds to the --should-poll or -p flag + , currentDir :: Maybe FilePath -- ^ The current directory to append to the glob patterns. If Nothing then -- the value is whatever is returned by 'getCurrentDirectory' -- This cooresponds to the --current-dir or -c arguments @@ -84,6 +112,9 @@ | NoDebounce deriving (Eq, Show, Read, Ord) +-- use the new vinyl for the options +-- the you get the monoid instance for free + instance Default Options where def = Options { log = NoLogger @@ -97,6 +128,24 @@ , currentDir = Nothing } +dropDoubleQuotes :: String -> String +dropDoubleQuotes [] = [] +dropDoubleQuotes (x : xs) + | x == '\"' = xs + | otherwise = x : xs + +stripDoubleQuotes :: String -> String +stripDoubleQuotes = dropDoubleQuotes . reverse . dropDoubleQuotes . reverse + +-- strip quotes if they are there +readFilePath :: String -> Either String FilePath +readFilePath xs = + let filePath = F.decodeString $ stripDoubleQuotes xs + in if F.valid filePath then + Right filePath + else + Left $ "invalid filePath " ++ xs + pOptions :: Parser Options pOptions = Options @@ -107,32 +156,30 @@ <> help "Type of logger. Valid options are LogToStdout | LogToFile | NoLogger" <> value (log def) ) - <*> option auto + <*> option (Just <$> eitherReader readFilePath) ( long "log-file" <> short 'f' <> metavar "LOG_FILE" <> help "Log file" <> value (logFile def) ) - <*> option auto - ( long "directories" + <*> many (option (eitherReader readFilePath) + ( long "directory" <> short 'd' <> metavar "DIRECTORIES" <> help "Directories to watch" - <> value (dirsToWatch def) ) - <*> option auto - ( long "recurse" + ) + <*> flag True False + ( long "no-recurse" <> short 'r' - <> metavar "RECURSE" - <> help "Boolean to recurse or directories or not" - <> value (recurseThroughDirectories def) + <> help "flag to turn off recursing" ) <*> option auto ( long "debounce" <> short 'b' <> metavar "DEBOUNCE" - <> help "Target for the greeting" + <> help "Type of debouncing. Valid choices are DebounceDefault | Debounce | NoDebounce" <> value (debounce def) ) <*> option auto @@ -149,14 +196,12 @@ <> help "Poll interval if polling is used" <> value (pollInterval def) ) - <*> option auto - ( long "poll" + <*> switch + ( long "should-poll" <> short 'p' - <> metavar "POLL" - <> help "Whether to use polling or not" - <> value (usePolling def) + <> help "Whether to use polling or not. Off by default" ) - <*> option auto + <*> option (Just <$> eitherReader readFilePath) ( long "current-dir" <> short 'c' <> metavar "CURRENT_DIR" @@ -166,26 +211,33 @@ -- This is like run, but the config params can be over written from the defaults +toDB :: Real a => a -> DebounceType -> FS.Debounce toDB amount dbtype = case dbtype of DebounceDefault -> FS.DebounceDefault Debounce -> FS.Debounce $ fromRational $ toRational amount NoDebounce -> FS.NoDebounce +makeAbsolute :: F.FilePath -> F.FilePath -> F.FilePath +makeAbsolute currentDir path = + if F.relative path then + currentDir F. path + else + path + optionsToConfig :: Options -> IO (FilePath, IR.Config, Maybe Handle) optionsToConfig Options {..} = do - actualCurrentDir <- getCurrentDirectory + actualCurrentDir <- F.decodeString <$> getCurrentDirectory let currentDir' = fromMaybe actualCurrentDir currentDir dirsToWatch' = if null dirsToWatch then [currentDir'] else - dirsToWatch + map (makeAbsolute currentDir') dirsToWatch (logger, mhandle) <- toLogger (fromMaybe "log.txt" logFile) log - let encodedDirs = map F.decodeString dirsToWatch' dirsToWatch'' <- if recurseThroughDirectories then - (encodedDirs ++) <$> concatMapM findAllDirs encodedDirs + (dirsToWatch' ++) <$> concatMapM findAllDirs dirsToWatch' else - return encodedDirs + return dirsToWatch' let watchConfig = FS.WatchConfig { FS.confDebounce = toDB debounceAmount debounce @@ -200,6 +252,13 @@ } return (currentDir', config, mhandle) +opts :: ParserInfo Options +opts = info (helper <*> pOptions) + ( fullDesc + <> progDesc "twitch" + <> header "a file watcher" + ) + -- | Simplest way to create a file watcher app. Set your main equal to defaultMain -- and you are good to go. See the module documentation for examples. -- @@ -208,11 +267,6 @@ -- executable made with defaultMain with the --help argument. defaultMain :: Dep -> IO () defaultMain dep = do - let opts = info (helper <*> pOptions) - ( fullDesc - <> progDesc "twitch" - <> header "a file watcher" - ) options <- execParser opts defaultMainWithOptions options dep @@ -220,8 +274,7 @@ defaultMainWithOptions :: Options -> Dep -> IO () defaultMainWithOptions options dep = do (currentDir, config, mhandle) <- optionsToConfig options - let currentDir' = F.decodeString currentDir - manager <- runWithConfig currentDir' config dep + manager <- runWithConfig currentDir config dep putStrLn "Type anything to quit" _ <- getLine for_ mhandle hClose diff --git a/src/Twitch/Path.hs b/src/Twitch/Path.hs --- a/src/Twitch/Path.hs +++ b/src/Twitch/Path.hs @@ -12,14 +12,9 @@ , canonicalizeDirPath , canonicalizePath ) where - +import Filesystem.Path.CurrentOS ( FilePath, encodeString, decodeString, () ) import Prelude hiding (FilePath) - import Control.Monad --- import Filesystem --- import Filesystem.Path hiding (concat) -import Filesystem.Path.CurrentOS hiding (concat) - import qualified Filesystem as FS import qualified Filesystem.Path as FP diff --git a/src/Twitch/Rule.hs b/src/Twitch/Rule.hs --- a/src/Twitch/Rule.hs +++ b/src/Twitch/Rule.hs @@ -1,25 +1,17 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Twitch.Rule where -import Data.Map (Map) -import Control.Applicative -import Control.Monad -import Filesystem.Path -import Filesystem.Path.CurrentOS import Prelude hiding (FilePath) -import System.Directory -import System.FilePath.Glob -import Data.Monoid -import Data.Time.Clock -import Data.String -import Data.Default -import Control.Arrow -import Data.Either -import Debug.Trace -import System.FSNotify (WatchManager) +import Control.Monad ( void ) +import Filesystem.Path ( FilePath ) +import Filesystem.Path.CurrentOS ( encodeString ) +import System.FilePath.Glob ( simplify, match, tryCompileWith, compDefault ) +import Data.Monoid ( (<>) ) +import Data.String ( IsString(..) ) +import Data.Default ( Default(..) ) +import Control.Arrow ( ArrowChoice(left) ) + type Name = String type PatternText = String @@ -80,12 +72,14 @@ -- Prefix API ----------------------------------------------------------------- addF, modifyF, deleteF, addModifyF :: (FilePath -> IO a) -> Rule -> Rule -addF = flip (|+) -modifyF = flip (|%) -deleteF = flip (|-) -nameF = flip (|#) +addF = flip (|+) +modifyF = flip (|%) +deleteF = flip (|-) addModifyF = flip (|>) +nameF :: String -> Rule -> Rule +nameF = flip (|#) + -- def & add foo & modify foo & delete foo & test tester -- def & add foo & modify foo & delete foo & pattern tester @@ -96,11 +90,11 @@ compilePattern :: FilePath -> PatternText -> Either RuleIssue (FilePath -> Bool) -compilePattern currentDir pattern = left (PatternCompliationFailed pattern) $ do +compilePattern currentDir pat = left (PatternCompliationFailed pat) $ do -- TODO is this way of adding the current directory cross platfrom okay? -- Does the globbing even work on windows - let absolutePattern = encodeString currentDir <> "/" <> pattern + let absolutePattern = encodeString currentDir <> "/" <> pat p <- tryCompileWith compDefault absolutePattern let test = match $ simplify p return $ \x -> test $ encodeString x diff --git a/src/Twitch/Run.hs b/src/Twitch/Run.hs --- a/src/Twitch/Run.hs +++ b/src/Twitch/Run.hs @@ -1,29 +1,29 @@ module Twitch.Run where -import Twitch.Internal -import Twitch.InternalRule -import Twitch.Rule (RuleIssue) -import Data.Either import Prelude hiding (FilePath, log) -import Filesystem.Path -import Filesystem.Path.CurrentOS -import Control.Applicative -import System.FSNotify -import System.Directory -import Twitch.Path -import Data.Default -import Debug.Trace +import Twitch.Internal ( Dep, runDep ) +import Twitch.InternalRule + ( Config(dirs, logger), InternalRule, toInternalRule, setupRules ) +import Twitch.Rule ( RuleIssue ) +import Data.Either ( partitionEithers ) +import Filesystem.Path ( FilePath ) +import Filesystem.Path.CurrentOS ( decodeString ) +import Control.Applicative ( (<$>) ) +import System.FSNotify ( WatchManager ) +import System.Directory ( getCurrentDirectory ) +import Twitch.Path ( findAllDirs ) +import Data.Default ( Default(def) ) -- This the main interface for running a Dep run :: Dep -> IO WatchManager run dep = do currentDir <- decodeString <$> getCurrentDirectory - dirs <- findAllDirs currentDir - runWithConfig currentDir (def { logger = print, dirs = dirs }) dep + dirs' <- findAllDirs currentDir + runWithConfig currentDir (def { logger = print, dirs = dirs' }) dep runWithConfig :: FilePath -> Config -> Dep -> IO WatchManager runWithConfig currentDir config dep = do - let (issues, rules) = depToRules currentDir dep + let (_issues, rules) = depToRules currentDir dep -- TODO handle the issues somehow -- Log and perhaps error setupRules config rules diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,6 @@ +module Main where +import Test.Hspec +import Tests.Twitch + +main :: IO () +main = hspec tests diff --git a/twitch.cabal b/twitch.cabal --- a/twitch.cabal +++ b/twitch.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: twitch -version: 0.1.5.1 +version: 0.1.6.1 synopsis: A high level file watcher DSL description: Twitch is a monadic DSL and library for file watching. @@ -57,16 +57,34 @@ , MultiParamTypeClasses , TypeSynonymInstances , TemplateHaskell - build-depends: base >=4.5 && <4.8 - , containers >=0.5 && <0.6 - , system-filepath >=0.4 && <0.5 - , mtl >=2.1 && <2.2 - , directory >=1.2 && <1.3 - , Glob >=0.7 && <0.8 - , time >=1.4 && <1.5 - , data-default >=0.5 && <0.6 - , fsnotify >=0.1 && <0.2 - , optparse-applicative >=0.11 && <0.12 - , system-fileio >=0.3 && <0.4 - hs-source-dirs: src - default-language: Haskell2010 + build-depends: base >=4.5 && <4.9 + , system-filepath + , transformers + , directory + , Glob + , time + , data-default + , fsnotify + , optparse-applicative + , system-fileio + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: tests, src + default-language: Haskell2010 + build-depends: base + , hspec + , QuickCheck >= 2.7 + , system-filepath + , transformers + , directory + , Glob + , time + , data-default + , fsnotify + , optparse-applicative + , system-fileio