watcher (empty) → 0.0.1

raw patch · 5 files changed

+357/−0 lines, 5 filesdep +basedep +filepathdep +hinotifysetup-changed

Dependencies added: base, filepath, hinotify

Files

• LICENSE +19/−0
• Setup.lhs +59/−0
• src/Watcher.hs +206/−0
• tests/doctests.hs +34/−0
• watcher.cabal +39/−0

@@ -0,0 +1,19 @@+Copyright © 2013 Nathaniel Soares++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.

@@ -0,0 +1,59 @@+#!/usr/local/bin/runhaskell++Copied from Edward Kmett's lens package: «https://github.com/ekmett/lens/blob/master/Setup.lhs»+Many thanks to Edward Kmett.++\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  , postHaddock = \args flags pkg lbi -> do+     copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]+     postHaddock simpleUserHooks args flags pkg lbi+  }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+  baseDir = case haddockDistPref flags of+    NoFlag -> "."+    Flag x -> x+  destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}

@@ -0,0 +1,206 @@+module Watcher+	( watch+	, unwatch+	, Action(Added, Changed, Moved, Removed)+	, Warning(MovedOutOfScope)+	, Watcher+	, Handler+	) where+import Control.Applicative+import Control.Concurrent+import Control.Monad (unless)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Traversable (mapM)+import Prelude hiding (mapM)+import System.Directory+import System.INotify+import System.FilePath++-- |The types of actions that are reported.+data Action+	= Added+	| Changed+	| Moved FilePath+	| Removed+	deriving (Eq, Show)++-- |Badness that happened during a watch, usually due to inotify limitations.+data Warning+	= MovedOutOfScope FilePath+	deriving (Eq, Show)++-- |Functions that handle events+-- The filepaths passed will be joined with the path used to set up the watcher.+-- If you have+--    mydir/+--      file1+--      file2+-- And you do (watch myHandler "mydir") and file1 changes, myHandler will be+-- passed "mydir/file1" as the FilePath.+type Handler = Action -> FilePath -> IO ()++-- |A handler used to mutate and reference watchers.+data Watcher+	= Watcher+	{ notifier :: INotify+	, descriptors :: MVar (Map FilePath WatchDescriptor)+	, moves :: MVar (Map Cookie FilePath)+	} deriving Eq++-- |Applies a monadic function to a specific value of a map, and returns the map+-- with that value removed. If the key specifying the value is not in the map,+-- then the fallback is executed and the map is returned unmolested.+popM :: (Monad m, Ord k) => (v -> m u) -> m w -> k -> Map k v -> m (Map k v)+popM function fallback key dict = if key `Map.member` dict+	then function (dict Map.! key) >> return (key `Map.delete` dict)+	else fallback >> return dict++-- |Monadic variant of if.+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM mpred t f = do+	predicate <- mpred+	if predicate then t else f++-- |Whether a file is . or ..+isDirectoryReference :: FilePath -> Bool+isDirectoryReference = (`elem` [".", ".."])++startsWith :: FilePath -> FilePath -> Bool+startsWith prefix path = take (length prefix) path == prefix++-- All non-directory-reference files in a directory.+-- The returned paths are extensions of the input path.+-- If you have+--     mydir/+--       file1+--       file2+-- then (ls "mydir") yields [mydir/file1, mydir/file2]+ls :: FilePath -> IO [FilePath]+ls dir = do+	children <- getDirectoryContents dir+	pure $ addDirToEach $ filter isRelevant children+	where+	isRelevant = not . isDirectoryReference+	addDirToEach = map (dir </>)++-- |Like ls, but sorted. Directories on the left, files on the right.+directoriesAndFiles :: FilePath -> IO [Either FilePath FilePath]+directoriesAndFiles path = mapM partition =<< ls path+	where+	partition x = ifM (doesDirectoryExist x) (dir x) (file x)+	dir = pure . Left+	file = pure . Right++-- |Creates a watch for a single handler on a single directory.+watch :: Handler -> FilePath -> IO Watcher+watch handler filepath = do+	isDir <- doesDirectoryExist filepath+	unless isDir (ioError $ userError $ "Not a directory: " ++ filepath)+	watcher <- Watcher+		<$> initINotify+		<*> newMVar Map.empty+		<*> newMVar Map.empty+	watchDir watcher handler filepath+	pure watcher++-- |Used to generate watchDir and moveWatchedDir+watchDirWithInitializer+	:: (FilePath -> IO ())+	-> Watcher+	-> Handler+	-> FilePath+	-> IO ()+watchDirWithInitializer initialize watcher handler dir = do+	watchd <- addWatch (notifier watcher) relevantEvents dir event+	modifyMVar_ (descriptors watcher) (pure . Map.insert dir watchd)+	mapM_ (either recurse initialize) =<< directoriesAndFiles dir+	where+	recurse = watchDirWithInitializer initialize watcher handler+	moveFileTo = handler . Moved+	moveDirTo source = moveWatchedDir source watcher handler+	event :: Event -> IO ()+	-- New file created+	event (Created False child) = handler Added (dir </> child)+	-- New directory created.+	event (Created True child) = recurse (dir </> child)+	-- This file modified.+	event (Modified False Nothing) = handler Changed dir+	-- Child file modified.+	event (Modified False (Just child)) = handler Changed (dir </> child)+	-- Directory added via move.+	event (MovedIn True child cookie) = modifyMVar_ (moves watcher) (popM+		(`moveDirTo` (dir </> child))+		(recurse (dir </> child))+		cookie)+	-- File added via move.+	event (MovedIn False child cookie) = modifyMVar_ (moves watcher) (popM+		(`moveFileTo` (dir </> child))+		(handler Added (dir </> child))+		cookie)+	-- Something moved out. If it was moved out of scope, we can't fire events+	-- on it, because we don't know where it moved to. If you move watched/foo+	-- to ../bar, the MovedOut event only knows that watched/foo/ is gone.+	-- There's no way for us to figure out that it went to bar/, recurse bar/,+	-- and fire the moved events manually on the files there. Using inotify,+	-- there's no way for us to send move events unless the moved file lands in+	-- a watched directory.+	event (MovedOut _ child cookie) = modifyMVar_ (moves watcher)+		(pure . Map.insert cookie (dir </> child))+	-- Directory removed.+	event (Deleted True child) = unwatchDir watcher (dir </> child)+	-- File removed.+	event (Deleted False child) = handler Removed (dir </> child)+	-- Not relevant.+	-- Note that we don't in general care about directory modification.+	-- Self events are ignored and passed on to be handled by the parent.+	-- Other non-created/moved/modified/deleted events are ignored.+	event _ = pure ()++-- |Creates watchers on one directory, recursively.+watchDir :: Watcher -> Handler -> FilePath -> IO ()+watchDir watcher handler+	= watchDirWithInitializer (handler Added) watcher handler++-- |Moves a directory, firing the appropriate move events recursively.+-- The subdirectory watchers will be killed and recreated, which is a bit+-- expensive, but is far cleaner than manually maintaining the root-relative+-- path of each directory watcher.+moveWatchedDir :: FilePath -> Watcher -> Handler -> FilePath -> IO ()+moveWatchedDir source watcher handler dest = do+	unwatchDir watcher source+	watchDirWithInitializer moved watcher handler dest+	where+	oldPath path = source </> makeRelative dest path+	moved path = handler (Moved $ oldPath path) path++-- |Removes the watcher on one subdir and updates the watch dict accordingly.+-- Might be called after the directory has been moved/removed. It is not+-- possible in general to check the contents of the directory.+unwatchDir :: Watcher -> FilePath -> IO ()+unwatchDir watcher dir = modifyMVar_ (descriptors watcher) killChildren+	where+	killChildren dict = do+		let dying = Map.filterWithKey (\k _ -> startsWith dir k) dict+		mapM_ removeWatch $ Map.elems dying+		pure $ dict Map.\\ dying++-- |Shuts down all watching and the inotifier.+unwatch :: Watcher -> IO [Warning]+unwatch watcher = do+	lost <- withMVar (moves watcher) (pure . map MovedOutOfScope . Map.elems)+	modifyMVar_ (descriptors watcher) killDescriptors+	killINotify (notifier watcher)+	pure lost+	where+	killDescriptors dict = mapM removeWatch dict *> pure Map.empty++-- |inotify events that are listened to.+relevantEvents :: [EventVariety]+relevantEvents =+	[ Modify+	, Create+	, MoveIn+	, MoveOut+	, Delete+	]

@@ -0,0 +1,34 @@+-- Adapted from Edward Kmett's doctests test:+-- «https://github.com/ekmett/lens/blob/master/tests/doctests.hsc»+-- Many thanks to Edward Kmett.+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++main :: IO ()+main = getSources >>= \sources -> doctest $+	  "-XOverloadedStrings"+	: "-isrc"+	: "-idist/build/autogen"+	: "-optP-include"+	: "-optPdist/build/autogen/cabal_macros.h"+	: "-hide-all-packages"+	: map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+	where+		go dir = do+			(dirs, files) <- getFilesAndDirectories dir+			(files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+	c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+	(,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c

@@ -0,0 +1,39 @@+Name:          watcher+Version:       0.0.1+License:       MIT+License-file:  LICENSE+Category:      filesystem+Synopsis:      Opinionated filesystem watcher.+Description:   A thin opinionated wrapper around INotify. Fires+               Added/Changed/Moved/Removed events on files, and that's it.+               Watches (only files) recursively on a given directory.+               Designed for simple filesystem watchers that don't want to mess+               with INotify. Inherits all of INotify's limitations surrounding+               moved files: Events are not fired for overwritten files nor for+               files moved out of the watched directory.+Author:        Nate Soares+Maintainer:    nate@so8r.es+Build-Type:    Simple+Cabal-Version: >=1.14++Library+  default-language: Haskell2010+  build-depends:+    base >= 4 && < 5,+    filepath >= 1.3,+    hinotify >= 0.3.5+  exposed-modules: Watcher+  hs-source-dirs: src+  ghc-options: -Wall -rtsopts+  ghc-prof-options: -auto-all++test-suite doctests+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  ghc-options: -threaded+  main-is: doctests.hs+  hs-source-dirs: tests+  build-depends:+    base,+    filepath,+    hinotify