diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -3,6 +3,8 @@ import qualified Data.Text as T import Data.Attoparsec.Text (parseOnly, endOfInput, eitherP) import Data.Attoparsec.Path (absFilePath, relFilePath, absDirPath) +import Data.Conduit ((=$=), runConduit) +import Data.Conduit.Combinators (stdout) import System.INotify (initINotify, removeWatch, killINotify) import System.File.Follow (follow) import System.Directory (getCurrentDirectory) @@ -25,4 +27,4 @@ Right d' -> pure (d' r) i <- initINotify - bracket (follow i f BS.putStr) (\watch -> removeWatch watch >> killINotify i) $ \_ -> forever $ threadDelay 50000 + bracket (follow i f (\source -> runConduit $ source =$= stdout)) (\watch -> removeWatch watch >> killINotify i) $ \_ -> forever $ threadDelay 50000 diff --git a/follow-file.cabal b/follow-file.cabal --- a/follow-file.cabal +++ b/follow-file.cabal @@ -1,5 +1,5 @@ Name: follow-file -Version: 0.0.1.2 +Version: 0.0.2 Author: Athan Clark Maintainer: Athan Clark License: BSD3 @@ -21,27 +21,32 @@ , attoparsec , attoparsec-path , bytestring + , conduit , directory + , exceptions , hinotify + , monad-control + , mtl , path , text , unix , utf8-string - , vector Executable follow-file - Default-Language: Haskell2010 - Hs-Source-Dirs: app - Main-is: Main.hs - Build-Depends: base - , bytestring - , follow-file - , path - , text - , attoparsec - , attoparsec-path - , hinotify - , directory + Default-Language: Haskell2010 + Hs-Source-Dirs: app + Main-is: Main.hs + Build-Depends: base + , bytestring + , follow-file + , path + , text + , attoparsec + , attoparsec-path + , hinotify + , conduit + , conduit-combinators + , directory Source-Repository head Type: git diff --git a/src/System/File/Follow.hs b/src/System/File/Follow.hs --- a/src/System/File/Follow.hs +++ b/src/System/File/Follow.hs @@ -2,6 +2,8 @@ ScopedTypeVariables , NamedFieldPuns , TupleSections + , Rank2Types + , FlexibleContexts #-} module System.File.Follow where @@ -10,13 +12,15 @@ import qualified Data.ByteString.Lazy.Internal as LBS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.UTF8 as BS8 -import qualified Data.Vector as V import qualified Data.Text as T import Data.Attoparsec.Text (parseOnly, endOfInput) import Data.Attoparsec.Path (relFilePath) -import Control.Monad (when) -import Control.Exception (bracket) -import Path (Path, Abs, File, filename, parent, toFilePath, parseRelFile) +import Data.Conduit (Producer, yield) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Catch (MonadMask, bracket) +import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith)) +import Path (Path, Abs, File, filename, parent, toFilePath) import System.Posix.IO.ByteString (fdReadBuf, openFd, OpenMode (ReadOnly), defaultFileFlags, closeFd, fdSeek) import System.Posix.Types (FileOffset) import System.Posix.Files.ByteString (fileSize, getFileStatus) @@ -28,48 +32,53 @@ -- | 'follow' takes a file, and informs you /only/ when it changes. If it's deleted, -- | you're notified with an empty 'Data.ByteString.ByteString'. If it doesn't exist yet, you'll be informed -- | of its entire contents upon it's creation, and will proceed to "follow it" as normal. -follow :: INotify - -> Path Abs File - -> (LBS.ByteString -> IO ()) - -> IO WatchDescriptor +follow :: ( MonadIO m + , MonadMask m + , MonadBaseControl IO m + ) + => INotify + -> Path Abs File + -> (Producer m BS.ByteString -> m ()) -- ^ Monadic state of @m@ is thrown away for each invocation, not synchronously interleaved. + -> m WatchDescriptor follow inotify file f = do let file' = toFilePath file - exists <- doesFileExist file' - (positionRef :: IORef FileOffset) <- + exists <- liftIO (doesFileExist file') + (positionRef :: IORef FileOffset) <- liftIO $ if exists then getFileStatus (BS8.fromString file') >>= (newIORef . fileSize) else newIORef 0 - let go = bracket (openFd (BS8.fromString file') ReadOnly Nothing defaultFileFlags) - closeFd $ \fd -> do - toSeek <- readIORef positionRef - idx <- fdSeek fd AbsoluteSeek toSeek - writeIORef positionRef idx - let loop acc = do - c <- BS.createUptoN LBS.defaultChunkSize $ \ptr -> do + let go = bracket (liftIO $ openFd (BS8.fromString file') ReadOnly Nothing defaultFileFlags) + (liftIO . closeFd) $ \fd -> do + toSeek <- liftIO (readIORef positionRef) + idx <- liftIO (fdSeek fd AbsoluteSeek toSeek) + liftIO (writeIORef positionRef idx) + let loop = do + c <- liftIO $ BS.createUptoN LBS.defaultChunkSize $ \ptr -> do seeked <- readIORef positionRef moreRead <- fdReadBuf fd ptr (fromIntegral LBS.defaultChunkSize) writeIORef positionRef (seeked + fromIntegral moreRead) pure (fromIntegral moreRead) if c == mempty - then pure acc - else loop (acc `V.snoc` c) - theRest <- loop V.empty - when (theRest /= V.empty) (f (V.foldr LBS.chunk mempty theRest)) + then pure () + else do + yield c + loop + f loop stop = do - writeIORef positionRef 0 - f mempty - addWatch inotify [Modify, Create, Delete] (toFilePath $ parent file) $ \e -> + liftIO (writeIORef positionRef 0) + f (yield mempty) + liftBaseWith $ \runInBase -> addWatch inotify [Modify, Create, Delete] (toFilePath $ parent file) $ \e -> let isFile filePath = parseOnly (relFilePath <* endOfInput) (T.pack filePath) == Right (filename file) in case e of - Created {filePath} | isFile filePath -> go + Created {filePath} | isFile filePath -> void $ runInBase go | otherwise -> pure () - Deleted {filePath} | isFile filePath -> stop + Deleted {filePath} | isFile filePath -> void $ runInBase stop | otherwise -> pure () - Modified {maybeFilePath} | (isFile <$> maybeFilePath) == Just True -> go + Modified {maybeFilePath} | (isFile <$> maybeFilePath) == Just True -> void $ runInBase go | otherwise -> pure () - MovedIn {filePath} | isFile filePath -> go + MovedIn {filePath} | isFile filePath -> void $ runInBase go | otherwise -> pure () - MovedOut {filePath} | isFile filePath -> go + MovedOut {filePath} | isFile filePath -> void $ runInBase go | otherwise -> pure () DeletedSelf -> error "containing folder deleted" Unmounted -> error "containing folder unmounted"