{-# LANGUAGE
ScopedTypeVariables
, NamedFieldPuns
, TupleSections
, Rank2Types
, FlexibleContexts
#-}
module System.File.Follow where
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
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.Text.Encoding as T
import Data.Attoparsec.Text (parseOnly, endOfInput)
import Data.Attoparsec.Path (relFilePath)
import Data.Conduit (ConduitT, 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.ByteString.FilePath (RawFilePath)
import System.Posix.Files.ByteString (fileSize, getFileStatus)
import System.Directory (doesFileExist)
import System.INotify (INotify, addWatch, Event (..), EventVariety (..), WatchDescriptor)
import GHC.IO.Device (SeekMode (AbsoluteSeek))
follow :: ( MonadIO m
, MonadMask m
, MonadBaseControl IO m
)
=> INotify
-> Path Abs File
-> (ConduitT i BS.ByteString m () -> m ())
-> m WatchDescriptor
follow inotify file f = do
let file' = toFilePath file
exists <- liftIO (doesFileExist file')
(positionRef :: IORef FileOffset) <- liftIO $
if exists
then getFileStatus (BS8.fromString file') >>= (newIORef . fileSize)
else newIORef 0
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 ()
else do
yield c
loop
f loop
stop = do
liftIO (writeIORef positionRef 0)
f (yield mempty)
liftBaseWith $ \runInBase -> addWatch inotify [Modify, Create, Delete] (BS8.fromString $ toFilePath $ parent file) $ \e ->
let isFile :: RawFilePath -> Bool
isFile filePath = parseOnly (relFilePath <* endOfInput) (T.decodeUtf8 filePath) == Right (filename file)
in case e of
Created {filePath}
| isFile filePath -> void $ runInBase go
| otherwise -> pure ()
Deleted {filePath}
| isFile filePath -> void $ runInBase stop
| otherwise -> pure ()
Modified {maybeFilePath}
| (isFile <$> maybeFilePath) == Just True -> void $ runInBase go
| otherwise -> pure ()
MovedIn {filePath}
| isFile filePath -> void $ runInBase go
| otherwise -> pure ()
MovedOut {filePath}
| isFile filePath -> void $ runInBase go
| otherwise -> pure ()
DeletedSelf -> error "containing folder deleted"
Unmounted -> error "containing folder unmounted"
QOverflow -> error "queue overflow"
_ -> pure ()