webapp automatic grouping

webapp: Adds newly created repositories to one of these groups:
clients, drives, servers

This is heuristic, but it's a pretty good heuristic, and can always be
configured.

Assistant/MakeRemote.hs

@@ -28,11 +28,12 @@ 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 ()
+makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO Remote
 makeSshRemote st dstatus scanremotes forcersync sshdata = do
 	r <- runThreadState st $
 		addRemote $ maker (sshRepoName sshdata) sshurl
 	syncNewRemote st dstatus scanremotes r
+	return r
 	where
 		rsync = forcersync || rsyncOnly sshdata
 		maker

Assistant/Pairing/MakeRemote.hs

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

Assistant/WebApp/Configurators/Local.hs

@@ -28,10 +28,13 @@ import Utility.DiskFree
 import Utility.DataUnits
 import Utility.Network
 import Remote (prettyListUUIDs)
+import Logs.Group
+import Annex.UUID
 
 import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Set as S
 import Data.Char
 import System.Posix.Directory
 import qualified Control.Exception as E
@@ -142,10 +145,10 @@ getNewRepositoryR = bootstrap (Just Config) $ do
 	case res of
 		FormSuccess (RepositoryPath p) -> lift $ do
 			let path = T.unpack p
-			liftIO $ do
+			liftIO $ makeRepo path False
-				makeRepo path False
+			u <- liftIO $ initRepo path Nothing
-				initRepo path Nothing
+			runAnnex () $ groupSet u (S.singleton "clients")
-				addAutoStart path
+			liftIO $ addAutoStart path
 			redirect $ SwitchToRepositoryR path
 		_ -> $(widgetFile "configurators/newrepository")
 
@@ -191,8 +194,9 @@ getAddDriveR = bootstrap (Just Config) $ do
 	where
 		go mountpoint = do
 			liftIO $ makerepo dir
-			liftIO $ initRepo dir $ Just remotename
+			u <- liftIO $ initRepo dir $ Just remotename
 			r <- addremote dir remotename
+			runAnnex () $ groupSet u (S.singleton "drives")
 			syncRemote r
 			where
 				dir = mountpoint </> gitAnnexAssistantDefaultDir
@@ -260,9 +264,10 @@ driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
 startFullAssistant :: FilePath -> Handler ()
 startFullAssistant path = do
 	webapp <- getYesod
+	liftIO $ makeRepo path False
+	u <- liftIO $ initRepo path Nothing
+	runAnnex () $ groupSet u (S.singleton "clients")
 	url <- liftIO $ do
-		makeRepo path False
-		initRepo path Nothing
 		addAutoStart path
 		changeWorkingDirectory path
 		fromJust $ postFirstRun webapp
@@ -286,10 +291,11 @@ inDir dir a = do
 	Annex.eval state a
 
 {- Initializes a git-annex repository in a directory with a description. -}
-initRepo :: FilePath -> Maybe String -> IO ()
+initRepo :: FilePath -> Maybe String -> IO UUID
-initRepo dir desc = inDir dir $
+initRepo dir desc = inDir dir $ do
 	unlessM isInitialized $
 		initialize desc
+	getUUID
 
 {- Adds a directory to the autostart file. -}
 addAutoStart :: FilePath -> IO ()

Assistant/WebApp/Configurators/S3.hs

@@ -19,12 +19,14 @@ import Assistant.ThreadedMonad
 import Utility.Yesod
 import qualified Remote.S3 as S3
 import Logs.Remote
-import Remote (prettyListUUIDs)
+import qualified Remote
 import Types.Remote (RemoteConfig)
+import Logs.Group
 
 import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Set as S
 import qualified Data.Map as M
 
 s3Configurator :: Widget -> Handler RepHtml
@@ -80,7 +82,7 @@ getAddS3R = s3Configurator $ do
 	case result of
 		FormSuccess s3input -> lift $ do
 			let name = T.unpack $ repoName s3input
-			makeS3Remote (extractCreds s3input) name $ M.fromList
+			makeS3Remote (extractCreds s3input) name setgroup $ M.fromList
 				[ ("encryption", "shared")
 				, ("type", "S3")
 				, ("datacenter", T.unpack $ datacenter s3input)
@@ -91,6 +93,8 @@ getAddS3R = s3Configurator $ do
 		showform form enctype = do
 			let authtoken = webAppFormAuthToken
 			$(widgetFile "configurators/adds3")
+		setgroup r = runAnnex () $
+			groupSet (Remote.uuid r) (S.singleton "servers")
 
 getEnableS3R :: UUID -> Handler RepHtml
 getEnableS3R uuid = s3Configurator $ do
@@ -101,24 +105,24 @@ getEnableS3R uuid = s3Configurator $ do
 			m <- runAnnex M.empty readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m
-			makeS3Remote s3creds name M.empty
+			makeS3Remote s3creds name (const noop) M.empty
 		_ -> showform form enctype
 	where
 		showform form enctype = do
 			let authtoken = webAppFormAuthToken
 			description <- lift $ runAnnex "" $
-				T.pack . concat <$> prettyListUUIDs [uuid]
+				T.pack . concat <$> Remote.prettyListUUIDs [uuid]
 			$(widgetFile "configurators/enables3")
 
-makeS3Remote :: S3Creds -> String -> RemoteConfig -> Handler ()
+makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
-makeS3Remote (S3Creds ak sk) name config = do
+makeS3Remote (S3Creds ak sk) name setup config = do
 	webapp <- getYesod
 	let st = fromJust $ threadState webapp
 	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
-	liftIO $ do
+	liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)
-		S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)
+	r <- liftIO $ runThreadState st $ addRemote $ do
-		r <- runThreadState st $ addRemote $ do
+		makeSpecialRemote name S3.remote config
-			makeSpecialRemote name S3.remote config
+		return remotename
-			return remotename
+	setup r
-		syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r
+	liftIO $ syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r
 	redirect RepositoriesR

Assistant/WebApp/Configurators/Ssh.hs

@@ -19,11 +19,13 @@ import Utility.Yesod
 import Utility.Rsync (rsyncUrlIsShell)
 import Logs.Remote
 import Remote
+import Logs.Group
 
 import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Map as M
+import qualified Data.Set as S
 import Network.Socket
 import System.Posix.User
 
@@ -130,7 +132,7 @@ getEnableRsyncR u = do
 			case result of
 				FormSuccess sshinput'
 					| isRsyncNet (hostname sshinput') ->
-						void $ lift $ makeRsyncNet sshinput'
+						void $ lift $ makeRsyncNet sshinput' (const noop)
 					| otherwise -> do
 						s <- liftIO $ testServer sshinput'
 						case s of
@@ -250,23 +252,23 @@ getConfirmSshR sshdata = sshConfigurator $ do
 	$(widgetFile "configurators/ssh/confirm")
 
 getMakeSshGitR :: SshData -> Handler RepHtml
-getMakeSshGitR = makeSsh False
+getMakeSshGitR = makeSsh False setupGroup
 
 getMakeSshRsyncR :: SshData -> Handler RepHtml
-getMakeSshRsyncR = makeSsh True
+getMakeSshRsyncR = makeSsh True setupGroup
 
-makeSsh :: Bool -> SshData -> Handler RepHtml
+makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
-makeSsh rsync sshdata
+makeSsh rsync setup sshdata
 	| needsPubKey sshdata = do
 		keypair <- liftIO genSshKeyPair
 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
-		makeSsh' rsync sshdata' (Just keypair)
+		makeSsh' rsync setup sshdata' (Just keypair)
-	| otherwise = makeSsh' rsync sshdata Nothing
+	| otherwise = makeSsh' rsync setup sshdata Nothing
 
-makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml
+makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> Maybe SshKeyPair -> Handler RepHtml
-makeSsh' rsync sshdata keypair =
+makeSsh' rsync setup sshdata keypair =
 	sshSetup [sshhost, remoteCommand] "" $
-		makeSshRepo rsync sshdata
+		makeSshRepo rsync setup sshdata
 	where
 		sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
 		remotedir = T.unpack $ sshDirectory sshdata
@@ -280,14 +282,15 @@ makeSsh' rsync sshdata keypair =
 				else Nothing
 			]
 
-makeSshRepo :: Bool -> SshData -> Handler RepHtml
+makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
-makeSshRepo forcersync sshdata = do
+makeSshRepo forcersync setup sshdata = do
 	webapp <- getYesod
-	liftIO $ makeSshRemote
+	r <- liftIO $ makeSshRemote
 		(fromJust $ threadState webapp)
 		(daemonStatus webapp)
 		(scanRemotes webapp)
 		forcersync sshdata
+	setup r
 	redirect RepositoriesR
 
 getAddRsyncNetR :: Handler RepHtml
@@ -303,14 +306,14 @@ getAddRsyncNetR = do
 	case result of
 		FormSuccess sshinput
 			| isRsyncNet (hostname sshinput) ->
-				makeRsyncNet sshinput
+				makeRsyncNet sshinput setupGroup
 			| otherwise ->
 				showform $ UnusableServer
 					"That is not a rsync.net host name."
 		_ -> showform UntestedServer
 
-makeRsyncNet :: SshInput -> Handler RepHtml
+makeRsyncNet :: SshInput -> (Remote -> Handler ()) -> Handler RepHtml
-makeRsyncNet sshinput = do
+makeRsyncNet sshinput setup = do
 	knownhost <- liftIO $ maybe (return False) knownHost (hostname sshinput)
 	keypair <- liftIO $ genSshKeyPair
 	sshdata <- liftIO $ setupSshKeyPair keypair $
@@ -338,8 +341,11 @@ makeRsyncNet sshinput = do
 		, remotecommand
 		]
 	sshSetup sshopts (sshPubKey keypair) $
-		makeSshRepo True sshdata
+		makeSshRepo True setup sshdata
 
 isRsyncNet :: Maybe Text -> Bool
 isRsyncNet Nothing = False
 isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
+
+setupGroup :: Remote -> Handler ()
+setupGroup r = runAnnex () $ groupSet (Remote.uuid r) (S.singleton "server")

debian/changelog

@@ -1,10 +1,12 @@
 git-annex (3.20121002) UNRELEASED; urgency=low
 
-  * group, ungroup: New commands to indicate groups of repositories.
   * watch, assistant: It's now safe to git annex unlock files while
     the watcher is running, as well as modify files checked into git
     as normal files. Additionally, .gitignore settings are now honored.
     Closes: #689979
+  * group, ungroup: New commands to indicate groups of repositories.
+  * webapp: Adds newly created repositories to one of these groups:
+    clients, drives, servers
   * vicfg: New command, allows editing (or simply viewing) most
     of the repository configuration settings stored in the git-annex branch.
   * Added preferred content expressions, configurable using vicfg.

doc/design/assistant/transfer_control.mdwn

@@ -6,8 +6,19 @@ it doesn't currently have, is covered by the [[partial_content]] page.
 
 But often the remote is just a removable drive or a cloud remote,
 that has a limited size. This page is about making the assistant do
-something smart with such remotes. (Which it now does.. **done** except for
+something smart with such remotes.
-an easy way to configure this.)
+
+## TODO
+
+* easy configuration of preferred content
+* Drop no longer preferred content.
+  - When a file is renamed, it might stop being preferred, so
+    could be checked and dropped. (If there's multiple links to
+    the same content, this gets tricky.)
+  - When a file is sent or received, the sender's preferred content
+    settings may change, causing it to be dropped from the sender.
+  - May also want to check for things to drop, from both local and remotes,
+    when doing the expensive trasfer scan.
 
 ## specifying what data a remote prefers to contain **done**