summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Changes.hs15
-rw-r--r--Assistant/Threads/SanityChecker.hs6
-rw-r--r--Assistant/Threads/Watcher.hs154
3 files changed, 88 insertions, 87 deletions
diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs
index cccc372c1..b20dce09a 100644
--- a/Assistant/Changes.hs
+++ b/Assistant/Changes.hs
@@ -8,7 +8,6 @@
module Assistant.Changes where
import Common.Annex
-import qualified Annex.Queue
import Types.KeySource
import Utility.TSet
@@ -39,19 +38,15 @@ newChangeChan :: IO ChangeChan
newChangeChan = newTSet
{- Handlers call this when they made a change that needs to get committed. -}
-madeChange :: FilePath -> ChangeType -> Annex (Maybe Change)
-madeChange f t = do
- -- Just in case the commit thread is not flushing the queue fast enough.
- Annex.Queue.flushWhenFull
- liftIO $ Just <$> (Change <$> getCurrentTime <*> pure f <*> pure t)
+madeChange :: FilePath -> ChangeType -> IO (Maybe Change)
+madeChange f t = Just <$> (Change <$> getCurrentTime <*> pure f <*> pure t)
-noChange :: Annex (Maybe Change)
+noChange :: IO (Maybe Change)
noChange = return Nothing
{- Indicates an add needs to be done, but has not started yet. -}
-pendingAddChange :: FilePath -> Annex (Maybe Change)
-pendingAddChange f =
- liftIO $ Just <$> (PendingAddChange <$> getCurrentTime <*> pure f)
+pendingAddChange :: FilePath -> IO (Maybe Change)
+pendingAddChange f = Just <$> (PendingAddChange <$> getCurrentTime <*> pure f)
isPendingAddChange :: Change -> Bool
isPendingAddChange (PendingAddChange {}) = True
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index 6379eee46..d92c6c394 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -90,9 +90,5 @@ check = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ void $ addAlert dstatus $ sanityCheckFixAlert msg
addsymlink file s = do
- d <- getAssistant id
- liftIO $ Watcher.runHandler (threadName d)
- (threadState d) (daemonStatusHandle d)
- (transferQueue d) (changeChan d)
- Watcher.onAddSymlink file s
+ Watcher.runHandler Watcher.onAddSymlink file s
insanity $ "found unstaged symlink: " ++ file
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 7ab124b14..33d4196da 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -15,7 +15,6 @@ module Assistant.Threads.Watcher (
) where
import Assistant.Common
-import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.Changes
import Assistant.TransferQueue
@@ -37,9 +36,6 @@ import Git.Types
import Data.Bits.Utils
import qualified Data.ByteString.Lazy as L
-thisThread :: ThreadName
-thisThread = "Watcher"
-
checkCanWatch :: Annex ()
checkCanWatch
| canWatch =
@@ -55,35 +51,42 @@ needLsof = error $ unlines
, "Be warned: This can corrupt data in the annex, and make fsck complain."
]
-watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> NamedThread
-watchThread st dstatus transferqueue changechan = NamedThread thisThread $ liftIO $ do
- void $ watchDir "." ignored hooks startup
- brokendebug thisThread [ "watching", "."]
- where
- startup = startupScan st dstatus
- hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a
- hooks = mkWatchHooks
- { addHook = hook onAdd
- , delHook = hook onDel
- , addSymlinkHook = hook onAddSymlink
- , delDirHook = hook onDelDir
- , errHook = hook onErr
+watchThread :: NamedThread
+watchThread = NamedThread "Watcher" $ do
+ startup <- asIO startupScan
+ addhook <- hook onAdd
+ delhook <- hook onDel
+ addsymlinkhook <- hook onAddSymlink
+ deldirhook <- hook onDelDir
+ errhook <- hook onErr
+ let hooks = mkWatchHooks
+ { addHook = addhook
+ , delHook = delhook
+ , addSymlinkHook = addsymlinkhook
+ , delDirHook = deldirhook
+ , errHook = errhook
}
+ void $ liftIO $ watchDir "." ignored hooks startup
+ debug [ "watching", "."]
+ where
+ hook a = Just <$> asIO2 (runHandler a)
{- Initial scartup scan. The action should return once the scan is complete. -}
-startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
-startupScan st dstatus scanner = do
- runThreadState st $ showAction "scanning"
- alertWhile' dstatus startupScanAlert $ do
- r <- scanner
+startupScan :: IO a -> Assistant a
+startupScan scanner = do
+ liftAnnex $ showAction "scanning"
+ dstatus <- getAssistant daemonStatusHandle
+ alertWhile' dstatus startupScanAlert <~> do
+ r <- liftIO $ scanner
-- Notice any files that were deleted before
-- watching was started.
- runThreadState st $ do
+ liftAnnex $ do
inRepo $ Git.Command.run "add" [Param "--update"]
showAction "started"
- modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True }
+ liftIO $ modifyDaemonStatus_ dstatus $
+ \s -> s { scanComplete = True }
return (True, r)
@@ -95,52 +98,52 @@ ignored = ig . takeFileName
ig ".gitattributes" = True
ig _ = False
-type Handler = ThreadName -> FilePath -> Maybe FileStatus -> DaemonStatusHandle -> TransferQueue -> Annex (Maybe Change)
+type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change)
-{- Runs an action handler, inside the Annex monad, and if there was a
- - change, adds it to the ChangeChan.
+{- Runs an action handler, and if there was a change, adds it to the ChangeChan.
-
- Exceptions are ignored, otherwise a whole watcher thread could be crashed.
-}
-runHandler :: ThreadName -> ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> Handler -> FilePath -> Maybe FileStatus -> IO ()
-runHandler threadname st dstatus transferqueue changechan handler file filestatus = void $ do
- r <- tryIO go
+runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler handler file filestatus = void $ do
+ r <- tryIO <~> handler file filestatus
case r of
- Left e -> print e
+ Left e -> liftIO $ print e
Right Nothing -> noop
- Right (Just change) -> recordChange changechan change
- where
- go = runThreadState st $ handler threadname file filestatus dstatus transferqueue
+ Right (Just change) -> do
+ -- Just in case the commit thread is not
+ -- flushing the queue fast enough.
+ liftAnnex $ Annex.Queue.flushWhenFull
+ flip recordChange change <<~ changeChan
onAdd :: Handler
-onAdd _ file filestatus _ _
- | maybe False isRegularFile filestatus = pendingAddChange file
- | otherwise = noChange
+onAdd file filestatus
+ | maybe False isRegularFile filestatus = liftIO $ pendingAddChange file
+ | otherwise = liftIO $ noChange
{- A symlink might be an arbitrary symlink, which is just added.
- Or, if it is a git-annex symlink, ensure it points to the content
- before adding it.
-}
onAddSymlink :: Handler
-onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.lookupFile file
+onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
where
go (Just (key, _)) = do
- link <- calcGitLink file key
+ link <- liftAnnex $ calcGitLink file key
ifM ((==) link <$> liftIO (readSymbolicLink file))
( do
- s <- liftIO $ getDaemonStatus dstatus
+ s <- daemonStatus
checkcontent key s
ensurestaged link s
, do
- liftIO $ brokendebug threadname ["fix symlink", file]
liftIO $ removeFile file
liftIO $ createSymbolicLink link file
- checkcontent key =<< liftIO (getDaemonStatus dstatus)
+ checkcontent key =<< daemonStatus
addlink link
)
go Nothing = do -- other symlink
link <- liftIO (readSymbolicLink file)
- ensurestaged link =<< liftIO (getDaemonStatus dstatus)
+ ensurestaged link =<< daemonStatus
{- This is often called on symlinks that are already
- staged correctly. A symlink may have been deleted
@@ -156,41 +159,47 @@ onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.l
ensurestaged link daemonstatus
| scanComplete daemonstatus = addlink link
| otherwise = case filestatus of
- Just s
- | not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
+ Just s | changedrecently s -> liftIO noChange
_ -> addlink link
+ where
+ changedrecently s = not $
+ afterLastDaemonRun (statusChangeTime s) daemonstatus
{- For speed, tries to reuse the existing blob for symlink target. -}
addlink link = do
- liftIO $ brokendebug threadname ["add symlink", file]
- v <- catObjectDetails $ Ref $ ':':file
- case v of
- Just (currlink, sha)
- | s2w8 link == L.unpack currlink ->
+ debug ["add symlink", file]
+ liftAnnex $ do
+ v <- catObjectDetails $ Ref $ ':':file
+ case v of
+ Just (currlink, sha)
+ | s2w8 link == L.unpack currlink ->
+ stageSymlink file sha
+ _ -> do
+ sha <- inRepo $
+ Git.HashObject.hashObject BlobObject link
stageSymlink file sha
- _ -> do
- sha <- inRepo $
- Git.HashObject.hashObject BlobObject link
- stageSymlink file sha
- madeChange file LinkChange
+ liftIO $ madeChange file LinkChange
{- When a new link appears, or a link is changed, after the startup
- scan, handle getting or dropping the key's content. -}
checkcontent key daemonstatus
| scanComplete daemonstatus = do
- present <- inAnnex key
- unless present $
- queueTransfers Next transferqueue dstatus
- key (Just file) Download
- handleDrops dstatus present key (Just file)
+ present <- liftAnnex $ inAnnex key
+ dstatus <- getAssistant daemonStatusHandle
+ unless present $ do
+ transferqueue <- getAssistant transferQueue
+ liftAnnex $ queueTransfers Next transferqueue
+ dstatus key (Just file) Download
+ liftAnnex $ handleDrops dstatus present key (Just file)
| otherwise = noop
onDel :: Handler
-onDel threadname file _ _dstatus _ = do
- liftIO $ brokendebug threadname ["file deleted", file]
- Annex.Queue.addUpdateIndex =<<
- inRepo (Git.UpdateIndex.unstageFile file)
- madeChange file RmChange
+onDel file _ = do
+ debug ["file deleted", file]
+ liftAnnex $
+ Annex.Queue.addUpdateIndex =<<
+ inRepo (Git.UpdateIndex.unstageFile file)
+ liftIO $ madeChange file RmChange
{- A directory has been deleted, or moved, so tell git to remove anything
- that was inside it from its cache. Since it could reappear at any time,
@@ -200,18 +209,19 @@ onDel threadname file _ _dstatus _ = do
- command to get the recursive list of files in the directory, so rm is
- just as good. -}
onDelDir :: Handler
-onDelDir threadname dir _ _dstatus _ = do
- liftIO $ brokendebug threadname ["directory deleted", dir]
- Annex.Queue.addCommand "rm"
+onDelDir dir _ = do
+ debug ["directory deleted", dir]
+ liftAnnex $ Annex.Queue.addCommand "rm"
[Params "--quiet -r --cached --ignore-unmatch --"] [dir]
- madeChange dir RmDirChange
+ liftIO $ madeChange dir RmDirChange
{- Called when there's an error with inotify or kqueue. -}
onErr :: Handler
-onErr _ msg _ dstatus _ = do
- warning msg
+onErr msg _ = do
+ liftAnnex $ warning msg
+ dstatus <- getAssistant daemonStatusHandle
void $ liftIO $ addAlert dstatus $ warningAlert "watcher" msg
- return Nothing
+ liftIO noChange
{- Adds a symlink to the index, without ever accessing the actual symlink
- on disk. This avoids a race if git add is used, where the symlink is