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/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. -}