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/Configurators.hs

@@ -13,8 +13,8 @@ import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
-import Assistant.DaemonStatus
 import Assistant.WebApp.Configurators.Local
+import Assistant.DaemonStatus
 import Utility.Yesod
 import qualified Remote
 import qualified Types.Remote as Remote
@@ -37,71 +37,6 @@ getConfigR = ifM (inFirstRun)
 		$(widgetFile "configurators/main")
 	)
 
-{- Lists known repositories, followed by options to add more. -}
-getRepositoriesR :: Handler RepHtml
-getRepositoriesR = bootstrap (Just Config) $ do
-	sideBarDisplay
-	setTitle "Repositories"
-	repolist <- lift $ repoList False True
-	$(widgetFile "configurators/repositories")
-
-data SetupRepo =
-	EnableRepo (Route WebApp) |
-	EditRepo (Route WebApp) |
-	EnableSyncRepo (Route WebApp)
-
-needsEnabled :: SetupRepo -> Bool
-needsEnabled (EnableRepo _) = True
-needsEnabled _ = False
-
-notSyncing :: SetupRepo -> Bool
-notSyncing (EnableSyncRepo _) = True
-notSyncing _ = False
-
-setupRepoLink :: SetupRepo -> Route WebApp
-setupRepoLink (EnableRepo r) = r
-setupRepoLink (EditRepo r) = r
-setupRepoLink (EnableSyncRepo r) = r
-
-{- A numbered list of known repositories. -}
-repoList :: Bool -> Bool -> Handler [(String, String, SetupRepo)]
-repoList onlyconfigured includehere
-	| onlyconfigured = list =<< configured
-	| otherwise = list =<< (++) <$> configured <*> rest
-	where
-		configured = do
-			rs <- filter (not . Remote.readonly) . knownRemotes <$>
-				(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
-			runAnnex [] $ do
-				u <- getUUID
-				let l = map Remote.uuid rs
-				let l' = if includehere then u : l else l
-				return $ withlinks (EditRepo . EditRepositoryR) l'
-		withlinks mklink l = zip l (map mklink l)
-		rest = runAnnex [] $ do
-			m <- readRemoteLog
-			unconfigured <- catMaybes . map (findtype m) . snd
-				<$> (trustPartition DeadTrusted $ M.keys m)
-			unsyncable <- withlinks (EnableSyncRepo . EditRepositoryR) . map Remote.uuid <$>
-				(filterM (\r -> not <$> repoSyncable (Remote.repo r))
-					=<< Remote.enabledRemoteList)
-			return $ unsyncable ++ unconfigured
-		findtype m u = case M.lookup u m of
-			Nothing -> Nothing
-			Just c -> case M.lookup "type" c of
-				Just "rsync" -> u `enableswith` EnableRsyncR
-				Just "directory" -> u `enableswith` EnableDirectoryR
-				Just "S3" -> u `enableswith` EnableS3R
-				_ -> Nothing
-		u `enableswith` r = Just (u, EnableRepo $ r u)
-		list l = runAnnex [] $ do
-			let l' = nubBy (\x y -> fst x == fst y) l
-			zip3
-				<$> pure counter
-				<*> Remote.prettyListUUIDs (map fst l')
-				<*> pure (map snd l')
-		counter = map show ([1..] :: [Int])
-
 {- An intro message, list of repositories, and nudge to make more. -}
 introDisplay :: Text -> Widget
 introDisplay ident = do
@@ -114,3 +49,93 @@ introDisplay ident = do
 	lift $ modifyWebAppState $ \s -> s { showIntro = False }
 	where
 		enough = 2
+
+{- Lists known repositories, followed by options to add more. -}
+getRepositoriesR :: Handler RepHtml
+getRepositoriesR = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Repositories"
+	repolist <- lift $ repoList False True
+	$(widgetFile "configurators/repositories")
+
+data Actions
+	= DisabledRepoActions
+		{ setupRepoLink :: Route WebApp }
+	| SyncingRepoActions
+		{ setupRepoLink :: Route WebApp
+		, syncToggleLink :: Route WebApp
+		}
+	| NotSyncingRepoActions
+		{ setupRepoLink :: Route WebApp
+		, syncToggleLink :: Route WebApp
+		}
+
+mkSyncingRepoActions :: UUID -> Actions
+mkSyncingRepoActions u = SyncingRepoActions
+	{ setupRepoLink = EditRepositoryR u
+	, syncToggleLink = DisableSyncR u
+	}
+
+mkNotSyncingRepoActions :: UUID -> Actions
+mkNotSyncingRepoActions u = NotSyncingRepoActions
+	{ setupRepoLink = EditRepositoryR u
+	, syncToggleLink = EnableSyncR u
+	}
+
+needsEnabled :: Actions -> Bool
+needsEnabled (DisabledRepoActions _) = True
+needsEnabled _ = False
+
+notSyncing :: Actions -> Bool
+notSyncing (SyncingRepoActions _ _) = False
+notSyncing _ = True
+
+{- A numbered list of known repositories,
+ - with actions that can be taken on them. -}
+repoList :: Bool -> Bool -> Handler [(String, String, Actions)]
+repoList onlyconfigured includehere
+	| onlyconfigured = list =<< configured
+	| otherwise = list =<< (++) <$> configured <*> rest
+	where
+		configured = do
+			rs <- filter (not . Remote.readonly) . knownRemotes <$>
+				(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
+			runAnnex [] $ do
+				u <- getUUID
+				let l = map Remote.uuid rs
+				let l' = if includehere then u : l else l
+				return $ zip l' $ map mkSyncingRepoActions l'
+		rest = runAnnex [] $ do
+			m <- readRemoteLog
+			unconfigured <- catMaybes . map (findtype m) . snd
+				<$> (trustPartition DeadTrusted $ M.keys m)
+			unsyncable <- map Remote.uuid <$>
+				(filterM (\r -> not <$> repoSyncable (Remote.repo r))
+					=<< Remote.enabledRemoteList)
+			return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured
+		findtype m u = case M.lookup u m of
+			Nothing -> Nothing
+			Just c -> case M.lookup "type" c of
+				Just "rsync" -> u `enableswith` EnableRsyncR
+				Just "directory" -> u `enableswith` EnableDirectoryR
+				Just "S3" -> u `enableswith` EnableS3R
+				_ -> Nothing
+		u `enableswith` r = Just (u, DisabledRepoActions $ r u)
+		list l = runAnnex [] $ do
+			let l' = nubBy (\x y -> fst x == fst y) l
+			zip3
+				<$> pure counter
+				<*> Remote.prettyListUUIDs (map fst l')
+				<*> pure (map snd l')
+		counter = map show ([1..] :: [Int])
+
+
+getEnableSyncR :: UUID -> Handler ()
+getEnableSyncR uuid = do
+	error "TODO"
+	redirect RepositoriesR
+
+getDisableSyncR :: UUID -> Handler ()
+getDisableSyncR uuid = do
+	error "TODO"
+	redirect RepositoriesR

Assistant/WebApp/Configurators/Edit.hs

@@ -13,11 +13,7 @@ import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
-import Assistant.WebApp.Configurators.Local (syncRemote)
+import Assistant.WebApp.Utility
-import Assistant.WebApp.DashBoard (cancelTransfer)
-import Assistant.DaemonStatus
-import Assistant.TransferQueue
-import Assistant.ThreadedMonad
 import Utility.Yesod
 import qualified Remote
 import qualified Remote.List as Remote
@@ -25,7 +21,6 @@ import qualified Types.Remote as Remote
 import Logs.UUID
 import Logs.Group
 import Logs.PreferredContent
-import Logs.Transfer
 import Types.StandardGroups
 import qualified Config
 import Annex.UUID
@@ -80,23 +75,6 @@ setRepoConfig uuid r c = do
 				else return Nothing
 		)
 
-changeSyncable :: Maybe Remote -> Bool -> Handler ()
-changeSyncable Nothing _ = noop
-changeSyncable (Just r) True = syncRemote r
-changeSyncable (Just 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
-
 editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
 editRepositoryAForm def = RepoConfig
 	<$> areq textField "Description" (Just $ repoDescription def)
@@ -122,14 +100,16 @@ editForm new uuid = bootstrap (Just Config) $ do
 	sideBarDisplay
 	setTitle "Configure repository"
 
-	(repo, remote) <- lift $ runAnnex undefined getrepo
+	(repo, mremote) <- lift $ runAnnex undefined getrepo
 	curr <- lift $ runAnnex undefined $ getRepoConfig uuid repo
 	((result, form), enctype) <- lift $
 		runFormGet $ renderBootstrap $ editRepositoryAForm curr
 	case result of
 		FormSuccess input -> lift $ do
-			maybe noop (changeSyncable remote) =<<
+			r <- runAnnex undefined $
-				runAnnex undefined (setRepoConfig uuid repo input)
+				setRepoConfig uuid repo input
+			maybe noop (uncurry changeSyncable) $
+				(,) <$> mremote <*> r
 			redirect RepositoriesR
 		_ -> showform form enctype curr
 	where

Assistant/WebApp/Configurators/Local.hs

@@ -13,7 +13,7 @@ import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
-import Assistant.Sync
+import Assistant.WebApp.Utility
 import Assistant.MakeRemote
 import Utility.Yesod
 import Init
@@ -227,16 +227,6 @@ getEnableDirectoryR uuid = bootstrap (Just Config) $ do
 		T.pack . concat <$> prettyListUUIDs [uuid]
 	$(widgetFile "configurators/enabledirectory")
 
-{- Start syncing a newly added remote, using a background thread. -}
-syncRemote :: Remote -> Handler ()
-syncRemote remote = do
-	webapp <- getYesod
-	liftIO $ syncNewRemote
-		(fromJust $ threadState webapp)
-		(daemonStatus webapp)
-		(scanRemotes webapp)
-		remote
-
 {- List of removable drives. -}
 driveList :: IO [RemovableDrive]
 driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts

Assistant/WebApp/DashBoard.hs

@@ -12,13 +12,12 @@ module Assistant.WebApp.DashBoard where
 import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.Types
+import Assistant.WebApp.Utility
 import Assistant.WebApp.SideBar
 import Assistant.WebApp.Notifications
 import Assistant.WebApp.Configurators
 import Assistant.DaemonStatus
 import Assistant.TransferQueue
-import Assistant.TransferSlots
-import qualified Assistant.Threads.Transferrer as Transferrer
 import Utility.NotificationBroadcaster
 import Utility.Yesod
 import Logs.Transfer
@@ -27,14 +26,11 @@ import Utility.DataUnits
 import Types.Key
 import qualified Remote
 import qualified Git
-import Locations.UserConfig
 
 import Yesod
 import Text.Hamlet
 import qualified Data.Map as M
 import Control.Concurrent
-import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
-import System.Posix.Process (getProcessGroupIDOf)
 
 {- A display of currently running and queued transfers.
  -
@@ -162,76 +158,3 @@ getCancelTransferR :: Transfer -> Handler ()
 getCancelTransferR t = cancelTransfer False t >> redirectBack
 postCancelTransferR :: Transfer -> Handler ()
 postCancelTransferR t = cancelTransfer False t
-
-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)

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)

Assistant/WebApp/routes

@@ -12,6 +12,8 @@
 /config/repository/switchto/#FilePath SwitchToRepositoryR GET
 /config/repository/edit/#UUID EditRepositoryR GET
 /config/repository/edit/new/#UUID EditNewRepositoryR GET
+/config/repository/sync/disable/#UUID DisableSyncR GET
+/config/repository/sync/enable/#UUID EnableSyncR GET
 
 /config/repository/add/drive AddDriveR GET
 /config/repository/add/ssh AddSshR GET

doc/install.mdwn

@@ -12,6 +12,7 @@ details.
 [[ArchLinux]]        | `yaourt -Sy git-annex`
 [[NixOS]]            | `nix-env -i git-annex`
 [[Gentoo]]           | `emerge git-annex`
+[[NixOS]]            | `nix install git-annex`
 [[ScientificLinux5]] | (and other RHEL5 clones like CentOS5)
 [[Fedora]]           | 
 [[openSUSE]]         | 

templates/configurators/repositories.hamlet

@@ -3,26 +3,28 @@
     Your repositories
   <table .table .table-condensed>
     <tbody>
-      $forall (num, name, setuprepo) <- repolist
+      $forall (num, name, actions) <- repolist
         <tr>
           <td>
             #{num}
           <td>
-            $if needsEnabled setuprepo
+            #{name}
-              <i>#{name}
-            $else
-              #{name}
           <td>
-            $if needsEnabled setuprepo
+            $if needsEnabled actions
-              <i>not enabled here #
+              <a href="@{setupRepoLink actions}">
-              &rarr; #
+                <i .icon-warning-sign></i> not enabled
-              <a href="@{setupRepoLink setuprepo}">
+            $else
+              <a href="@{syncToggleLink actions}">
+                $if notSyncing actions
+                  <i .icon-pause></i> syncing paused
+                $else
+                  <i .icon-refresh></i> syncing enabled
+          <td>
+            $if needsEnabled actions
+              <a href="@{setupRepoLink actions}">
                 enable
             $else
-              $if notSyncing setuprepo
+              <a href="@{setupRepoLink actions}">
-                <i>syncing disabled #
-                &rarr; #
-              <a href="@{setupRepoLink setuprepo}">
                 configure
   <div .row-fluid>
     <div .span6>