enqueue Downloads when new symlinks appear to content we don't have
This commit is contained in:
parent
c8135ea0a8
commit
6af319d8cd
3 changed files with 35 additions and 21 deletions
|
@ -113,8 +113,8 @@ startDaemon assistant foreground
|
||||||
, mergeThread st
|
, mergeThread st
|
||||||
, transferWatcherThread st dstatus
|
, transferWatcherThread st dstatus
|
||||||
, daemonStatusThread st dstatus
|
, daemonStatusThread st dstatus
|
||||||
, sanityCheckerThread st dstatus changechan
|
, sanityCheckerThread st dstatus transferqueue changechan
|
||||||
, watchThread st dstatus changechan
|
, watchThread st dstatus transferqueue changechan
|
||||||
]
|
]
|
||||||
waitForTermination
|
waitForTermination
|
||||||
|
|
||||||
|
|
|
@ -14,14 +14,15 @@ import qualified Git.LsFiles
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import Assistant.ThreadedMonad
|
import Assistant.ThreadedMonad
|
||||||
import Assistant.Changes
|
import Assistant.Changes
|
||||||
|
import Assistant.TransferQueue
|
||||||
import Utility.ThreadScheduler
|
import Utility.ThreadScheduler
|
||||||
import qualified Assistant.Threads.Watcher as Watcher
|
import qualified Assistant.Threads.Watcher as Watcher
|
||||||
|
|
||||||
import Data.Time.Clock.POSIX
|
import Data.Time.Clock.POSIX
|
||||||
|
|
||||||
{- This thread wakes up occasionally to make sure the tree is in good shape. -}
|
{- This thread wakes up occasionally to make sure the tree is in good shape. -}
|
||||||
sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> ChangeChan -> IO ()
|
sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO ()
|
||||||
sanityCheckerThread st status changechan = forever $ do
|
sanityCheckerThread st status transferqueue changechan = forever $ do
|
||||||
waitForNextCheck st status
|
waitForNextCheck st status
|
||||||
|
|
||||||
runThreadState st $
|
runThreadState st $
|
||||||
|
@ -29,7 +30,7 @@ sanityCheckerThread st status changechan = forever $ do
|
||||||
{ sanityCheckRunning = True }
|
{ sanityCheckRunning = True }
|
||||||
|
|
||||||
now <- getPOSIXTime -- before check started
|
now <- getPOSIXTime -- before check started
|
||||||
catchIO (check st status changechan)
|
catchIO (check st status transferqueue changechan)
|
||||||
(runThreadState st . warning . show)
|
(runThreadState st . warning . show)
|
||||||
|
|
||||||
runThreadState st $ do
|
runThreadState st $ do
|
||||||
|
@ -58,8 +59,8 @@ oneDay = 24 * 60 * 60
|
||||||
{- It's important to stay out of the Annex monad as much as possible while
|
{- It's important to stay out of the Annex monad as much as possible while
|
||||||
- running potentially expensive parts of this check, since remaining in it
|
- running potentially expensive parts of this check, since remaining in it
|
||||||
- will block the watcher. -}
|
- will block the watcher. -}
|
||||||
check :: ThreadState -> DaemonStatusHandle -> ChangeChan -> IO ()
|
check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO ()
|
||||||
check st status changechan = do
|
check st status transferqueue changechan = do
|
||||||
g <- runThreadState st $ do
|
g <- runThreadState st $ do
|
||||||
showSideAction "Running daily check"
|
showSideAction "Running daily check"
|
||||||
fromRepo id
|
fromRepo id
|
||||||
|
@ -79,5 +80,5 @@ check st status changechan = do
|
||||||
insanity m = runThreadState st $ warning m
|
insanity m = runThreadState st $ warning m
|
||||||
addsymlink file s = do
|
addsymlink file s = do
|
||||||
insanity $ "found unstaged symlink: " ++ file
|
insanity $ "found unstaged symlink: " ++ file
|
||||||
Watcher.runHandler st status changechan
|
Watcher.runHandler st status transferqueue changechan
|
||||||
Watcher.onAddSymlink file s
|
Watcher.onAddSymlink file s
|
||||||
|
|
|
@ -13,6 +13,8 @@ import Common.Annex
|
||||||
import Assistant.ThreadedMonad
|
import Assistant.ThreadedMonad
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import Assistant.Changes
|
import Assistant.Changes
|
||||||
|
import Assistant.TransferQueue
|
||||||
|
import Logs.Transfer
|
||||||
import Utility.DirWatcher
|
import Utility.DirWatcher
|
||||||
import Utility.Types.DirWatcher
|
import Utility.Types.DirWatcher
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
@ -45,11 +47,11 @@ needLsof = error $ unlines
|
||||||
, "Be warned: This can corrupt data in the annex, and make fsck complain."
|
, "Be warned: This can corrupt data in the annex, and make fsck complain."
|
||||||
]
|
]
|
||||||
|
|
||||||
watchThread :: ThreadState -> DaemonStatusHandle -> ChangeChan -> IO ()
|
watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO ()
|
||||||
watchThread st dstatus changechan = void $ watchDir "." ignored hooks startup
|
watchThread st dstatus transferqueue changechan = void $ watchDir "." ignored hooks startup
|
||||||
where
|
where
|
||||||
startup = statupScan st dstatus
|
startup = statupScan st dstatus
|
||||||
hook a = Just $ runHandler st dstatus changechan a
|
hook a = Just $ runHandler st dstatus transferqueue changechan a
|
||||||
hooks = WatchHooks
|
hooks = WatchHooks
|
||||||
{ addHook = hook onAdd
|
{ addHook = hook onAdd
|
||||||
, delHook = hook onDel
|
, delHook = hook onDel
|
||||||
|
@ -82,22 +84,22 @@ ignored = ig . takeFileName
|
||||||
ig ".gitattributes" = True
|
ig ".gitattributes" = True
|
||||||
ig _ = False
|
ig _ = False
|
||||||
|
|
||||||
type Handler = FilePath -> Maybe FileStatus -> DaemonStatusHandle -> Annex (Maybe Change)
|
type Handler = FilePath -> Maybe FileStatus -> DaemonStatusHandle -> TransferQueue -> Annex (Maybe Change)
|
||||||
|
|
||||||
{- Runs an action handler, inside the Annex monad, and if there was a
|
{- Runs an action handler, inside the Annex monad, and if there was a
|
||||||
- change, adds it to the ChangeChan.
|
- change, adds it to the ChangeChan.
|
||||||
-
|
-
|
||||||
- Exceptions are ignored, otherwise a whole watcher thread could be crashed.
|
- Exceptions are ignored, otherwise a whole watcher thread could be crashed.
|
||||||
-}
|
-}
|
||||||
runHandler :: ThreadState -> DaemonStatusHandle -> ChangeChan -> Handler -> FilePath -> Maybe FileStatus -> IO ()
|
runHandler :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> Handler -> FilePath -> Maybe FileStatus -> IO ()
|
||||||
runHandler st dstatus changechan handler file filestatus = void $ do
|
runHandler st dstatus transferqueue changechan handler file filestatus = void $ do
|
||||||
r <- tryIO go
|
r <- tryIO go
|
||||||
case r of
|
case r of
|
||||||
Left e -> print e
|
Left e -> print e
|
||||||
Right Nothing -> noop
|
Right Nothing -> noop
|
||||||
Right (Just change) -> recordChange changechan change
|
Right (Just change) -> recordChange changechan change
|
||||||
where
|
where
|
||||||
go = runThreadState st $ handler file filestatus dstatus
|
go = runThreadState st $ handler file filestatus dstatus transferqueue
|
||||||
|
|
||||||
{- During initial directory scan, this will be run for any regular files
|
{- During initial directory scan, this will be run for any regular files
|
||||||
- that are already checked into git. We don't want to turn those into
|
- that are already checked into git. We don't want to turn those into
|
||||||
|
@ -118,7 +120,7 @@ runHandler st dstatus changechan handler file filestatus = void $ do
|
||||||
- the add.
|
- the add.
|
||||||
-}
|
-}
|
||||||
onAdd :: Handler
|
onAdd :: Handler
|
||||||
onAdd file filestatus dstatus
|
onAdd file filestatus dstatus _
|
||||||
| maybe False isRegularFile filestatus = do
|
| maybe False isRegularFile filestatus = do
|
||||||
ifM (scanComplete <$> getDaemonStatus dstatus)
|
ifM (scanComplete <$> getDaemonStatus dstatus)
|
||||||
( go
|
( go
|
||||||
|
@ -136,12 +138,15 @@ onAdd file filestatus dstatus
|
||||||
- before adding it.
|
- before adding it.
|
||||||
-}
|
-}
|
||||||
onAddSymlink :: Handler
|
onAddSymlink :: Handler
|
||||||
onAddSymlink file filestatus dstatus = go =<< Backend.lookupFile file
|
onAddSymlink file filestatus dstatus transferqueue = go =<< Backend.lookupFile file
|
||||||
where
|
where
|
||||||
go (Just (key, _)) = do
|
go (Just (key, _)) = do
|
||||||
link <- calcGitLink file key
|
link <- calcGitLink file key
|
||||||
ifM ((==) link <$> liftIO (readSymbolicLink file))
|
ifM ((==) link <$> liftIO (readSymbolicLink file))
|
||||||
( ensurestaged link =<< getDaemonStatus dstatus
|
( do
|
||||||
|
s <- getDaemonStatus dstatus
|
||||||
|
checkcontent key s
|
||||||
|
ensurestaged link s
|
||||||
, do
|
, do
|
||||||
liftIO $ removeFile file
|
liftIO $ removeFile file
|
||||||
liftIO $ createSymbolicLink link file
|
liftIO $ createSymbolicLink link file
|
||||||
|
@ -183,8 +188,16 @@ onAddSymlink file filestatus dstatus = go =<< Backend.lookupFile file
|
||||||
stageSymlink file sha
|
stageSymlink file sha
|
||||||
madeChange file LinkChange
|
madeChange file LinkChange
|
||||||
|
|
||||||
|
{- When a new link appears, after the startup scan,
|
||||||
|
- try to get the key's content. -}
|
||||||
|
checkcontent key daemonstatus
|
||||||
|
| scanComplete daemonstatus = unlessM (inAnnex key) $
|
||||||
|
queueTransfers transferqueue dstatus
|
||||||
|
key (Just file) Download
|
||||||
|
| otherwise = noop
|
||||||
|
|
||||||
onDel :: Handler
|
onDel :: Handler
|
||||||
onDel file _ _dstatus = do
|
onDel file _ _dstatus _ = do
|
||||||
Annex.Queue.addUpdateIndex =<<
|
Annex.Queue.addUpdateIndex =<<
|
||||||
inRepo (Git.UpdateIndex.unstageFile file)
|
inRepo (Git.UpdateIndex.unstageFile file)
|
||||||
madeChange file RmChange
|
madeChange file RmChange
|
||||||
|
@ -197,14 +210,14 @@ onDel file _ _dstatus = do
|
||||||
- command to get the recursive list of files in the directory, so rm is
|
- command to get the recursive list of files in the directory, so rm is
|
||||||
- just as good. -}
|
- just as good. -}
|
||||||
onDelDir :: Handler
|
onDelDir :: Handler
|
||||||
onDelDir dir _ _dstatus = do
|
onDelDir dir _ _dstatus _ = do
|
||||||
Annex.Queue.addCommand "rm"
|
Annex.Queue.addCommand "rm"
|
||||||
[Params "--quiet -r --cached --ignore-unmatch --"] [dir]
|
[Params "--quiet -r --cached --ignore-unmatch --"] [dir]
|
||||||
madeChange dir RmDirChange
|
madeChange dir RmDirChange
|
||||||
|
|
||||||
{- Called when there's an error with inotify. -}
|
{- Called when there's an error with inotify. -}
|
||||||
onErr :: Handler
|
onErr :: Handler
|
||||||
onErr msg _ _dstatus = do
|
onErr msg _ _dstatus _ = do
|
||||||
warning msg
|
warning msg
|
||||||
return Nothing
|
return Nothing
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue