diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2016 FP Complete + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +# fsnotify-conduit + +Get filesystem notifications as a stream of events, using the conduit +package to handle the stream. This uses the +[fsnotify package](https://www.stackage.org/package/fsnotify), which +uses OS-specific file notification APIs for efficiency. Simple usage +example, a program which will print all events for the given directory +tree: + +``` haskell +#!/usr/bin/env stack +{- stack + --resolver lts-6.15 + --install-ghc + runghc + --package fsnotify-conduit + --package conduit-combinators + -} + +import Conduit +import Data.Conduit.FSNotify +import System.Environment (getArgs) + +main :: IO () +main = do + args <- getArgs + dir <- + case args of + [dir] -> return dir + _ -> error $ "Expected one argument (directory to watch)" + runResourceT + $ sourceFileChanges (setRelative False $ mkFileChangeSettings dir) + $$ mapM_C (liftIO . print) +``` 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/fsnotify-conduit.cabal b/fsnotify-conduit.cabal new file mode 100644 --- /dev/null +++ b/fsnotify-conduit.cabal @@ -0,0 +1,48 @@ +name: fsnotify-conduit +version: 0.1.0.0 +synopsis: Get filesystem notifications as a stream of events +description: Please see README.md +homepage: https://github.com/fpco/fsnotify-conduit#readme +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@snoyman.com +copyright: 2016 FP Complete +category: Data, Conduit +build-type: Simple +extra-source-files: README.md ChangeLog.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.Conduit.FSNotify + build-depends: base >= 4.7 && < 5 + , conduit + , directory + , filepath + , fsnotify + , resourcet + , transformers + default-language: Haskell2010 + +test-suite fsnotify-conduit-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Data.Conduit.FSNotifySpec + build-depends: base + , async + , conduit + , directory + , filepath + , fsnotify-conduit + , hspec + , resourcet + , temporary + , transformers + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/fpco/fsnotify-conduit diff --git a/src/Data/Conduit/FSNotify.hs b/src/Data/Conduit/FSNotify.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/FSNotify.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Data.Conduit.FSNotify + ( -- * Conduit API + sourceFileChanges + , FileChangeSettings + , mkFileChangeSettings + + -- * Setters + , setWatchConfig + , setRelative + , setRecursive + , setPredicate + + -- * Re-exports + , FS.Event (..) + , FS.eventTime + , FS.eventPath + , FS.WatchConfig (..) + , FS.Debounce (..) + ) where + +import Control.Exception (assert) +import Data.Conduit +import Control.Monad.Trans.Resource (MonadResource) +import Control.Monad.IO.Class (liftIO) +import Control.Monad (forever) +import qualified System.FSNotify as FS +import System.Directory (canonicalizePath) +import Control.Concurrent.Chan +import Data.List (stripPrefix) +import System.FilePath (addTrailingPathSeparator) + +-- | Settings for watching for file changes, to be passed in to +-- 'sourceFileChanges'. Should be created with 'mkFileChangeSettings'. +-- +-- @since 0.1.0.0 +data FileChangeSettings = FileChangeSettings + { fcsDir :: !FilePath + , fcsWatchConfig :: !FS.WatchConfig + , fcsRelative :: !Bool + , fcsRecursive :: !Bool + , fcsPredicate :: !(FS.Event -> Bool) + } + +-- | Override the 'FS.WatchConfig' when creating the 'FS.WatchManager'. +-- +-- Default: 'FS.defaultConfig' +-- +-- @since 0.1.0.0 +setWatchConfig :: FS.WatchConfig -> FileChangeSettings -> FileChangeSettings +setWatchConfig x fcs = fcs { fcsWatchConfig = x } + +-- | Whether to provide paths relative to the root directory (@True@) +-- or absolute paths (@False@). +-- +-- Default: 'True' (relative paths) +-- +-- @since 0.1.0.0 +setRelative :: Bool -> FileChangeSettings -> FileChangeSettings +setRelative x fcs = fcs { fcsRelative = x } + +-- | Recursively watch a directory tree? +-- +-- Default: 'True' +-- +-- @since 0.1.0.0 +setRecursive :: Bool -> FileChangeSettings -> FileChangeSettings +setRecursive x fcs = fcs { fcsRecursive = x } + +-- | Predicate used to filter events. +-- +-- Default: @const True@ (allow all events) +-- +-- @since 0.1.0.0 +setPredicate :: (FS.Event -> Bool) -> FileChangeSettings -> FileChangeSettings +setPredicate x fcs = fcs { fcsPredicate = x } + +-- | Create a 'FileChangeSettings' from a directory to watch. Provides +-- defaults which can be overridden by the setter functions in this +-- module, such as 'setRelative'. +-- +-- @since 0.1.0.0 +mkFileChangeSettings :: FilePath -- ^ directory to watch + -> FileChangeSettings +mkFileChangeSettings dir = FileChangeSettings + { fcsDir = dir + , fcsWatchConfig = FS.defaultConfig + , fcsRelative = True + , fcsRecursive = True + , fcsPredicate = const True + } + +-- | Watch for changes to a directory, and yield the file paths +-- downstream. Typical usage would be: +-- +-- @ +-- sourceFileChanges (setRelative False $ mkFileChangeSettings dir) +-- @ +-- +-- @since 0.1.0.0 +sourceFileChanges :: MonadResource m + => FileChangeSettings + -> Producer m FS.Event +sourceFileChanges FileChangeSettings {..} = + -- The bracketP function allows us to safely allocate some resource + -- and guarantee it will be cleaned up. In our case, we are calling + -- startManager to allocate a file watching manager, and stopManager + -- to clean it up. These functions will under the surface tie in to + -- OS-specific file watch mechanisms, such as inotify on Linux. + bracketP (FS.startManagerConf fcsWatchConfig) FS.stopManager $ \man -> do + -- Get the absolute path of the root directory + root' <- liftIO $ canonicalizePath fcsDir + + -- Create a channel for communication between two threads. Since + -- file watch events come in asynchronously on separate threads, + -- we want to fill up a channel with those events, and then below + -- read the values off that channel. + chan <- liftIO newChan + + -- Start watching a directory tree, accepting all events (const True). + let watchChan = if fcsRecursive then FS.watchTreeChan else FS.watchDirChan + bracketP (watchChan man root' fcsPredicate chan) id $ const $ forever $ do + event <- liftIO $ readChan chan + + if fcsRelative + then do + -- The complete file path of the event. + let fp = FS.eventPath event + + -- Since we want the path relative to the directory root, + -- strip off the root from the file path + case stripPrefix (addTrailingPathSeparator root') fp of + Nothing -> assert False $ return () + Just suffix + -- Ignore changes to the root directory itself + | null suffix -> return () + + -- Got a change to the file, write it to the channel + | otherwise -> yield $ + case event of + FS.Added _ time -> FS.Added suffix time + FS.Modified _ time -> FS.Modified suffix time + FS.Removed _ time -> FS.Removed suffix time + else yield event diff --git a/test/Data/Conduit/FSNotifySpec.hs b/test/Data/Conduit/FSNotifySpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Conduit/FSNotifySpec.hs @@ -0,0 +1,39 @@ +module Data.Conduit.FSNotifySpec where + +import Test.Hspec (Spec, it, shouldBe) +import Data.Conduit (($$)) +import qualified Data.Conduit.List as CL +import Control.Monad.Trans.Resource (runResourceT) +import Data.Conduit.FSNotify +import Control.Concurrent.Chan (newChan, writeChan, readChan) +import Control.Applicative ((<|>)) +import Control.Monad (forM_) +import Control.Concurrent.Async (Concurrently (..)) +import Control.Concurrent (threadDelay) +import System.FilePath (()) +import System.Directory (removeFile) +import System.IO.Temp (withSystemTempDirectory) +import Control.Monad.IO.Class (liftIO) + +spec :: Spec +spec = do + it "sourceFileChanges" $ withSystemTempDirectory "source-file-changes" $ \root -> do + chan <- newChan + let actions = + [ ("foo", Just "hello") + , ("bar", Just "world") + , ("foo", Just "!") + , ("bar", Nothing) + , ("foo", Nothing) + ] + runConcurrently $ + Concurrently (runResourceT $ sourceFileChanges (mkFileChangeSettings root) + $$ CL.mapM_ (liftIO . writeChan chan)) <|> + Concurrently (forM_ actions $ \(path, mcontents) -> do + threadDelay 100000 + case mcontents of + Nothing -> removeFile (root path) + Just contents -> writeFile (root path) contents) <|> + Concurrently (forM_ actions $ \(expected, _) -> do + event <- readChan chan + eventPath event `shouldBe` expected) 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 #-}