Assistant monad, stage 1

This adds the Assistant monad, and an AssistantData structure.
So far, none of the assistant's threads run in the monad yet.

7 files changed, 211 insertions, 150 deletions

diff --git a/Assistant.hs b/Assistant.hs
index ade4621e5..bdca20fef 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -120,13 +120,6 @@ module Assistant where
 import Assistant.Common
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
-import Assistant.Changes
-import Assistant.Commits
-import Assistant.Pushes
-import Assistant.ScanRemotes
-import Assistant.BranchChange
-import Assistant.TransferQueue
-import Assistant.TransferSlots
 import Assistant.Threads.DaemonStatus
 import Assistant.Threads.Watcher
 import Assistant.Threads.Committer
@@ -180,24 +173,28 @@ startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (String -> FilePath -> IO ()
 startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 	checkCanWatch
 	dstatus <- startDaemonStatus
-	liftIO $ daemonize $ run dstatus st
+	liftIO $ daemonize $
+		runAssistant go =<< newAssistantData st dstatus
   where
-	run dstatus st = do
-		changechan <- newChangeChan
-		commitchan <- newCommitChan
-		pushmap <- newFailedPushMap
-		transferqueue <- newTransferQueue
-		transferslots <- newTransferSlots
-		scanremotes <- newScanRemoteMap
-		branchhandle <- newBranchChangeHandle
-		pushnotifier <- newPushNotifier
+	go = do
+		d <- getAssistant id
+		st <- getAssistant threadState
+		dstatus <- getAssistant daemonStatus
+		changechan <- getAssistant changeChan
+		commitchan <- getAssistant commitChan
+		pushmap <- getAssistant failedPushMap
+		transferqueue <- getAssistant transferQueue
+		transferslots <- getAssistant transferSlots
+		scanremotes <- getAssistant scanRemoteMap
+		branchhandle <- getAssistant branchChangeHandle
+		pushnotifier <- getAssistant pushNotifier
 #ifdef WITH_WEBAPP
-		urlrenderer <- newUrlRenderer
+		urlrenderer <- liftIO $ newUrlRenderer
 #endif
-		mapM_ (startthread dstatus)
+		mapM_ (startthread d)
 			[ watch $ commitThread st changechan commitchan transferqueue dstatus
 #ifdef WITH_WEBAPP
-			, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer Nothing webappwaiter
+			, assist $ webAppThread d urlrenderer False Nothing webappwaiter
 #ifdef WITH_PAIRING
 			, assist $ pairListenerThread st dstatus scanremotes urlrenderer
 #endif
@@ -220,11 +217,12 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
 #endif
 			, watch $ watchThread st dstatus transferqueue changechan
 			]
-		waitForTermination
+		liftIO waitForTermination
 
 	watch a = (True, a)
 	assist a = (False, a)
-	startthread dstatus (watcher, t)
-		| watcher || assistant = void $ forkIO $
-			runNamedThread dstatus t
+	startthread d (watcher, t)
+		| watcher || assistant = void $ liftIO $ forkIO $
+			flip runAssistant d $
+				runNamedThread t
 		| otherwise = noop
diff --git a/Assistant/BranchChange.hs b/Assistant/BranchChange.hs
index d1d1c20df..cf7080f90 100644
--- a/Assistant/BranchChange.hs
+++ b/Assistant/BranchChange.hs
@@ -8,7 +8,7 @@
 module Assistant.BranchChange where
 
 import Control.Concurrent.MSampleVar
-import Assistant.Common
+import Common.Annex
 
 newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ())
 
diff --git a/Assistant/Common.hs b/Assistant/Common.hs
index d6df77f69..a6c6b8935 100644
--- a/Assistant/Common.hs
+++ b/Assistant/Common.hs
@@ -14,8 +14,9 @@ module Assistant.Common (
 ) where
 
 import Common.Annex as X
-import Assistant.DaemonStatus
+import Assistant.Monad as X
 import Assistant.Alert
+import Assistant.DaemonStatus
 
 import System.Log.Logger
 import qualified Control.Exception as E
@@ -26,10 +27,10 @@ data NamedThread = NamedThread ThreadName (IO ())
 debug :: ThreadName -> [String] -> IO ()
 debug threadname ws = debugM threadname $ unwords $ (threadname ++ ":") : ws
 
-runNamedThread :: DaemonStatusHandle -> NamedThread -> IO ()
-runNamedThread dstatus (NamedThread name a) = go
+runNamedThread :: NamedThread -> Assistant ()
+runNamedThread (NamedThread name a) = liftIO . go =<< getAssistant daemonStatus
 	where
-		go = do
+		go dstatus = do
 			r <- E.try a :: IO (Either E.SomeException ())
 			case r of
 				Right _ -> noop
diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs
new file mode 100644
index 000000000..fa982b45e
--- /dev/null
+++ b/Assistant/Monad.hs
@@ -0,0 +1,83 @@
+{- git-annex assistant monad
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE PackageImports, GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}
+
+module Assistant.Monad (
+	Assistant,
+	AssistantData(..),
+	newAssistantData,
+	runAssistant,
+	getAssistant,
+	liftAnnex
+) where
+
+import "mtl" Control.Monad.Reader
+import Control.Monad.Base (liftBase, MonadBase)
+
+import Common.Annex
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Assistant.TransferQueue
+import Assistant.TransferSlots
+import Assistant.Pushes
+import Assistant.Commits
+import Assistant.Changes
+import Assistant.BranchChange
+
+newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
+	deriving (
+		Monad,
+		MonadIO,
+		MonadReader AssistantData,
+		Functor,
+		Applicative
+	)
+
+instance MonadBase IO Assistant where
+	liftBase = Assistant . liftBase
+
+data AssistantData = AssistantData
+	{ threadState :: ThreadState
+	, daemonStatus :: DaemonStatusHandle
+	, scanRemoteMap :: ScanRemoteMap
+	, transferQueue :: TransferQueue
+	, transferSlots :: TransferSlots
+	, pushNotifier :: PushNotifier
+	, failedPushMap :: FailedPushMap
+	, commitChan :: CommitChan
+	, changeChan :: ChangeChan
+	, branchChangeHandle :: BranchChangeHandle
+	}
+
+newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
+newAssistantData st dstatus = AssistantData
+	<$> pure st
+	<*> pure dstatus
+	<*> newScanRemoteMap
+	<*> newTransferQueue
+	<*> newTransferSlots
+	<*> newPushNotifier
+	<*> newFailedPushMap
+	<*> newCommitChan
+	<*> newChangeChan
+	<*> newBranchChangeHandle
+
+runAssistant :: Assistant a -> AssistantData -> IO a
+runAssistant a = runReaderT (mkAssistant a)
+
+getAssistant :: (AssistantData -> a) -> Assistant a
+getAssistant = reader
+
+{- Runs an action in the git-annex monad. Note that the same monad state
+ - is shared amoung all assistant threads, so only one of these can run at
+ - a time. Therefore, long-duration actions should be avoided. -}
+liftAnnex :: Annex a -> Assistant a
+liftAnnex a = do
+	st <- reader threadState
+	liftIO $ runThreadState st a
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 310a6e984..5d24fe23f 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -59,16 +59,16 @@ watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan
 watchThread st dstatus transferqueue changechan = NamedThread thisThread $ do
 	void $ watchDir "." ignored hooks startup
 	debug 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
-			}
+  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
+		}
 
 {- Initial scartup scan. The action should return once the scan is complete. -}
 startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
@@ -89,7 +89,7 @@ startupScan st dstatus scanner = do
 
 ignored :: FilePath -> Bool
 ignored = ig . takeFileName
-	where
+  where
 	ig ".git" = True
 	ig ".gitignore" = True
 	ig ".gitattributes" = True
@@ -109,14 +109,13 @@ runHandler threadname st dstatus transferqueue changechan handler file filestatu
 		Left e -> print e
 		Right Nothing -> noop
 		Right (Just change) -> recordChange changechan change
-	where
-		go = runThreadState st $ handler threadname file filestatus dstatus transferqueue
+  where
+	go = runThreadState st $ handler threadname file filestatus dstatus transferqueue
 
 onAdd :: Handler
 onAdd _ file filestatus _ _
 	| maybe False isRegularFile filestatus = pendingAddChange file
 	| otherwise = noChange
-	where
 
 {- 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
@@ -124,69 +123,67 @@ onAdd _ file filestatus _ _
  -}
 onAddSymlink :: Handler
 onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.lookupFile file
-	where
-		go (Just (key, _)) = do
-			link <- calcGitLink file key
-			ifM ((==) link <$> liftIO (readSymbolicLink file))
-				( do
-					s <- liftIO $ getDaemonStatus dstatus
-					checkcontent key s
-					ensurestaged link s
-				, do
-					liftIO $ debug threadname ["fix symlink", file]
-					liftIO $ removeFile file
-					liftIO $ createSymbolicLink link file
-					checkcontent key =<< liftIO (getDaemonStatus dstatus)
-					addlink link
-				)
-		go Nothing = do -- other symlink
-			link <- liftIO (readSymbolicLink file)
-			ensurestaged link =<< liftIO (getDaemonStatus dstatus)
-
-		{- This is often called on symlinks that are already
-		 - staged correctly. A symlink may have been deleted
-		 - and being re-added, or added when the watcher was
-		 - not running. So they're normally restaged to make sure.
-		 -
-		 - As an optimisation, during the startup scan, avoid
-		 - restaging everything. Only links that were created since
-		 - the last time the daemon was running are staged.
-		 - (If the daemon has never ran before, avoid staging
-		 - links too.)
-		 -}
-		ensurestaged link daemonstatus
-			| scanComplete daemonstatus = addlink link
-			| otherwise = case filestatus of
-				Just s
-					| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
-				_ -> addlink link
-
-		{- For speed, tries to reuse the existing blob for
-		 - the symlink target. -}
-		addlink link = do
-			liftIO $ debug threadname ["add symlink", file]
-			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
+  where
+	go (Just (key, _)) = do
+		link <- calcGitLink file key
+		ifM ((==) link <$> liftIO (readSymbolicLink file))
+			( do
+				s <- liftIO $ getDaemonStatus dstatus
+				checkcontent key s
+				ensurestaged link s
+			, do
+				liftIO $ debug threadname ["fix symlink", file]
+				liftIO $ removeFile file
+				liftIO $ createSymbolicLink link file
+				checkcontent key =<< liftIO (getDaemonStatus dstatus)
+				addlink link
+			)
+	go Nothing = do -- other symlink
+		link <- liftIO (readSymbolicLink file)
+		ensurestaged link =<< liftIO (getDaemonStatus dstatus)
+
+	{- This is often called on symlinks that are already
+	 - staged correctly. A symlink may have been deleted
+	 - and being re-added, or added when the watcher was
+	 - not running. So they're normally restaged to make sure.
+	 -
+	 - As an optimisation, during the startup scan, avoid
+	 - restaging everything. Only links that were created since
+	 - the last time the daemon was running are staged.
+	 - (If the daemon has never ran before, avoid staging
+	 - links too.)
+	 -}
+	ensurestaged link daemonstatus
+		| scanComplete daemonstatus = addlink link
+		| otherwise = case filestatus of
+			Just s
+				| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
+			_ -> addlink link
+
+	{- For speed, tries to reuse the existing blob for symlink target. -}
+	addlink link = do
+		liftIO $ debug threadname ["add symlink", file]
+		v <- catObjectDetails $ Ref $ ':':file
+		case v of
+			Just (currlink, sha)
+				| s2w8 link == L.unpack currlink ->
 					stageSymlink file sha
-			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)
-			| otherwise = noop
+			_ -> do
+				sha <- inRepo $
+					Git.HashObject.hashObject BlobObject link
+				stageSymlink file sha
+		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)
+		| otherwise = noop
 
 onDel :: Handler
 onDel threadname file _ _dstatus _ = do
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 6ed827e01..bb8fcd186 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -28,12 +28,6 @@ import Assistant.WebApp.Configurators.XMPP
 import Assistant.WebApp.Documentation
 import Assistant.WebApp.OtherRepos
 import Assistant.ThreadedMonad
-import Assistant.DaemonStatus
-import Assistant.ScanRemotes
-import Assistant.TransferQueue
-import Assistant.TransferSlots
-import Assistant.Pushes
-import Assistant.Commits
 import Utility.WebApp
 import Utility.FileMode
 import Utility.TempFile
@@ -51,51 +45,43 @@ mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
 
 type Url = String
 
-webAppThread 
-	:: Maybe ThreadState
-	-> DaemonStatusHandle
-	-> ScanRemoteMap
-	-> TransferQueue
-	-> TransferSlots
-	-> PushNotifier
-	-> CommitChan
+webAppThread
+	:: AssistantData
 	-> UrlRenderer
+	-> Bool
 	-> Maybe (IO String)
 	-> Maybe (Url -> FilePath -> IO ())
 	-> NamedThread
-webAppThread mst dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer postfirstrun onstartup = thread $ do
+webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ do
 	webapp <- WebApp
-		<$> pure mst
-		<*> pure dstatus
-		<*> pure scanremotes
-		<*> pure transferqueue
-		<*> pure transferslots
-		<*> pure pushnotifier
-		<*> pure commitchan
+		<$> pure assistantdata
 		<*> (pack <$> genRandomToken)
-		<*> getreldir mst
+		<*> getreldir
 		<*> pure $(embed "static")
 		<*> newWebAppState
 		<*> pure postfirstrun
+		<*> pure noannex
 	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
 	app <- toWaiAppPlain webapp
 	app' <- ifM debugEnabled
 		( return $ httpDebugLogger app
 		, return app
 		)
-	runWebApp app' $ \port -> case mst of
-		Nothing -> withTempFile "webapp.html" $ \tmpfile _ ->
+	runWebApp app' $ \port -> if noannex
+		then withTempFile "webapp.html" $ \tmpfile _ ->
 			go port webapp tmpfile Nothing
-		Just st -> do
+		else do
+			let st = threadState assistantdata
 			htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim
 			urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile
 			go port webapp htmlshim (Just urlfile)
 	where
 		thread = NamedThread thisThread
-		getreldir Nothing = return Nothing
-		getreldir (Just st) = Just <$>
-			(relHome =<< absPath
-				=<< runThreadState st (fromRepo repoPath))
+		getreldir
+			| noannex = return Nothing
+			| otherwise = Just <$>
+				(relHome =<< absPath
+					=<< runThreadState (threadState assistantdata) (fromRepo repoPath))
 		go port webapp htmlshim urlfile = do
 			debug thisThread ["running on port", show port]
 			let url = myUrl webapp port
diff --git a/Command/WebApp.hs b/Command/WebApp.hs
index 5a372f94d..aff760ee4 100644
--- a/Command/WebApp.hs
+++ b/Command/WebApp.hs
@@ -12,11 +12,6 @@ import Command
 import Assistant
 import Assistant.Common
 import Assistant.DaemonStatus
-import Assistant.ScanRemotes
-import Assistant.TransferQueue
-import Assistant.TransferSlots
-import Assistant.Pushes
-import Assistant.Commits
 import Assistant.Threads.WebApp
 import Assistant.WebApp
 import Assistant.Install
@@ -101,20 +96,21 @@ autoStart autostartfile = do
  -}
 firstRun :: IO ()
 firstRun = do
+	{- Without a repository, we cannot have an Annex monad, so cannot
+	 - get a ThreadState. Using undefined is only safe because the
+	 - webapp checks its noAnnex field before accessing the
+	 - threadstate. -}
+	let st = undefined
+	{- Get a DaemonStatus without running in the Annex monad. -}
 	dstatus <- atomically . newTMVar =<< newDaemonStatus
-	scanremotes <- newScanRemoteMap
-	transferqueue <- newTransferQueue
-	transferslots <- newTransferSlots
+	d <- newAssistantData st dstatus
 	urlrenderer <- newUrlRenderer
-	pushnotifier <- newPushNotifier
-	commitchan <- newCommitChan
 	v <- newEmptyMVar
 	let callback a = Just $ a v
-	void $ runNamedThread dstatus $
-		webAppThread Nothing dstatus scanremotes
-			transferqueue transferslots pushnotifier commitchan
-			urlrenderer
-			(callback signaler) (callback mainthread)
+	void $ flip runAssistant d $ runNamedThread $
+		webAppThread d urlrenderer True 
+			(callback signaler)
+			(callback mainthread)
 	where
 		signaler v = do
 			putMVar v ""