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.

Assistant/Threads/SanityChecker.hs

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