add syncing enabled/disabled to repo list with icon, and toggle link

The toggle link doesn't work yet.

Also lots of refactoring and type improvements

Assistant/WebApp/Utility.hs

@@ -0,0 +1,125 @@
+{- git-annex assistant webapp utilities
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Assistant.WebApp.Utility where
+
+import Assistant.Common
+import Assistant.WebApp.Types
+import Assistant.DaemonStatus
+import Assistant.ThreadedMonad
+import Assistant.TransferQueue
+import Assistant.TransferSlots
+import Assistant.Sync
+import qualified Remote
+import qualified Assistant.Threads.Transferrer as Transferrer
+import Logs.Transfer
+import Locations.UserConfig
+
+import Yesod
+import qualified Data.Map as M
+import Control.Concurrent
+import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
+import System.Posix.Process (getProcessGroupIDOf)
+
+changeSyncable :: Remote -> Bool -> Handler ()
+changeSyncable r True = syncRemote r
+changeSyncable r False = do
+	webapp <- getYesod
+	let dstatus = daemonStatus webapp
+	let st = fromJust $ threadState webapp
+	liftIO $ runThreadState st $ updateKnownRemotes dstatus
+	{- Stop all transfers to or from this remote.
+	 - XXX Can't stop any ongoing scan, or git syncs. -}
+	void $ liftIO $ dequeueTransfers (transferQueue webapp) dstatus tofrom
+	mapM_ (cancelTransfer False) =<<
+		filter tofrom . M.keys <$>
+			liftIO (currentTransfers <$> getDaemonStatus dstatus)
+	where
+		tofrom t = transferUUID t == Remote.uuid r
+
+{- Start syncing remote, using a background thread. -}
+syncRemote :: Remote -> Handler ()
+syncRemote remote = do
+	webapp <- getYesod
+	liftIO $ syncNewRemote
+		(fromJust $ threadState webapp)
+		(daemonStatus webapp)
+		(scanRemotes webapp)
+		remote
+
+pauseTransfer :: Transfer -> Handler ()
+pauseTransfer = cancelTransfer True
+
+cancelTransfer :: Bool -> Transfer -> Handler ()
+cancelTransfer pause t = do
+	webapp <- getYesod
+	let dstatus = daemonStatus webapp
+	m <- getCurrentTransfers
+	liftIO $ do
+		unless pause $
+			{- remove queued transfer -}
+			void $ dequeueTransfers (transferQueue webapp) dstatus $
+				equivilantTransfer t
+		{- stop running transfer -}
+		maybe noop (stop dstatus) (M.lookup t m)
+	where
+		stop dstatus 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. -}
+			maybe noop signalthread $ transferTid info
+			maybe noop killproc $ transferPid info
+			if pause
+				then void $
+					alterTransferInfo dstatus t $ \i -> i
+						{ transferPaused = True }
+				else void $
+					removeTransfer dstatus 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 = 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
+			webapp <- getYesod
+			let dstatus = daemonStatus webapp
+			let q = transferQueue webapp
+			is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
+			maybe noop start $ headMaybe is
+		resume tid = do
+			webapp <- getYesod
+			let dstatus = daemonStatus webapp
+			liftIO $ do
+				alterTransferInfo dstatus t $ \i -> i
+					{ transferPaused = False }
+				throwTo tid ResumeTransfer
+		start info = do
+			webapp <- getYesod
+			let st = fromJust $ threadState webapp
+			let dstatus = daemonStatus webapp
+			let slots = transferSlots webapp
+			liftIO $ inImmediateTransferSlot dstatus slots $ do
+				program <- readProgramFile
+				Transferrer.startTransfer st dstatus program t info
+
+getCurrentTransfers :: Handler TransferMap
+getCurrentTransfers = currentTransfers
+	<$> (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)