webapp: avoid overwriting remote configs when enabling it

Avoid stomping on existing group and preferred content settings
when enabling or combining with an already existing remote.

Two level fix. First, use defaultStandardGroup rather than
setStandardGroup, so if there is an existing configuration in the git-annex
branch, it's not overwritten.

To handle pre-existing ssh remotes (including gcrypt), a second level is
needed, because before syncing with the remote, it's configuration won't be
available locally. (And syncing could take a long time.) So, in this case,
keep track of whether the remote is being created or enabled, and only set
configs when creating it.

This commit was sponsored by Anders Lannerback.

Assistant/WebApp/Configurators/Local.hs

@@ -339,7 +339,7 @@ getFinishAddDriveR drive = go
 				(Git.Config.boolConfig True)
 		(u, r) <- a isnew
 		when isnew $
-			liftAnnex $ setStandardGroup u TransferGroup
+			liftAnnex $ defaultStandardGroup u TransferGroup
 		liftAssistant $ immediateSyncRemote r
 		redirect $ EditNewRepositoryR u
   	mountpoint = T.unpack (mountPoint drive)
@@ -471,7 +471,7 @@ initRepo' :: Maybe String -> Maybe StandardGroup -> Annex ()
 initRepo' desc mgroup = unlessM isInitialized $ do
 	initialize desc
 	u <- getUUID
-	maybe noop (setStandardGroup u) mgroup
+	maybe noop (defaultStandardGroup u) mgroup
 	{- Ensure branch gets committed right away so it is
 	 - available for merging immediately. -}
 	Annex.Branch.commit "update"

Assistant/WebApp/Configurators/Ssh.hs

@@ -61,6 +61,10 @@ data AuthMethod
 	| ExistingSshKey
 	deriving (Eq, Show)
 
+-- Is a repository a new one that's being created, or did it already exist
+-- and is just being added.
+data RepoStatus = NewRepo | ExistingRepo
+
 {- SshInput is only used for applicative form prompting, this converts
  - the result of such a form into a SshData. -}
 mkSshData :: SshInput -> SshData
@@ -425,9 +429,7 @@ getConfirmSshR sshdata u
 		m <- liftAnnex readRemoteLog
 		case M.lookup "type" =<< M.lookup u m of
 			Just "gcrypt" -> combineExistingGCrypt sshdata' u
-			-- This handles enabling git repositories
+			_ -> makeSshRepo ExistingRepo sshdata'
-			-- that already exist.
-			_ -> makeSshRepo sshdata'
 
 {- The user has confirmed they want to combine with a ssh repository,
  - which is not known to us. So it might be using gcrypt. -}
@@ -435,7 +437,7 @@ getCombineSshR :: SshData -> Handler Html
 getCombineSshR sshdata = prepSsh False sshdata $ \sshdata' ->
 	sshConfigurator $
 		checkExistingGCrypt sshdata' $
-			void $ liftH $ makeSshRepo sshdata'
+			void $ liftH $ makeSshRepo ExistingRepo sshdata'
 
 getRetrySshR :: SshData -> Handler ()
 getRetrySshR sshdata = do
@@ -444,10 +446,10 @@ getRetrySshR sshdata = do
 
 {- Making a new git repository. -}
 getMakeSshGitR :: SshData -> Handler Html
-getMakeSshGitR sshdata = prepSsh True sshdata makeSshRepo
+getMakeSshGitR sshdata = prepSsh True sshdata (makeSshRepo NewRepo)
 
 getMakeSshRsyncR :: SshData -> Handler Html
-getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) makeSshRepo
+getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) (makeSshRepo NewRepo)
 
 rsyncOnly :: SshData -> SshData
 rsyncOnly sshdata = sshdata { sshCapabilities = [RsyncCapable] }
@@ -456,7 +458,7 @@ getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html
 getMakeSshGCryptR sshdata NoRepoKey = whenGcryptInstalled $
 	withNewSecretKey $ getMakeSshGCryptR sshdata . RepoKey
 getMakeSshGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
-	prepSsh False sshdata $ makeGCryptRepo keyid
+	prepSsh False sshdata $ makeGCryptRepo NewRepo keyid
 	
 {- Detect if the user entered a location with an existing, known
  - gcrypt repository, and enable it. Otherwise, runs the action. -}
@@ -523,10 +525,10 @@ prepSsh' needsinit origsshdata sshdata keypair a = sshSetup (mkSshInput origsshd
 		]
 	rsynconly = onlyCapability origsshdata RsyncCapable
 
-makeSshRepo :: SshData -> Handler Html
+makeSshRepo :: RepoStatus -> SshData -> Handler Html
-makeSshRepo sshdata
+makeSshRepo rs sshdata
 	| onlyCapability sshdata RsyncCapable = setupCloudRemote TransferGroup Nothing mk
-	| otherwise = makeSshRepoConnection mk setup
+	| otherwise = makeSshRepoConnection rs mk setup
   where
 	mk = makeSshRemote sshdata
 	-- Record the location of the ssh remote in the remote log, so it
@@ -539,16 +541,19 @@ makeSshRepo sshdata
 			M.insert "name" (fromMaybe (Remote.name r) (M.lookup "name" c)) c
 		configSet (Remote.uuid r) c'
 
-makeSshRepoConnection :: Annex RemoteName -> (Remote -> Annex ()) -> Handler Html
+makeSshRepoConnection :: RepoStatus -> Annex RemoteName -> (Remote -> Annex ()) -> Handler Html
-makeSshRepoConnection mk setup = setupRemote postsetup TransferGroup Nothing mk
+makeSshRepoConnection rs mk setup = setupRemote postsetup mgroup Nothing mk
   where
+	mgroup = case rs of
+		NewRepo -> Just TransferGroup
+		ExistingRepo -> Nothing
 	postsetup r = do
 		liftAssistant $ sendRemoteControl RELOAD
 		liftAnnex $ setup r
 		redirect $ EditNewRepositoryR (Remote.uuid r)
 
-makeGCryptRepo :: KeyId -> SshData -> Handler Html
+makeGCryptRepo :: RepoStatus -> KeyId -> SshData -> Handler Html
-makeGCryptRepo keyid sshdata = makeSshRepoConnection mk (const noop)
+makeGCryptRepo rs keyid sshdata = makeSshRepoConnection rs mk (const noop)
   where
 	mk = makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid
 
@@ -591,21 +596,22 @@ postAddRsyncNetR = do
 				$(widgetFile "configurators/rsync.net/encrypt")
 
 getMakeRsyncNetSharedR :: SshData -> Handler Html
-getMakeRsyncNetSharedR = makeSshRepo . rsyncOnly
+getMakeRsyncNetSharedR = makeSshRepo NewRepo . rsyncOnly
 
-{- Make a gcrypt special remote on rsync.net. -}
+{- Make a new gcrypt special remote on rsync.net. -}
 getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
 getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $
 	withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey
 getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
-	sshSetup (mkSshInput sshdata) [sshhost, gitinit] Nothing $ makeGCryptRepo keyid sshdata
+	sshSetup (mkSshInput sshdata) [sshhost, gitinit] Nothing $
+		makeGCryptRepo NewRepo keyid sshdata
   where
 	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
 	gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)
 
 enableRsyncNet :: SshInput -> String -> Handler Html
 enableRsyncNet sshinput reponame = 
-	prepRsyncNet sshinput reponame $ makeSshRepo . rsyncOnly
+	prepRsyncNet sshinput reponame $ makeSshRepo ExistingRepo . rsyncOnly
 
 enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
 enableRsyncNetGCrypt sshinput reponame = 

Assistant/WebApp/MakeRemote.hs

@@ -31,13 +31,15 @@ import Utility.Yesod
  - This includes displaying the connectionNeeded nudge if appropariate.
  -}
 setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
-setupCloudRemote = setupRemote $ redirect . EditNewCloudRepositoryR . Remote.uuid
+setupCloudRemote = setupRemote postsetup . Just
+  where
+	postsetup = redirect . EditNewCloudRepositoryR . Remote.uuid
 
-setupRemote :: (Remote -> Handler a) -> StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
+setupRemote :: (Remote -> Handler a) -> Maybe StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
-setupRemote postsetup defaultgroup mcost getname = do
+setupRemote postsetup mgroup mcost getname = do
 	r <- liftAnnex $ addRemote getname
 	liftAnnex $ do
-		setStandardGroup (Remote.uuid r) defaultgroup
+		maybe noop (defaultStandardGroup (Remote.uuid r)) mgroup
 		maybe noop (Config.setRemoteCost (Remote.repo r)) mcost
 	liftAssistant $ syncRemote r
 	postsetup r

Logs/PreferredContent.hs

@@ -18,6 +18,7 @@ module Logs.PreferredContent (
 	groupPreferredContentMapRaw,
 	checkPreferredContentExpression,
 	setStandardGroup,
+	defaultStandardGroup,
 	preferredRequiredMapsLoad,
 ) where
 
@@ -133,10 +134,20 @@ checkPreferredContentExpression expr = case parsedToMatcher tokens of
 	tokens = exprParser matchAll matchAll emptyGroupMap M.empty Nothing expr
 
 {- Puts a UUID in a standard group, and sets its preferred content to use
- - the standard expression for that group, unless something is already set. -}
+ - the standard expression for that group (unless preferred content is
+ - already set). -}
 setStandardGroup :: UUID -> StandardGroup -> Annex ()
 setStandardGroup u g = do
 	groupSet u $ S.singleton $ fromStandardGroup g
-	m <- preferredContentMap
+	unlessM (isJust . M.lookup u <$> preferredContentMap) $
-	unless (isJust $ M.lookup u m) $
 		preferredContentSet u "standard"
+
+{- Avoids overwriting the UUID's standard group or preferred content
+ - when it's already been configured. -}
+defaultStandardGroup :: UUID -> StandardGroup -> Annex ()
+defaultStandardGroup u g = 
+	unlessM (hasgroup <||> haspc) $
+		setStandardGroup u g
+  where
+	hasgroup = not . S.null <$> lookupGroups u
+	haspc = isJust . M.lookup u <$> preferredContentMap

debian/changelog

@@ -4,8 +4,7 @@ git-annex (5.20140530) UNRELEASED; urgency=medium
     group and preferred content to be set in the current repository,
     even when not combining.
   * webapp: Avoid stomping on existing group and preferred content settings
-    when adding a local repository (or removable drive repository) that
+    when enabling or combining with an already existing remote.
-    already exists.
 
  -- Joey Hess <joeyh@debian.org>  Thu, 29 May 2014 20:10:59 -0400
 

doc/bugs/adding_existing_repo_as_remote_in_webapp_may_reset_its_group.mdwn

@@ -9,3 +9,8 @@ may have the same problems. Didn't check yet.
 
 > Fixed for local repos and repos on removable drives. Still open for
 > ssh remotes (incl gcrypt). --[[Joey]]
+
+>> Fixed for ssh (including gcrypt) too.
+>>
+>> Also affected enabling existing special remotes, like webdav; that's
+>> also fixed. [[done]] --[[Joey]]