Assistant monad, stage 2.5
Converted several threads to run in the monad. Added a lot of useful combinators for working with the monad. Now the monad includes the name of the thread. Some debugging messages are disabled pending converting other threads.
This commit is contained in:
parent
4e765327ca
commit
4dbdc2b666
29 changed files with 299 additions and 280 deletions
|
@ -11,60 +11,56 @@ module Assistant.Threads.SanityChecker (
|
|||
|
||||
import Assistant.Common
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.Changes
|
||||
import Assistant.Alert
|
||||
import Assistant.TransferQueue
|
||||
import qualified Git.LsFiles
|
||||
import Utility.ThreadScheduler
|
||||
import qualified Assistant.Threads.Watcher as Watcher
|
||||
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
thisThread :: ThreadName
|
||||
thisThread = "SanityChecker"
|
||||
|
||||
{- This thread wakes up occasionally to make sure the tree is in good shape. -}
|
||||
sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> NamedThread
|
||||
sanityCheckerThread st dstatus transferqueue changechan = thread $ forever $ do
|
||||
waitForNextCheck dstatus
|
||||
sanityCheckerThread :: NamedThread
|
||||
sanityCheckerThread = NamedThread "SanityChecker" $ forever $ do
|
||||
waitForNextCheck
|
||||
|
||||
debug thisThread ["starting sanity check"]
|
||||
debug ["starting sanity check"]
|
||||
|
||||
void $ alertWhile dstatus sanityCheckAlert go
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
void $ alertWhile dstatus sanityCheckAlert <~> go
|
||||
|
||||
debug thisThread ["sanity check complete"]
|
||||
where
|
||||
thread = NamedThread thisThread
|
||||
go = do
|
||||
modifyDaemonStatus_ dstatus $ \s -> s
|
||||
{ sanityCheckRunning = True }
|
||||
debug ["sanity check complete"]
|
||||
where
|
||||
go = do
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
liftIO $ modifyDaemonStatus_ dstatus $ \s -> s
|
||||
{ sanityCheckRunning = True }
|
||||
|
||||
now <- getPOSIXTime -- before check started
|
||||
r <- catchIO (check st dstatus transferqueue changechan)
|
||||
$ \e -> do
|
||||
runThreadState st $ warning $ show e
|
||||
return False
|
||||
now <- liftIO $ getPOSIXTime -- before check started
|
||||
r <- either showerr return =<< tryIO <~> check
|
||||
|
||||
modifyDaemonStatus_ dstatus $ \s -> s
|
||||
{ sanityCheckRunning = False
|
||||
, lastSanityCheck = Just now
|
||||
}
|
||||
liftIO $ modifyDaemonStatus_ dstatus $ \s -> s
|
||||
{ sanityCheckRunning = False
|
||||
, lastSanityCheck = Just now
|
||||
}
|
||||
|
||||
return r
|
||||
return r
|
||||
|
||||
showerr e = do
|
||||
liftAnnex $ warning $ show e
|
||||
return False
|
||||
|
||||
{- Only run one check per day, from the time of the last check. -}
|
||||
waitForNextCheck :: DaemonStatusHandle -> IO ()
|
||||
waitForNextCheck dstatus = do
|
||||
v <- lastSanityCheck <$> getDaemonStatus dstatus
|
||||
now <- getPOSIXTime
|
||||
threadDelaySeconds $ Seconds $ calcdelay now v
|
||||
where
|
||||
calcdelay _ Nothing = oneDay
|
||||
calcdelay now (Just lastcheck)
|
||||
| lastcheck < now = max oneDay $
|
||||
oneDay - truncate (now - lastcheck)
|
||||
| otherwise = oneDay
|
||||
waitForNextCheck :: Assistant ()
|
||||
waitForNextCheck = do
|
||||
v <- lastSanityCheck <$> daemonStatus
|
||||
now <- liftIO getPOSIXTime
|
||||
liftIO $ threadDelaySeconds $ Seconds $ calcdelay now v
|
||||
where
|
||||
calcdelay _ Nothing = oneDay
|
||||
calcdelay now (Just lastcheck)
|
||||
| lastcheck < now = max oneDay $
|
||||
oneDay - truncate (now - lastcheck)
|
||||
| otherwise = oneDay
|
||||
|
||||
oneDay :: Int
|
||||
oneDay = 24 * 60 * 60
|
||||
|
@ -72,29 +68,31 @@ oneDay = 24 * 60 * 60
|
|||
{- 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
|
||||
- will block the watcher. -}
|
||||
check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO Bool
|
||||
check st dstatus transferqueue changechan = do
|
||||
g <- runThreadState st gitRepo
|
||||
check :: Assistant Bool
|
||||
check = do
|
||||
g <- liftAnnex gitRepo
|
||||
-- Find old unstaged symlinks, and add them to git.
|
||||
(unstaged, cleanup) <- Git.LsFiles.notInRepo False ["."] g
|
||||
now <- getPOSIXTime
|
||||
(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g
|
||||
now <- liftIO $ getPOSIXTime
|
||||
forM_ unstaged $ \file -> do
|
||||
ms <- catchMaybeIO $ getSymbolicLinkStatus file
|
||||
ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
|
||||
case ms of
|
||||
Just s | toonew (statusChangeTime s) now -> noop
|
||||
| isSymbolicLink s ->
|
||||
addsymlink file ms
|
||||
| isSymbolicLink s -> addsymlink file ms
|
||||
_ -> noop
|
||||
void cleanup
|
||||
liftIO $ void cleanup
|
||||
return True
|
||||
where
|
||||
toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
|
||||
slop = fromIntegral tenMinutes
|
||||
insanity msg = do
|
||||
runThreadState st $ warning msg
|
||||
void $ addAlert dstatus $ sanityCheckFixAlert msg
|
||||
addsymlink file s = do
|
||||
Watcher.runHandler thisThread st dstatus
|
||||
transferqueue changechan
|
||||
Watcher.onAddSymlink file s
|
||||
insanity $ "found unstaged symlink: " ++ file
|
||||
where
|
||||
toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
|
||||
slop = fromIntegral tenMinutes
|
||||
insanity msg = do
|
||||
liftAnnex $ warning msg
|
||||
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
|
||||
insanity $ "found unstaged symlink: " ++ file
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue