moved code out of webapp

No code changes, aside from some changes to lifting in code that turned out
to be able to run in Assistant rather than Handler.

Assistant/Repair.hs

@@ -0,0 +1,59 @@
+{- git-annex assistant repository repair
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+
+module Assistant.Repair where
+
+import Assistant.Common
+import Command.Repair (repairAnnexBranch)
+import Git.Repair (runRepairOf)
+import Logs.FsckResults
+import Annex.UUID
+import Utility.Batch
+import Config.Files
+import Assistant.Sync
+
+import Control.Concurrent.Async
+
+runRepair :: UUID -> Assistant ()
+runRepair u = do
+	-- Stop the watcher from running while running repairs.
+	changeSyncable Nothing False
+
+	fsckresults <- liftAnnex $ readFsckResults u
+	myu <- liftAnnex getUUID
+	if u == myu
+		then localrepair fsckresults
+		else remoterepair fsckresults
+	liftAnnex $ writeFsckResults u Nothing
+
+	-- Start the watcher running again. This also triggers it to do a
+	-- startup scan, which is especially important if the git repo
+	-- repair removed files from the index file. Those files will be
+	-- seen as new, and re-added to the repository.
+	changeSyncable Nothing True
+  where
+  	localrepair fsckresults = do
+		-- This intentionally runs the repair inside the Annex
+		-- monad, which is not strictly necessary, but keeps
+		-- other threads that might be trying to use the Annex
+		-- from running until it completes.
+		needfsck <- liftAnnex $ do
+			(ok, stillmissing, modifiedbranches) <- inRepo $
+				runRepairOf fsckresults True
+			repairAnnexBranch stillmissing modifiedbranches
+			return (not ok)
+		when needfsck $
+			backgroundfsck [ Param "--fast" ]
+
+	remoterepair _fsckresults = do
+		error "TODO: remote repair"
+	
+	backgroundfsck params = liftIO $ void $ async $ do
+		program <- readProgramFile
+		batchCommand program (Param "fsck" : params)

Assistant/Sync.hs

@@ -23,9 +23,17 @@ import qualified Git.Command
 import qualified Git.Ref
 import qualified Remote
 import qualified Types.Remote as Remote
+import qualified Remote.List as Remote
 import qualified Annex.Branch
 import Annex.UUID
 import Annex.TaggedPush
+import qualified Config
+import Git.Config
+import Assistant.NamedThread
+import Assistant.Threads.Watcher (watchThread, WatcherControl(..))
+import Assistant.TransferSlots
+import Assistant.TransferQueue
+import Logs.Transfer
 
 import Data.Time.Clock
 import qualified Data.Map as M
@@ -233,3 +241,36 @@ syncRemote remote = do
 		reconnectRemotes False [remote]
 		addScanRemotes True [remote]
 	void $ liftIO $ forkIO $ thread
+
+{- Use Nothing to change autocommit setting; or a remote to change
+ - its sync setting. -}
+changeSyncable :: Maybe Remote -> Bool -> Assistant ()
+changeSyncable Nothing enable = do
+	liftAnnex $ Config.setConfig key (boolConfig enable)
+	liftIO . maybe noop (`throwTo` signal)
+		=<< namedThreadId watchThread
+  where
+	key = Config.annexConfig "autocommit"
+	signal
+		| enable = ResumeWatcher
+		| otherwise = PauseWatcher
+changeSyncable (Just r) True = do
+	liftAnnex $ changeSyncFlag r True
+	syncRemote r
+changeSyncable (Just r) False = do
+	liftAnnex $ changeSyncFlag r False
+	updateSyncRemotes
+	{- Stop all transfers to or from this remote.
+	 - XXX Can't stop any ongoing scan, or git syncs. -}
+	void $ dequeueTransfers tofrom
+	mapM_ (cancelTransfer False) =<<
+		filter tofrom . M.keys . currentTransfers <$> getDaemonStatus
+  where
+	tofrom t = transferUUID t == Remote.uuid r
+
+changeSyncFlag :: Remote -> Bool -> Annex ()
+changeSyncFlag r enabled = do
+	Config.setConfig key (boolConfig enabled)
+	void Remote.remoteListRefresh
+  where
+	key = Config.remoteConfig (Remote.repo r) "sync"

Assistant/Threads/TransferWatcher.hs

@@ -9,9 +9,7 @@ module Assistant.Threads.TransferWatcher where
 
 import Assistant.Common
 import Assistant.DaemonStatus
-import Assistant.TransferQueue
-import Assistant.Drop
-import Annex.Content
+import Assistant.TransferSlots
 import Logs.Transfer
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
@@ -98,28 +96,3 @@ onDel file = case parseTransferFile file of
 			 - runs. -}
 			threadDelay 10000000 -- 10 seconds
 			finished t minfo
-
-{- Queue uploads of files downloaded to us, spreading them
- - out to other reachable remotes.
- -
- - Downloading a file may have caused a remote to not want it;
- - so check for drops from remotes.
- -
- - Uploading a file may cause the local repo, or some other remote to not
- - want it; handle that too.
- -}
-finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
-finishedTransfer t (Just info)
-	| transferDirection t == Download =
-		whenM (liftAnnex $ inAnnex $ transferKey t) $ do
-			dodrops False
-			queueTransfersMatching (/= transferUUID t)
-				"newly received object"
-				Later (transferKey t) (associatedFile info) Upload
-	| otherwise = dodrops True
-  where
-	dodrops fromhere = handleDrops
-		("drop wanted after " ++ describeTransfer t info)
-		fromhere (transferKey t) (associatedFile info) Nothing
-finishedTransfer _ _ = noop
-

Assistant/Threads/Transferrer.hs

@@ -36,105 +36,3 @@ transfererThread = namedThread "Transferrer" $ do
   where
 	{- Skip transfers that are already running. -}
 	notrunning = isNothing . startedTime
-
-{- By the time this is called, the daemonstatus's currentTransfers map should
- - already have been updated to include the transfer. -}
-genTransfer :: Transfer -> TransferInfo -> TransferGenerator
-genTransfer t info = case (transferRemote info, associatedFile info) of
-	(Just remote, Just file) 
-		| Git.repoIsLocalUnknown (Remote.repo remote) -> do
-			-- optimisation for removable drives not plugged in
-			liftAnnex $ recordFailedTransfer t info
-			void $ removeTransfer t
-			return Nothing
-		| otherwise -> ifM (liftAnnex $ shouldTransfer t info)
-			( do
-				debug [ "Transferring:" , describeTransfer t info ]
-				notifyTransfer
-				return $ Just (t, info, go remote file)
-			, do
-				debug [ "Skipping unnecessary transfer:",
-					describeTransfer t info ]
-				void $ removeTransfer t
-				finishedTransfer t (Just info)
-				return Nothing
-			)
-	_ -> return Nothing
-  where
-	direction = transferDirection t
-	isdownload = direction == Download
-
-	{- Alerts are only shown for successful transfers.
-	 - Transfers can temporarily fail for many reasons,
-	 - so there's no point in bothering the user about
-	 - those. The assistant should recover.
-	 -
-	 - After a successful upload, handle dropping it from
-	 - here, if desired. In this case, the remote it was
-	 - uploaded to is known to have it.
-	 -
-	 - Also, after a successful transfer, the location
-	 - log has changed. Indicate that a commit has been
-	 - made, in order to queue a push of the git-annex
-	 - branch out to remotes that did not participate
-	 - in the transfer.
-	 -
-	 - If the process failed, it could have crashed,
-	 - so remove the transfer from the list of current
-	 - transfers, just in case it didn't stop
-	 - in a way that lets the TransferWatcher do its
-	 - usual cleanup. However, first check if something else is
-	 - running the transfer, to avoid removing active transfers.
-	 -}
-	go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info)
-		( do
-			void $ addAlert $ makeAlertFiller True $
-				transferFileAlert direction True file
-			unless isdownload $
-				handleDrops
-					("object uploaded to " ++ show remote)
-					True (transferKey t)
-					(associatedFile info)
-					(Just remote)
-			void recordCommit
-		, whenM (liftAnnex $ isNothing <$> checkTransfer t) $
-			void $ removeTransfer t
-		)
-
-{- Called right before a transfer begins, this is a last chance to avoid
- - unnecessary transfers.
- -
- - For downloads, we obviously don't need to download if the already
- - have the object.
- -
- - Smilarly, for uploads, check if the remote is known to already have
- - the object.
- -
- - Also, uploads get queued to all remotes, in order of cost.
- - This may mean, for example, that an object is uploaded over the LAN
- - to a locally paired client, and once that upload is done, a more
- - expensive transfer remote no longer wants the object. (Since
- - all the clients have it already.) So do one last check if this is still
- - preferred content.
- -
- - We'll also do one last preferred content check for downloads. An
- - example of a case where this could be needed is if a download is queued
- - for a file that gets moved out of an archive directory -- but before
- - that download can happen, the file is put back in the archive.
- -}
-shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
-shouldTransfer t info
-	| transferDirection t == Download =
-		(not <$> inAnnex key) <&&> wantGet True file
-	| transferDirection t == Upload = case transferRemote info of
-		Nothing -> return False
-		Just r -> notinremote r
-			<&&> wantSend True file (Remote.uuid r)
-	| otherwise = return False
-  where
-	key = transferKey t
-	file = associatedFile info
-
-	{- Trust the location log to check if the remote already has
-	 - the key. This avoids a roundtrip to the remote. -}
-	notinremote r = notElem (Remote.uuid r) <$> loggedLocations key

Assistant/Threads/Watcher.hs

@@ -9,7 +9,7 @@
 
 module Assistant.Threads.Watcher (
 	watchThread,
-	WatcherException(..),
+	WatcherControl(..),
 	checkCanWatch,
 	needLsof,
 	onAddSymlink,
@@ -64,10 +64,10 @@ needLsof = error $ unlines
 	]
 
 {- A special exception that can be thrown to pause or resume the watcher. -}
-data WatcherException = PauseWatcher | ResumeWatcher
+data WatcherControl = PauseWatcher | ResumeWatcher
         deriving (Show, Eq, Typeable)
 
-instance E.Exception WatcherException
+instance E.Exception WatcherControl
 
 watchThread :: NamedThread
 watchThread = namedThread "Watcher" $
@@ -107,7 +107,7 @@ runWatcher = do
   where
 	hook a = Just <$> asIO2 (runHandler a)
 
-waitFor :: WatcherException -> Assistant () -> Assistant ()
+waitFor :: WatcherControl -> Assistant () -> Assistant ()
 waitFor sig next = do
 	r <- liftIO (E.try pause :: IO (Either E.SomeException ()))
 	case r of

Assistant/TransferSlots.hs

@@ -13,11 +13,27 @@ import Assistant.Types.TransferSlots
 import Assistant.DaemonStatus
 import Assistant.TransferrerPool
 import Assistant.Types.TransferrerPool
+import Assistant.Types.TransferQueue
+import Assistant.TransferQueue
+import Assistant.Alert
+import Assistant.Alert.Utility
+import Assistant.Commits
+import Assistant.Drop
 import Logs.Transfer
+import Logs.Location
+import qualified Git
+import qualified Remote
+import qualified Types.Remote as Remote
+import Annex.Content
+import Annex.Wanted
+import Config.Files
 
+import qualified Data.Map as M 
 import qualified Control.Exception as E
 import Control.Concurrent
 import qualified Control.Concurrent.MSemN as MSemN
+import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
+import System.Posix.Process (getProcessGroupIDOf)
 
 type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
 
@@ -76,3 +92,186 @@ runTransferThread' program d run = go
 			_ -> done
 	done = runAssistant d $ 
 		flip MSemN.signal 1 <<~ transferSlots
+
+{- By the time this is called, the daemonstatus's currentTransfers map should
+ - already have been updated to include the transfer. -}
+genTransfer :: Transfer -> TransferInfo -> TransferGenerator
+genTransfer t info = case (transferRemote info, associatedFile info) of
+	(Just remote, Just file) 
+		| Git.repoIsLocalUnknown (Remote.repo remote) -> do
+			-- optimisation for removable drives not plugged in
+			liftAnnex $ recordFailedTransfer t info
+			void $ removeTransfer t
+			return Nothing
+		| otherwise -> ifM (liftAnnex $ shouldTransfer t info)
+			( do
+				debug [ "Transferring:" , describeTransfer t info ]
+				notifyTransfer
+				return $ Just (t, info, go remote file)
+			, do
+				debug [ "Skipping unnecessary transfer:",
+					describeTransfer t info ]
+				void $ removeTransfer t
+				finishedTransfer t (Just info)
+				return Nothing
+			)
+	_ -> return Nothing
+  where
+	direction = transferDirection t
+	isdownload = direction == Download
+
+	{- Alerts are only shown for successful transfers.
+	 - Transfers can temporarily fail for many reasons,
+	 - so there's no point in bothering the user about
+	 - those. The assistant should recover.
+	 -
+	 - After a successful upload, handle dropping it from
+	 - here, if desired. In this case, the remote it was
+	 - uploaded to is known to have it.
+	 -
+	 - Also, after a successful transfer, the location
+	 - log has changed. Indicate that a commit has been
+	 - made, in order to queue a push of the git-annex
+	 - branch out to remotes that did not participate
+	 - in the transfer.
+	 -
+	 - If the process failed, it could have crashed,
+	 - so remove the transfer from the list of current
+	 - transfers, just in case it didn't stop
+	 - in a way that lets the TransferWatcher do its
+	 - usual cleanup. However, first check if something else is
+	 - running the transfer, to avoid removing active transfers.
+	 -}
+	go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info)
+		( do
+			void $ addAlert $ makeAlertFiller True $
+				transferFileAlert direction True file
+			unless isdownload $
+				handleDrops
+					("object uploaded to " ++ show remote)
+					True (transferKey t)
+					(associatedFile info)
+					(Just remote)
+			void recordCommit
+		, whenM (liftAnnex $ isNothing <$> checkTransfer t) $
+			void $ removeTransfer t
+		)
+
+{- Called right before a transfer begins, this is a last chance to avoid
+ - unnecessary transfers.
+ -
+ - For downloads, we obviously don't need to download if the already
+ - have the object.
+ -
+ - Smilarly, for uploads, check if the remote is known to already have
+ - the object.
+ -
+ - Also, uploads get queued to all remotes, in order of cost.
+ - This may mean, for example, that an object is uploaded over the LAN
+ - to a locally paired client, and once that upload is done, a more
+ - expensive transfer remote no longer wants the object. (Since
+ - all the clients have it already.) So do one last check if this is still
+ - preferred content.
+ -
+ - We'll also do one last preferred content check for downloads. An
+ - example of a case where this could be needed is if a download is queued
+ - for a file that gets moved out of an archive directory -- but before
+ - that download can happen, the file is put back in the archive.
+ -}
+shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
+shouldTransfer t info
+	| transferDirection t == Download =
+		(not <$> inAnnex key) <&&> wantGet True file
+	| transferDirection t == Upload = case transferRemote info of
+		Nothing -> return False
+		Just r -> notinremote r
+			<&&> wantSend True file (Remote.uuid r)
+	| otherwise = return False
+  where
+	key = transferKey t
+	file = associatedFile info
+
+	{- Trust the location log to check if the remote already has
+	 - the key. This avoids a roundtrip to the remote. -}
+	notinremote r = notElem (Remote.uuid r) <$> loggedLocations key
+
+{- Queue uploads of files downloaded to us, spreading them
+ - out to other reachable remotes.
+ -
+ - Downloading a file may have caused a remote to not want it;
+ - so check for drops from remotes.
+ -
+ - Uploading a file may cause the local repo, or some other remote to not
+ - want it; handle that too.
+ -}
+finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
+finishedTransfer t (Just info)
+	| transferDirection t == Download =
+		whenM (liftAnnex $ inAnnex $ transferKey t) $ do
+			dodrops False
+			queueTransfersMatching (/= transferUUID t)
+				"newly received object"
+				Later (transferKey t) (associatedFile info) Upload
+	| otherwise = dodrops True
+  where
+	dodrops fromhere = handleDrops
+		("drop wanted after " ++ describeTransfer t info)
+		fromhere (transferKey t) (associatedFile info) Nothing
+finishedTransfer _ _ = noop
+
+{- Pause a running transfer. -}
+pauseTransfer :: Transfer -> Assistant ()
+pauseTransfer = cancelTransfer True
+
+{- Cancel a running transfer. -}
+cancelTransfer :: Bool -> Transfer -> Assistant ()
+cancelTransfer pause t = do
+	m <- getCurrentTransfers
+	unless pause $
+		{- remove queued transfer -}
+		void $ dequeueTransfers $ equivilantTransfer t
+	{- stop running transfer -}
+	maybe noop stop (M.lookup t m)
+  where
+	stop info = do
+		{- When there's a thread associated with the
+		 - transfer, it's signaled first, to avoid it
+		 - displaying any alert about the transfer having
+		 - failed when the transfer process is killed. -}
+		liftIO $ maybe noop signalthread $ transferTid info
+		liftIO $ maybe noop killproc $ transferPid info
+		if pause
+			then void $ alterTransferInfo t $
+				\i -> i { transferPaused = True }
+			else void $ removeTransfer t
+	signalthread tid
+		| pause = throwTo tid PauseTransfer
+		| otherwise = killThread tid
+	{- In order to stop helper processes like rsync,
+	 - kill the whole process group of the process running the transfer. -}
+	killproc pid = void $ tryIO $ do
+		g <- getProcessGroupIDOf pid
+		void $ tryIO $ signalProcessGroup sigTERM g
+		threadDelay 50000 -- 0.05 second grace period
+		void $ tryIO $ signalProcessGroup sigKILL g
+
+{- Start or resume a transfer. -}
+startTransfer :: Transfer -> Assistant ()
+startTransfer t = do
+	m <- getCurrentTransfers
+	maybe startqueued go (M.lookup t m)
+  where
+	go info = maybe (start info) resume $ transferTid info
+	startqueued = do
+		is <- map snd <$> getMatchingTransfers (== t)
+		maybe noop start $ headMaybe is
+	resume tid = do
+		alterTransferInfo t $ \i -> i { transferPaused = False }
+		liftIO $ throwTo tid ResumeTransfer
+	start info = do
+		program <- liftIO readProgramFile
+		inImmediateTransferSlot program $
+			genTransfer t info
+
+getCurrentTransfers :: Assistant TransferMap
+getCurrentTransfers = currentTransfers <$> getDaemonStatus

Assistant/WebApp/Configurators/Delete.hs

@@ -14,6 +14,7 @@ import Assistant.DeleteRemote
 import Assistant.WebApp.Utility
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
+import Assistant.Sync
 import qualified Remote
 import qualified Git
 import Config.Files
@@ -91,9 +92,10 @@ deleteCurrentRepository = dangerPage $ do
 			{- Disable syncing to this repository, and all
 			 - remotes. This stops all transfers, and all
 			 - file watching. -}
-			changeSyncable Nothing False
-			rs <- liftAssistant $ syncRemotes <$> getDaemonStatus
-			mapM_ (\r -> changeSyncable (Just r) False) rs
+			liftAssistant $ do
+				changeSyncable Nothing False
+				rs <- syncRemotes <$> getDaemonStatus
+				mapM_ (\r -> changeSyncable (Just r) False) rs
 
 			{- Make all directories writable, so all annexed
 			 - content can be deleted. -}

Assistant/WebApp/Configurators/Edit.hs

@@ -10,12 +10,12 @@
 module Assistant.WebApp.Configurators.Edit where
 
 import Assistant.WebApp.Common
-import Assistant.WebApp.Utility
 import Assistant.WebApp.Gpg
 import Assistant.DaemonStatus
 import Assistant.MakeRemote (uniqueRemoteName)
 import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
 import Assistant.ScanRemotes
+import Assistant.Sync
 import qualified Assistant.WebApp.Configurators.AWS as AWS
 import qualified Assistant.WebApp.Configurators.IA as IA
 #ifdef WITH_S3
@@ -124,7 +124,7 @@ setRepoConfig uuid mremote oldc newc = do
 				Nothing -> addScanRemotes True
 					=<< syncDataRemotes <$> getDaemonStatus
 	when syncableChanged $
-		changeSyncable mremote (repoSyncable newc)
+		liftAssistant $ changeSyncable mremote (repoSyncable newc)
   where
   	syncableChanged = repoSyncable oldc /= repoSyncable newc
 	associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory newc

Assistant/WebApp/Control.hs

@@ -13,8 +13,8 @@ import Assistant.WebApp.Common
 import Config.Files
 import Utility.LogFile
 import Assistant.DaemonStatus
-import Assistant.WebApp.Utility
 import Assistant.Alert
+import Assistant.TransferSlots
 
 import Control.Concurrent
 import System.Posix (getProcessID, signalProcess, sigTERM)
@@ -26,16 +26,16 @@ getShutdownR = page "Shutdown" Nothing $
 
 getShutdownConfirmedR :: Handler Html
 getShutdownConfirmedR = do
-	{- Remove all alerts for currently running activities. -}
 	liftAssistant $ do
+		{- Remove all alerts for currently running activities. -}
 		updateAlertMap $ M.filter $ \a -> alertClass a /= Activity
 		void $ addAlert shutdownAlert
-	{- Stop transfers the assistant is running,
-	 - otherwise they would continue past shutdown.
-	 - Pausing transfers prevents more being started up (and stops
-	 - the transfer processes). -}
-	ts <- liftAssistant $ M.keys . currentTransfers <$> getDaemonStatus
-	mapM_ pauseTransfer ts
+		{- Stop transfers the assistant is running,
+		 - otherwise they would continue past shutdown.
+		 - Pausing transfers prevents more being started up (and stops
+		 - the transfer processes). -}
+		ts <- M.keys . currentTransfers <$> getDaemonStatus
+		mapM_ pauseTransfer ts
 	page "Shutdown" Nothing $ do
 		{- Wait 2 seconds before shutting down, to give the web
 		 - page time to load in the browser. -}

Assistant/WebApp/DashBoard.hs

@@ -10,10 +10,10 @@
 module Assistant.WebApp.DashBoard where
 
 import Assistant.WebApp.Common
-import Assistant.WebApp.Utility
 import Assistant.WebApp.RepoList
 import Assistant.WebApp.Notifications
 import Assistant.TransferQueue
+import Assistant.TransferSlots
 import Assistant.DaemonStatus
 import Utility.NotificationBroadcaster
 import Logs.Transfer
@@ -31,7 +31,7 @@ import Control.Concurrent
 transfersDisplay :: Bool -> Widget
 transfersDisplay warnNoScript = do
 	webapp <- liftH getYesod
-	current <- liftH $ M.toList <$> getCurrentTransfers
+	current <- liftAssistant $ M.toList <$> getCurrentTransfers
 	queued <- take 10 <$> liftAssistant getTransferQueue
 	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
 	let transfers = simplifyTransfers $ current ++ queued
@@ -139,15 +139,15 @@ openFileBrowser = do
 getPauseTransferR :: Transfer -> Handler ()
 getPauseTransferR = noscript postPauseTransferR
 postPauseTransferR :: Transfer -> Handler ()
-postPauseTransferR = pauseTransfer
+postPauseTransferR = liftAssistant . pauseTransfer
 getStartTransferR :: Transfer -> Handler ()
 getStartTransferR = noscript postStartTransferR
 postStartTransferR :: Transfer -> Handler ()
-postStartTransferR = startTransfer
+postStartTransferR = liftAssistant . startTransfer
 getCancelTransferR :: Transfer -> Handler ()
 getCancelTransferR = noscript postCancelTransferR
 postCancelTransferR :: Transfer -> Handler ()
-postCancelTransferR = cancelTransfer False
+postCancelTransferR = liftAssistant . cancelTransfer False
 
 noscript :: (Transfer -> Handler ()) -> Transfer -> Handler ()
 noscript a t = a t >> redirectBack

Assistant/WebApp/Repair.hs

@@ -10,17 +10,9 @@
 module Assistant.WebApp.Repair where
 
 import Assistant.WebApp.Common
-import Assistant.WebApp.Utility
 import Assistant.WebApp.RepoList
 import Remote (prettyUUID)
-import Command.Repair (repairAnnexBranch)
-import Git.Repair (runRepairOf)
-import Logs.FsckResults
-import Annex.UUID
-import Utility.Batch
-import Config.Files
-
-import Control.Concurrent.Async
+import Assistant.Repair
 
 getRepairRepositoryR :: UUID -> Handler Html
 getRepairRepositoryR = postRepairRepositoryR
@@ -33,48 +25,8 @@ getRepairRepositoryRunR :: UUID -> Handler Html
 getRepairRepositoryRunR = postRepairRepositoryRunR
 postRepairRepositoryRunR :: UUID -> Handler Html
 postRepairRepositoryRunR u = do
-	-- Stop the watcher from running while running repairs.
-	changeSyncable Nothing False
-
-	fsckthread <- liftAssistant $ runRepair u
-
-	-- Start the watcher running again. This also triggers it to do a
-	-- startup scan, which is especially important if the git repo
-	-- repair removed files from the index file. Those files will be
-	-- seen as new, and re-added to the repository.
-	changeSyncable Nothing True
-
-	liftAnnex $ writeFsckResults u Nothing
-
+	liftAssistant $ runRepair u
 	page "Repair repository" Nothing $ do
 		let repolist = repoListDisplay $
 			mainRepoSelector { nudgeAddMore = True }
 		$(widgetFile "control/repairrepository/done")
-
-runRepair :: UUID -> Assistant ()
-runRepair u = do
-	fsckresults <- liftAnnex (readFsckResults u)
-	myu <- liftAnnex getUUID
-	if u == myu
-		then localrepair fsckresults
-		else remoterepair fsckresults
-  where
-  	localrepair fsckresults = do
-		-- This intentionally runs the repair inside the Annex
-		-- monad, which is not stricktly necessary, but keeps
-		-- other threads that might be trying to use the Annex
-		-- from running until it completes.
-		needfsck <- liftAnnex $ do
-			(ok, stillmissing, modifiedbranches) <- inRepo $
-				runRepairOf fsckresults True
-			repairAnnexBranch stillmissing modifiedbranches
-			return (not ok)
-		when needfsck $
-			backgroundfsck [ Param "--fast" ]
-
-	remoterepair _fsckresults = do
-		error "TODO: remote repair"
-	
-	backgroundfsck params = liftIO $ void $ async $ do
-		program <- readProgramFile
-		batchCommand program (Param "fsck" : params)

Assistant/WebApp/RepoList.hs

@@ -12,7 +12,6 @@ module Assistant.WebApp.RepoList where
 import Assistant.WebApp.Common
 import Assistant.DaemonStatus
 import Assistant.WebApp.Notifications
-import Assistant.WebApp.Utility
 import Assistant.Ssh
 import qualified Annex
 import qualified Remote
@@ -208,7 +207,7 @@ getDisableSyncR = flipSync False
 flipSync :: Bool -> UUID -> Handler ()
 flipSync enable uuid = do
 	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
-	changeSyncable mremote enable
+	liftAssistant $ changeSyncable mremote enable
 	redirectBack
 
 getRepositoriesReorderR :: Handler ()

Assistant/WebApp/Utility.hs

@@ -9,122 +9,17 @@ module Assistant.WebApp.Utility where
 
 import Assistant.Common
 import Assistant.WebApp.Types
-import Assistant.DaemonStatus
-import Assistant.TransferQueue
-import Assistant.Types.TransferSlots
-import Assistant.TransferSlots
 import Assistant.Sync
 import qualified Remote
-import qualified Types.Remote as Remote
-import qualified Remote.List as Remote
-import qualified Assistant.Threads.Transferrer as Transferrer
-import Logs.Transfer
 import qualified Config
 import Config.Cost
-import Config.Files
-import Git.Config
-import Assistant.Threads.Watcher
-import Assistant.NamedThread
 import Types.StandardGroups
 import Git.Remote
 import Logs.PreferredContent
 import Assistant.MakeRemote
 
-import qualified Data.Map as M
-import Control.Concurrent
-import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
-import System.Posix.Process (getProcessGroupIDOf)
 import Utility.Yesod
 
-{- Use Nothing to change autocommit setting; or a remote to change
- - its sync setting. -}
-changeSyncable :: Maybe Remote -> Bool -> Handler ()
-changeSyncable Nothing enable = do
-	liftAnnex $ Config.setConfig key (boolConfig enable)
-	liftIO . maybe noop (`throwTo` signal)
-		=<< liftAssistant (namedThreadId watchThread)
-  where
-	key = Config.annexConfig "autocommit"
-	signal
-		| enable = ResumeWatcher
-		| otherwise = PauseWatcher
-changeSyncable (Just r) True = do
-	changeSyncFlag r True
-	liftAssistant $ syncRemote r
-changeSyncable (Just r) False = do
-	changeSyncFlag r False
-	liftAssistant updateSyncRemotes
-	{- Stop all transfers to or from this remote.
-	 - XXX Can't stop any ongoing scan, or git syncs. -}
-	void $ liftAssistant $ dequeueTransfers tofrom
-	mapM_ (cancelTransfer False) =<<
-		filter tofrom . M.keys <$>
-			liftAssistant (currentTransfers <$> getDaemonStatus)
-  where
-	tofrom t = transferUUID t == Remote.uuid r
-
-changeSyncFlag :: Remote -> Bool -> Handler ()
-changeSyncFlag r enabled = liftAnnex $ do
-	Config.setConfig key (boolConfig enabled)
-	void Remote.remoteListRefresh
-  where
-	key = Config.remoteConfig (Remote.repo r) "sync"
-
-pauseTransfer :: Transfer -> Handler ()
-pauseTransfer = cancelTransfer True
-
-cancelTransfer :: Bool -> Transfer -> Handler ()
-cancelTransfer pause t = do
-	m <- getCurrentTransfers
-	unless pause $
-		{- remove queued transfer -}
-		void $ liftAssistant $ dequeueTransfers $ equivilantTransfer t
-	{- stop running transfer -}
-	maybe noop stop (M.lookup t m)
-  where
-	stop info = liftAssistant $ do
-		{- When there's a thread associated with the
-		 - transfer, it's signaled first, to avoid it
-		 - displaying any alert about the transfer having
-		 - failed when the transfer process is killed. -}
-		liftIO $ maybe noop signalthread $ transferTid info
-		liftIO $ maybe noop killproc $ transferPid info
-		if pause
-			then void $ alterTransferInfo t $
-				\i -> i { transferPaused = True }
-			else void $ removeTransfer t
-	signalthread tid
-		| pause = throwTo tid PauseTransfer
-		| otherwise = killThread tid
-	{- In order to stop helper processes like rsync,
-	 - kill the whole process group of the process running the transfer. -}
-	killproc pid = void $ tryIO $ do
-		g <- getProcessGroupIDOf pid
-		void $ tryIO $ signalProcessGroup sigTERM g
-		threadDelay 50000 -- 0.05 second grace period
-		void $ tryIO $ signalProcessGroup sigKILL g
-
-startTransfer :: Transfer -> Handler ()
-startTransfer t = do
-	m <- getCurrentTransfers
-	maybe startqueued go (M.lookup t m)
-  where
-	go info = maybe (start info) resume $ transferTid info
-	startqueued = do
-		is <- liftAssistant $ map snd <$> getMatchingTransfers (== t)
-		maybe noop start $ headMaybe is
-	resume tid = do
-		liftAssistant $ alterTransferInfo t $
-			\i -> i { transferPaused = False }
-		liftIO $ throwTo tid ResumeTransfer
-	start info = liftAssistant $ do
-		program <- liftIO readProgramFile
-		inImmediateTransferSlot program $
-			Transferrer.genTransfer t info
-
-getCurrentTransfers :: Handler TransferMap
-getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus
-
 {- Runs an action that creates or enables a cloud remote,
  - and finishes setting it up, then starts syncing with it,
  - and finishes by displaying the page to edit it. -}