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.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 System.Posix.IO.ByteString (fdReadBuf, openFd, OpenMode (ReadOnly), defaultFileFlags, closeFd, fdSeek)
import System.Posix.Types (FileOffset)
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 :: INotify
-> Path Abs File
-> (LBS.ByteString -> IO ())
-> IO WatchDescriptor
follow inotify file f = do
let file' = toFilePath file
exists <- doesFileExist file'
(positionRef :: IORef FileOffset) <-
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
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))
stop = do
writeIORef positionRef 0
f mempty
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
| otherwise -> pure ()
Deleted {filePath} | isFile filePath -> stop
| otherwise -> pure ()
Modified {maybeFilePath} | (isFile <$> maybeFilePath) == Just True -> go
| otherwise -> pure ()
MovedIn {filePath} | isFile filePath -> go
| otherwise -> pure ()
MovedOut {filePath} | isFile filePath -> go
| otherwise -> pure ()
DeletedSelf -> error "containing folder deleted"
Unmounted -> error "containing folder unmounted"
QOverflow -> error "queue overflow"
_ -> pure ()