import qualified System.INotify as INotify
import Control.Concurrent.STM
import qualified Data.ByteString as S
+import qualified System.FilePath.ByteString as P
import Data.Time.Clock.POSIX
#endif
-- The file does not need to exist yet when this is called. It will wait
-- for the file to appear before opening it and starting verification.
--
--- This is not supported for all OSs, and will return False on OS's
--- where it is not supported.
+-- This is not supported for all OSs, and on OS's where it is not
+-- supported, verification will fail.
--
-- Note that there are situations where the file may fail to verify despite
-- having the correct content. For example, when the file is written out
-- of order, or gets replaced part way through. To deal with such cases,
--- when False is returned, it should not be treated as if the file's
+-- when verification fails, it should not be treated as if the file's
-- content is known to be incorrect, but instead as an indication that the
-- file should be verified again, once it's done being written to.
--
-- writer has finished. If there is more work still to do, it returns an IO
-- action that will complete the work. This way, the caller can display
-- something appropriate while that is running.
-tailVerify :: IncrementalVerifier -> FilePath -> TMVar () -> IO (Either (IO Bool) Bool)
+tailVerify :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO (Maybe (IO ()))
#if WITH_INOTIFY
tailVerify iv f finished =
- catchDefaultIO (Right False) $
- INotify.withINotify $ \i -> do
- h <- waitforfiletoexist i
- tryIO (go i h) >>= \case
- Right r -> return r
- Left _ -> do
- maybe noop hClose h
- return (Right False)
+ tryIO go >>= \case
+ Right r -> return r
+ Left _ -> do
+ failIncremental iv
+ return Nothing
where
- rf = toRawFilePath f
- d = toRawFilePath (takeDirectory f)
-
- waitforfiletoexist i = tryIO (openBinaryFile f ReadMode) >>= \case
+ f' = fromRawFilePath f
+ waitforfiletoexist i = tryIO (openBinaryFile f' ReadMode) >>= \case
Right h -> return (Just h)
Left _ -> do
hv <- newEmptyTMVarIO
wd <- inotifycreate i $
- tryIO (openBinaryFile f ReadMode) >>= \case
+ tryIO (openBinaryFile f' ReadMode) >>= \case
Right h ->
unlessM (atomically $ tryPutTMVar hv h) $
hClose h
INotify.removeWatch wd
return v
- inotifycreate i cont = INotify.addWatch i evs d $ \case
+ inotifycreate i cont = INotify.addWatch i evs (P.takeDirectory f) $ \case
-- Ignore changes to other files in the directory.
INotify.Created { INotify.filePath = fn }
- | fn /= rf -> noop
+ | fn /= f -> noop
INotify.MovedIn { INotify.filePath = fn }
- | fn /= rf -> noop
+ | fn /= f -> noop
INotify.Opened { INotify.maybeFilePath = fn }
- | fn /= Just rf -> noop
+ | fn /= Just f -> noop
INotify.Modified { INotify.maybeFilePath = fn }
- | fn /= Just rf -> noop
+ | fn /= Just f -> noop
_ -> cont
where
evs =
, INotify.Modify
]
- go i (Just h) = do
+ go = INotify.withINotify $ \i -> do
+ h <- waitforfiletoexist i
+ tryIO (go' i h) >>= \case
+ Right r -> return r
+ Left _ -> do
+ maybe noop hClose h
+ failIncremental iv
+ return Nothing
+
+ go' i (Just h) = do
modified <- newEmptyTMVarIO
- wd <- INotify.addWatch i [INotify.Modify] rf $ \_event ->
+ wd <- INotify.addWatch i [INotify.Modify] f $ \_event ->
atomically $ void $ tryPutTMVar modified ()
r <- follow h modified
INotify.removeWatch wd
return r
-- File never showed up, but we've been told it's done being
-- written to.
- go _ Nothing = return (Right False)
+ go' _ Nothing = do
+ failIncremental iv
+ return Nothing
follow h modified = do
b <- S.hGetNonBlocking h chunk
if S.null b
then do
hClose h
- Right <$> finalizeIncremental iv
+ return Nothing
else do
updateIncremental iv b
now <- getPOSIXTime
if now - starttime > 0.5
- then return (Left (deferredfinish h))
+ then return $ Just $
+ tryIO (deferredfinish h) >>= \case
+ Right () -> noop
+ Left _ -> failIncremental iv
else finish h starttime
deferredfinish h = do
b <- S.hGet h chunk
if S.null b
- then do
- hClose h
- finalizeIncremental iv
+ then hClose h
else do
updateIncremental iv b
deferredfinish h
chunk = 65536
#else
-tailVerify _ _ _ = return (Right False) -- not supported
+tailVerify iv _ _ = do
+ failIncremental iv
+ return Nothing
#endif
-
mkIncrementalVerifier :: HashAlgorithm h => Context h -> Key -> IO IncrementalVerifier
mkIncrementalVerifier ctx key = do
- v <- newIORef ctx
+ v <- newIORef (Just ctx)
return $ IncrementalVerifier
- { updateIncremental = modifyIORef' v . flip hashUpdate
- , finalizeIncremental = do
- ctx' <- readIORef v
- let digest = hashFinalize ctx'
- return $ sameCheckSum key (show digest)
+ { updateIncremental = \b ->
+ modifyIORef' v $ \case
+ Just ctx' -> Just (hashUpdate ctx' b)
+ Nothing -> Nothing
+ , finalizeIncremental =
+ readIORef v >>= \case
+ Just ctx' -> do
+ let digest = hashFinalize ctx'
+ return $ sameCheckSum key (show digest)
+ Nothing -> return False
+ , failIncremental = writeIORef v Nothing
}
{- A varient of the SHA256E backend, for testing that needs special keys
projects / git-annex.git / commitdiff