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:
Joey Hess 2012-10-29 02:21:04 -04:00
parent 4e765327ca
commit 4dbdc2b666
29 changed files with 299 additions and 280 deletions

View file

@ -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