lifted Assistant.Sync into Assistant monad

lots of nice cleanups

Assistant/MakeRemote.hs

@@ -8,9 +8,6 @@
 module Assistant.MakeRemote where
 
 import Assistant.Common
-import Assistant.ThreadedMonad
-import Assistant.DaemonStatus
-import Assistant.ScanRemotes
 import Assistant.Ssh
 import Assistant.Sync
 import qualified Types.Remote as R
@@ -28,11 +25,11 @@ import qualified Data.Map as M
 import Data.Char
 
 {- Sets up and begins syncing with a new ssh or rsync remote. -}
-makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO Remote
-makeSshRemote st dstatus scanremotes forcersync sshdata = do
-	r <- runThreadState st $
+makeSshRemote :: Bool -> SshData -> Assistant Remote
+makeSshRemote forcersync sshdata = do
+	r <- liftAnnex $
 		addRemote $ maker (sshRepoName sshdata) sshurl
-	syncNewRemote st dstatus scanremotes r
+	syncNewRemote r
 	return r
 	where
 		rsync = forcersync || rsyncOnly sshdata

Assistant/Pairing/MakeRemote.hs

@@ -42,10 +42,7 @@ finishedPairing msg keypair = do
 			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
 			]
 			""
-	st <- getAssistant threadState
-	dstatus <- getAssistant daemonStatusHandle
-	scanremotes <- getAssistant scanRemoteMap
-	void $ liftIO $ makeSshRemote st dstatus scanremotes False sshdata
+	void $ makeSshRemote False sshdata
 
 {- Mostly a straightforward conversion.  Except:
  -  * Determine the best hostname to use to contact the host.

Assistant/Sync.hs

@@ -36,25 +36,29 @@ import Control.Concurrent
  - the remotes have diverged from the local git-annex branch. Otherwise,
  - it's sufficient to requeue failed transfers.
  -}
-reconnectRemotes :: ThreadName -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Maybe PushNotifier -> [Remote] -> IO ()
-reconnectRemotes _ _ _ _ _ [] = noop
-reconnectRemotes threadname st dstatus scanremotes pushnotifier rs = void $
-	alertWhile dstatus (syncAlert rs) $ do
+reconnectRemotes :: Bool -> [Remote] -> Assistant ()
+reconnectRemotes _ [] = noop
+reconnectRemotes notifypushes rs = void $ do
+	dstatus <- getAssistant daemonStatusHandle
+	alertWhile dstatus (syncAlert rs) <~> do
 		(ok, diverged) <- sync
-			=<< runThreadState st (inRepo Git.Branch.current)
-		addScanRemotes scanremotes diverged rs
+			=<< liftAnnex (inRepo Git.Branch.current)
+		scanremotes <- getAssistant scanRemoteMap
+		liftIO $ addScanRemotes scanremotes diverged rs
 		return ok
 	where
 		(gitremotes, _specialremotes) =
 			partition (Git.repoIsUrl . Remote.repo) rs
 		sync (Just branch) = do
-			diverged <- snd <$> manualPull st (Just branch) gitremotes
-			now <- getCurrentTime
-			ok <- pushToRemotes threadname now st pushnotifier Nothing gitremotes
+			st <- getAssistant threadState
+			diverged <- liftIO $ snd <$> manualPull st (Just branch) gitremotes
+			now <- liftIO getCurrentTime
+			ok <- pushToRemotes now notifypushes gitremotes
 			return (ok, diverged)
 		{- No local branch exists yet, but we can try pulling. -}
 		sync Nothing = do
-			diverged <- snd <$> manualPull st Nothing gitremotes
+			st <- getAssistant threadState
+			diverged <- liftIO $ snd <$> manualPull st Nothing gitremotes
 			return (True, diverged)
 
 {- Updates the local sync branch, then pushes it to all remotes, in
@@ -81,72 +85,68 @@ reconnectRemotes threadname st dstatus scanremotes pushnotifier rs = void $
  - them. While ugly, those branches are reserved for pushing by us, and
  - so our pushes will succeed.
  -}
-pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe PushNotifier -> Maybe FailedPushMap -> [Remote] -> IO Bool
-pushToRemotes threadname now st mpushnotifier mpushmap remotes = do
-	(g, branch, u) <- runThreadState st $ do
+pushToRemotes :: UTCTime -> Bool -> [Remote] -> Assistant Bool
+pushToRemotes now notifypushes remotes = do
+	(g, branch, u) <- liftAnnex $ do
 		Annex.Branch.commit "update"
 		(,,)
 			<$> gitRepo
 			<*> inRepo Git.Branch.current
 			<*> getUUID
 	go True branch g u remotes
-	where
-		go _ Nothing _ _ _ = return True -- no branch, so nothing to do
-		go shouldretry (Just branch) g u rs =  do
-			brokendebug threadname
-				[ "pushing to"
-				, show rs
+  where
+	go _ Nothing _ _ _ = return True -- no branch, so nothing to do
+	go shouldretry (Just branch) g u rs =  do
+		debug ["pushing to", show rs]
+		liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
+		(succeeded, failed) <- liftIO $ inParallel (push g branch) rs
+		updatemap succeeded []
+		if null failed
+			then do
+				when notifypushes $
+					notifyPush (map Remote.uuid succeeded) <<~ pushNotifier
+				return True
+			else if shouldretry
+				then retry branch g u failed
+				else fallback branch g u failed
+
+	updatemap succeeded failed = do
+		pushmap <- getAssistant failedPushMap
+		liftIO $ changeFailedPushMap pushmap $ \m ->
+			M.union (makemap failed) $
+				M.difference m (makemap succeeded)
+	makemap l = M.fromList $ zip l (repeat now)
+
+	retry branch g u rs = do
+		debug ["trying manual pull to resolve failed pushes"]
+		st <- getAssistant threadState
+		void $ liftIO $ manualPull st (Just branch) rs
+		go False (Just branch) g u rs
+
+	fallback branch g u rs = do
+		debug ["fallback pushing to", show rs]
+		(succeeded, failed) <- liftIO $
+			inParallel (pushfallback g u branch) rs
+		updatemap succeeded failed
+		when (notifypushes && (not $ null succeeded)) $
+			notifyPush (map Remote.uuid succeeded) <<~ pushNotifier
+		return $ null failed
+		
+	push g branch remote = Command.Sync.pushBranch remote branch g
+	pushfallback g u branch remote = Git.Command.runBool "push"
+		[ Param $ Remote.name remote
+		, Param $ refspec Annex.Branch.name
+		, Param $ refspec branch
+		] g
+		where
+			{- Push to refs/synced/uuid/branch; this
+			 - avoids cluttering up the branch display. -}
+			refspec b = concat
+				[ s
+				, ":"
+				, "refs/synced/" ++ fromUUID u ++ "/" ++ s
 				]
-			Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
-			(succeeded, failed) <- inParallel (push g branch) rs
-			updatemap succeeded []
-			let ok = null failed
-			if ok
-				then do
-					maybe noop (notifyPush $ map Remote.uuid succeeded) mpushnotifier
-					return ok
-				else if shouldretry
-					then retry branch g u failed
-					else fallback branch g u failed
-
-		updatemap succeeded failed = case mpushmap of
-			Nothing -> noop
-			Just pushmap -> changeFailedPushMap pushmap $ \m ->
-				M.union (makemap failed) $
-					M.difference m (makemap succeeded)
-		makemap l = M.fromList $ zip l (repeat now)
-
-		retry branch g u rs = do
-			brokendebug threadname [ "trying manual pull to resolve failed pushes" ]
-			void $ manualPull st (Just branch) rs
-			go False (Just branch) g u rs
-
-		fallback branch g u rs = do
-			brokendebug threadname
-				[ "fallback pushing to"
-				, show rs
-				]
-			(succeeded, failed) <- inParallel (pushfallback g u branch) rs
-			updatemap succeeded failed
-			unless (null succeeded) $
-				maybe noop (notifyPush $ map Remote.uuid succeeded) mpushnotifier
-			return $ null failed
-			
-		push g branch remote = Command.Sync.pushBranch remote branch g
-		pushfallback g u branch remote = Git.Command.runBool "push"
-			[ Param $ Remote.name remote
-			, Param $ refspec Annex.Branch.name
-			, Param $ refspec branch
-			] g
-			where
-				{- Push to refs/synced/uuid/branch; this
-				 - avoids cluttering up the branch display. -}
-				refspec b = concat
-					[ s
-					, ":"
-					, "refs/synced/" ++ fromUUID u ++ "/" ++ s
-					]
-					where s = show $ Git.Ref.base b
+				where s = show $ Git.Ref.base b
 
 {- Manually pull from remotes and merge their branches. -}
 manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO ([Bool], Bool)
@@ -160,7 +160,8 @@ manualPull st currentbranch remotes = do
 	return (results, haddiverged)
 
 {- Start syncing a newly added remote, using a background thread. -}
-syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
-syncNewRemote st dstatus scanremotes remote = do
-	runThreadState st $ updateSyncRemotes dstatus
-	void $ forkIO $ reconnectRemotes "SyncRemote" st dstatus scanremotes Nothing [remote]
+syncNewRemote :: Remote -> Assistant ()
+syncNewRemote remote = do
+	liftAnnex . updateSyncRemotes =<< getAssistant daemonStatusHandle
+	thread <- asIO2 reconnectRemotes
+	void $ liftIO $ forkIO $ thread False [remote]

Assistant/Threads/MountWatcher.hs

@@ -159,11 +159,7 @@ handleMount :: FilePath -> Assistant ()
 handleMount dir = do
 	debug ["detected mount of", dir]
 	rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir
-	d <- getAssistant id
-	liftIO $ 
-		reconnectRemotes (threadName d) (threadState d)
-			(daemonStatusHandle d) (scanRemoteMap d)
-			(Just $ pushNotifier d) rs
+	reconnectRemotes True rs
 
 {- Finds remotes located underneath the mount point.
  -

Assistant/Threads/NetWatcher.hs

@@ -123,11 +123,7 @@ listenWicdConnections client callback =
 #endif
 
 handleConnection :: Assistant ()
-handleConnection = do
-	d <- getAssistant id
-	liftIO . reconnectRemotes (threadName d) (threadState d)
-		(daemonStatusHandle d) (scanRemoteMap d) (Just $ pushNotifier d)
-		=<< networkRemotes
+handleConnection = reconnectRemotes True =<< networkRemotes
 
 {- Finds network remotes. -}
 networkRemotes :: Assistant [Remote]

Assistant/Threads/Pusher.hs

@@ -32,11 +32,9 @@ pushRetryThread = NamedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do
 	unless (null topush) $ do
 		debug ["retrying", show (length topush), "failed pushes"]
 		now <- liftIO $ getCurrentTime
-		st <- getAssistant threadState
-		pushnotifier <- getAssistant pushNotifier
 		dstatus <- getAssistant daemonStatusHandle
-		void $ liftIO $ alertWhile dstatus (pushRetryAlert topush) $
-			pushToRemotes thisThread now st (Just pushnotifier) (Just pushmap) topush
+		void $ alertWhile dstatus (pushRetryAlert topush) <~>
+			pushToRemotes now True topush
 	where
 		halfhour = 1800
 
@@ -52,12 +50,9 @@ pushThread = NamedThread "Pusher" $ runEvery (Seconds 2) <~> do
 			remotes <- filter pushable . syncRemotes <$> daemonStatus
 			unless (null remotes) $ do
 				now <- liftIO $ getCurrentTime
-				st <- getAssistant threadState
-				pushmap <- getAssistant failedPushMap
-				pushnotifier <- getAssistant pushNotifier		
 				dstatus <- getAssistant daemonStatusHandle
-				void $ liftIO $ alertWhile dstatus (pushAlert remotes) $
-					pushToRemotes thisThread now st (Just pushnotifier) (Just pushmap) remotes
+				void $ alertWhile dstatus (pushAlert remotes) <~>
+					pushToRemotes now True remotes
 		else do
 			debug ["delaying push of", show (length commits), "commits"]
 			flip refillCommits commits <<~ commitChan

Assistant/WebApp/Configurators/S3.hs

@@ -124,5 +124,5 @@ makeS3Remote (S3Creds ak sk) name setup config = do
 		makeSpecialRemote name S3.remote config
 		return remotename
 	setup r
-	liftIO $ syncNewRemote st (daemonStatusHandle d) (scanRemoteMap d) r
+	runAssistantY $ syncNewRemote r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

Assistant/WebApp/Configurators/Ssh.hs

@@ -283,12 +283,7 @@ makeSsh' rsync setup sshdata keypair =
 
 makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
 makeSshRepo forcersync setup sshdata = do
-	d <- getAssistantY id
-	r <- liftIO $ makeSshRemote
-		(threadState d)
-		(daemonStatusHandle d)
-		(scanRemoteMap d)
-		forcersync sshdata
+	r <- runAssistantY $ makeSshRemote forcersync sshdata
 	setup r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r
 

Assistant/WebApp/Utility.hs

@@ -61,13 +61,7 @@ changeSyncFlag r enabled = runAnnex undefined $ do
 
 {- Start syncing remote, using a background thread. -}
 syncRemote :: Remote -> Handler ()
-syncRemote remote = do
-	d <- getAssistantY id
-	liftIO $ syncNewRemote
-		(threadState d)
-		(daemonStatusHandle d)
-		(scanRemoteMap d)
-		remote
+syncRemote = runAssistantY . syncNewRemote
 
 pauseTransfer :: Transfer -> Handler ()
 pauseTransfer = cancelTransfer True