watcher 0.0.2 → 0.0.3.0

raw patch · 5 files changed

+135/−213 lines, 5 filesdep +basic-preludedep +system-fileiodep +system-filepathdep −directorydep −filepathdep ~basedep ~containersdep ~hinotifysetup-changed

Dependencies added: basic-prelude, system-fileio, system-filepath

Dependencies removed: directory, filepath

Dependency ranges changed: base, containers, hinotify

Files

• Setup.hs +2/−0
• Setup.lhs +0/−59
• src/Watcher.hs +108/−79
• tests/doctests.hs +0/−34
• watcher.cabal +25/−41

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

@@ -1,59 +0,0 @@-#!/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}

@@ -1,3 +1,5 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} module Watcher 	( watch 	, unwatch@@ -6,30 +8,46 @@ 	, Watcher 	, Handler 	) where-import Control.Applicative+import BasicPrelude hiding (stripPrefix, mapM) import Control.Concurrent-import Control.Monad (unless)-import Data.Map (Map)+	( MVar+	, newMVar+	, modifyMVar_+	, withMVar ) import qualified Data.Map as Map import Data.Traversable (mapM)-import Prelude hiding (mapM)-import System.Directory+import Filesystem+import Filesystem.Path.CurrentOS import System.INotify-import System.FilePath+	( Cookie+	, EventVariety(Create, Modify, Delete, MoveIn, MoveOut)+	, Event(Created, Modified, Deleted, MovedIn, MovedOut)+	, INotify+	, WatchDescriptor+	, addWatch+	, initINotify+	, killINotify+	, removeWatch ) + -- |The types of actions that are reported. data Action 	= Added 	| Changed+	-- NOTE: It is the user's responsibility to check if the destination already+	-- existed and, in the event that a file was overwritten, handle the+	-- overwritten file's removal. 	| 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@@ -40,6 +58,7 @@ -- passed "mydir/file1" as the FilePath. type Handler = Action -> FilePath -> IO () + -- |A handler used to mutate and reference watchers. data Watcher 	= Watcher@@ -48,13 +67,6 @@ 	, 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@@ -62,48 +74,44 @@ 	predicate <- mpred 	if predicate then t else f --- |Whether a file is . or ..-isDirectoryReference :: FilePath -> Bool-isDirectoryReference = (`elem` [".", ".."]) +-- |Makes path relative to base.+makeRelative :: FilePath -> FilePath -> FilePath+makeRelative base path = fromMaybe path stripped+	where+	stripped = stripPrefix (commonPrefix [base, path]) path+++-- |Whether or not path starts with prefix. startsWith :: FilePath -> FilePath -> Bool-startsWith prefix path = take (length prefix) path == prefix+startsWith prefix path = commonPrefix [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.+-- |Like listDirectory, but partitioned: directories left, files right. directoriesAndFiles :: FilePath -> IO [Either FilePath FilePath]-directoriesAndFiles path = mapM partition =<< ls path+directoriesAndFiles path = mapM divvy =<< listDirectory path 	where-	partition x = ifM (doesDirectoryExist x) (dir x) (file x)+	divvy x = ifM (isDirectory 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)+	-- Ensures that the path is treated as a directory.+	let dirpath = filepath </> ""+	isDir <- isDirectory dirpath+	unless isDir $ ioError $+		userError $ "Not a directory: " ++ encodeString dirpath 	watcher <- Watcher 		<$> initINotify 		<*> newMVar Map.empty 		<*> newMVar Map.empty-	watchDir watcher handler filepath+	watchDir watcher handler dirpath 	pure watcher + -- |Used to generate watchDir and moveWatchedDir watchDirWithInitializer 	:: (FilePath -> IO ())@@ -111,57 +119,75 @@ 	-> Handler 	-> FilePath 	-> IO ()-watchDirWithInitializer initialize watcher handler dir = do-	watchd <- addWatch (notifier watcher) relevantEvents dir event+watchDirWithInitializer initialize watcher handler filepath = do+	-- The filepath, guaranteed to be treated like a directory.+	let strdir = encodeString dir+	watchd <- addWatch (notifier watcher) relevantEvents strdir event 	modifyMVar_ (descriptors watcher) (pure . Map.insert dir watchd) 	mapM_ (either recurse initialize) =<< directoriesAndFiles dir 	where+	dir = filepath </> ""+	into child = dir </> decodeString child 	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 ()+	descend = recurse . into+	ascend = unwatchDir watcher . into+	add = handler Added . into+	remove = handler Removed . into+	change = handler Changed . into+	prepMove child cookie = modifyMVar_ (moves watcher)+		(pure . Map.insert cookie (into child))+	moveFile child cookie = modifyMVar_ (moves watcher) (\dict ->+		let source = dict Map.! cookie in+		if cookie `Map.member` dict+		then do+			handler (Moved source) (into child)+			pure $ Map.delete cookie dict+		else handler Added (into child) *> pure dict)+	moveDir child cookie = modifyMVar_ (moves watcher) (\dict ->+		let source = dict Map.! cookie in+		if cookie `Map.member` dict+		then do+			moveWatchedDir source watcher handler (into child)+			pure $ Map.delete cookie dict+		else recurse (into child) *> pure dict)+	event ev = case ev of+		-- New file created+		Created False child -> add child+		-- New directory created.+		Created True child -> descend child+		-- This file modified.+		Modified False Nothing -> handler Changed dir+		-- Child file modified.+		Modified False (Just child) -> change child+		-- Directory added via move.+		MovedIn True child cookie -> moveDir child cookie+		-- File added via move.+		MovedIn False child cookie -> moveFile 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.+		MovedOut _ child cookie -> prepMove child cookie+		-- Directory removed.+		Deleted True child -> ascend child+		-- File removed.+		Deleted False child -> remove child+		-- Not relevant.+		-- 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.+		_ -> 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@@ -171,9 +197,10 @@ 	unwatchDir watcher source 	watchDirWithInitializer moved watcher handler dest 	where-	oldPath path = source </> makeRelative dest path+	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.@@ -185,6 +212,7 @@ 		mapM_ removeWatch $ Map.elems dying 		pure $ dict Map.\\ dying + -- |Shuts down all watching and the inotifier. unwatch :: Watcher -> IO [Warning] unwatch watcher = do@@ -194,6 +222,7 @@ 	pure lost 	where 	killDescriptors dict = mapM removeWatch dict *> pure Map.empty+  -- |inotify events that are listened to. relevantEvents :: [EventVariety]

@@ -1,34 +0,0 @@--- 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

@@ -1,43 +1,27 @@-Name:          watcher-Version:       0.0.2-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,-    containers >= 0.4,-    directory >= 1.1,-    filepath >= 1.3,-    hinotify >= 0.3.5-  exposed-modules: Watcher-  hs-source-dirs: src-  ghc-options: -Wall -rtsopts-  ghc-prof-options: -auto-all+name:                watcher+version:             0.0.3.0+synopsis:            Opinionated filesystem watcher+license:             MIT+license-file:        LICENSE+author:              So8res+description:         A filesystem watcher. Triggers added/changed/removed events+                     when the filesystem changes. Can cache in an SQL database+                     and bring itself back up to date after long periods of+                     downtime.+maintainer:          nate@so8r.es+category:            System+build-type:          Simple+cabal-version:       >=1.10 -test-suite doctests+library   default-language: Haskell2010-  type: exitcode-stdio-1.0-  ghc-options: -threaded-  main-is: doctests.hs-  hs-source-dirs: tests-  build-depends:-    base,-    containers,-    directory,-    filepath,-    hinotify+  exposed-modules:     Watcher+  build-depends:       base ==4.5.*,+                       basic-prelude ==0.3.*,+                       containers ==0.4.*,+                       system-fileio ==0.3.*,+                       system-filepath ==0.4.*,+                       hinotify ==0.3.*+  hs-source-dirs:      src+  ghc-options:         -Wall -rtsopts+  ghc-prof-options:    -auto-all