webapp: Differentiate between creating a new S3/Glacier/WebDav remote, and initializing an existing remote. When creating a new remote, avoid conflicts with other existing (or deleted) remotes with the same name.

Assistant/MakeRemote.hs

@@ -27,6 +27,8 @@ import Creds
 import qualified Data.Text as T
 import qualified Data.Map as M
 
+type RemoteName = String
+
 {- Sets up and begins syncing with a new ssh or rsync remote. -}
 makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote
 makeSshRemote forcersync sshdata mcost = do
@@ -53,7 +55,7 @@ makeSshRemote forcersync sshdata mcost = do
 			| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
 	
 {- Runs an action that returns a name of the remote, and finishes adding it. -}
-addRemote :: Annex String -> Annex Remote
+addRemote :: Annex RemoteName -> Annex Remote
 addRemote a = do
 	name <- a
 	void remoteListRefresh
@@ -61,36 +63,58 @@ addRemote a = do
 		=<< Remote.byName (Just name)
 
 {- Inits a rsync special remote, and returns its name. -}
-makeRsyncRemote :: String -> String -> Annex String
+makeRsyncRemote :: RemoteName -> String -> Annex String
-makeRsyncRemote name location = makeRemote name location $
+makeRsyncRemote name location = makeRemote name location $ const $ void $
-	const $ makeSpecialRemote name Rsync.remote config
+	go =<< Command.InitRemote.findExisting name
   where
+  	go Nothing = setupSpecialRemote name Rsync.remote config
+		=<< Command.InitRemote.generateNew name
+	go (Just v) = setupSpecialRemote name Rsync.remote config v
 	config = M.fromList
 		[ ("encryption", "shared")
 		, ("rsyncurl", location)
 		, ("type", "rsync")
 		]
 
-{- Inits a new special remote, or enables an existing one.
+type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName
- -
+
- - Currently, only 'weak' ciphers can be generated from the assistant,
+{- Inits a new special remote. The name is used as a suggestion, but
- - because otherwise GnuPG may block once the entropy pool is drained,
+ - will be changed if there is already a special remote with that name. -}
- - and as of now there's no way to tell the user to perform IO actions
+initSpecialRemote :: SpecialRemoteMaker
- - to refill the pool. -}
+initSpecialRemote name remotetype config = go 0
-makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex ()
-makeSpecialRemote name remotetype config =
-	go =<< Command.InitRemote.findExisting name
   where
-  	go Nothing = go =<< Just <$> Command.InitRemote.generateNew name
+	go :: Int -> Annex RemoteName
-	go (Just (u, c)) = do
+	go n = do
-		c' <- R.setup remotetype u $
+		let fullname = if n == 0  then name else name ++ show n
-			M.insert "highRandomQuality" "false" $ M.union config c
+		r <- Command.InitRemote.findExisting fullname
-		describeUUID u name
+		case r of
-		configSet u c'
+			Nothing -> setupSpecialRemote fullname remotetype config
+				=<< Command.InitRemote.generateNew fullname
+			Just _ -> go (n + 1)
+
+{- Enables an existing special remote. -}
+enableSpecialRemote :: SpecialRemoteMaker
+enableSpecialRemote name remotetype config = do
+	r <- Command.InitRemote.findExisting name
+	case r of
+		Nothing -> error $ "Cannot find a special remote named " ++ name
+		Just v -> setupSpecialRemote name remotetype config v
+
+setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> (UUID, R.RemoteConfig) -> Annex RemoteName
+setupSpecialRemote name remotetype config (u, c) = do
+	{- Currently, only 'weak' ciphers can be generated from the
+	 - assistant, because otherwise GnuPG may block once the entropy
+	 - pool is drained, and as of now there's no way to tell the user
+	 - to perform IO actions to refill the pool. -}
+	c' <- R.setup remotetype u $
+		M.insert "highRandomQuality" "false" $ M.union config c
+	describeUUID u name
+	configSet u c'
+	return name
 
 {- Returns the name of the git remote it created. If there's already a
  - remote at the location, returns its name. -}
-makeGitRemote :: String -> String -> Annex String
+makeGitRemote :: String -> String -> Annex RemoteName
 makeGitRemote basename location = makeRemote basename location $ \name ->
 	void $ inRepo $ Git.Command.runBool
 		[Param "remote", Param "add", Param name, Param location]
@@ -99,7 +123,7 @@ makeGitRemote basename location = makeRemote basename location $ \name ->
  - action, which is passed the name of the remote to make.
  -
  - Returns the name of the remote. -}
-makeRemote :: String -> String -> (String -> Annex ()) -> Annex String
+makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
 makeRemote basename location a = do
 	g <- gitRepo
 	if not (any samelocation $ Git.remotes g)
@@ -116,7 +140,7 @@ makeRemote basename location a = do
  - necessary.
  -
  - Ensures that the returned name is a legal git remote name. -}
-uniqueRemoteName :: String -> Int -> Git.Repo -> String
+uniqueRemoteName :: String -> Int -> Git.Repo -> RemoteName
 uniqueRemoteName basename n r
 	| null namecollision = name
 	| otherwise = uniqueRemoteName legalbasename (succ n) r

Assistant/WebApp/Configurators/AWS.hs

@@ -124,7 +124,7 @@ postAddS3R = awsConfigurator $ do
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
-			makeAWSRemote S3.remote (extractCreds input) name setgroup $ M.fromList
+			makeAWSRemote initSpecialRemote S3.remote (extractCreds input) name setgroup $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("type", "S3")
 				, ("datacenter", T.unpack $ datacenter input)
@@ -150,7 +150,7 @@ postAddGlacierR = glacierConfigurator $ do
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
-			makeAWSRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
+			makeAWSRemote initSpecialRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("type", "glacier")
 				, ("datacenter", T.unpack $ datacenter input)
@@ -198,7 +198,7 @@ enableAWSRemote remotetype uuid = do
 			m <- liftAnnex readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m
-			makeAWSRemote remotetype creds name (const noop) M.empty
+			makeAWSRemote enableSpecialRemote remotetype creds name (const noop) M.empty
 		_ -> do
 			description <- liftAnnex $
 				T.pack <$> Remote.prettyUUID uuid
@@ -207,13 +207,11 @@ enableAWSRemote remotetype uuid = do
 enableAWSRemote _ _ = error "S3 not supported by this build"
 #endif
 
-makeAWSRemote :: RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
+makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
-makeAWSRemote remotetype (AWSCreds ak sk) name setup config = do
+makeAWSRemote maker remotetype (AWSCreds ak sk) name setup config = do
-	remotename <- liftAnnex $ fromRepo $ uniqueRemoteName name 0
 	liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
 	r <- liftAnnex $ addRemote $ do
-		makeSpecialRemote hostname remotetype config
+		maker hostname remotetype config
-		return remotename
 	setup r
 	liftAssistant $ syncRemote r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

Assistant/WebApp/Configurators/IA.hs

@@ -130,7 +130,7 @@ postAddIAR = iaConfigurator $ do
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = escapeBucket $ T.unpack $ itemName input
-			AWS.makeAWSRemote S3.remote (extractCreds input) name setgroup $
+			AWS.makeAWSRemote initSpecialRemote S3.remote (extractCreds input) name setgroup $
 				M.fromList $ catMaybes
 					[ Just $ configureEncryption NoEncryption
 					, Just ("type", "S3")
@@ -174,7 +174,7 @@ enableIARemote uuid = do
 			m <- liftAnnex readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m
-			AWS.makeAWSRemote S3.remote creds name (const noop) M.empty
+			AWS.makeAWSRemote enableSpecialRemote S3.remote creds name (const noop) M.empty
 		_ -> do
 			description <- liftAnnex $
 				T.pack <$> Remote.prettyUUID uuid

Assistant/WebApp/Configurators/WebDAV.hs

@@ -69,7 +69,7 @@ postAddBoxComR = boxConfigurator $ do
 		runFormPost $ renderBootstrap $ boxComAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ 
-			makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList
+			makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) setgroup $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("embedcreds", if embedCreds input then "yes" else "no")
 				, ("type", "webdav")
@@ -100,7 +100,7 @@ postEnableWebDAVR uuid = do
 		getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
 	case mcreds of
 		Just creds -> webDAVConfigurator $ liftH $
-			makeWebDavRemote name creds (const noop) M.empty
+			makeWebDavRemote enableSpecialRemote name creds (const noop) M.empty
 		Nothing
 			| "box.com/" `isInfixOf` url ->
 				boxConfigurator $ showform name url
@@ -115,7 +115,7 @@ postEnableWebDAVR uuid = do
 			runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds
 		case result of
 			FormSuccess input -> liftH $
-				makeWebDavRemote name (toCredPair input) (const noop) M.empty
+				makeWebDavRemote enableSpecialRemote name (toCredPair input) (const noop) M.empty
 			_ -> do
 				description <- liftAnnex $
 					T.pack <$> Remote.prettyUUID uuid
@@ -125,13 +125,10 @@ postEnableWebDAVR _ = error "WebDAV not supported by this build"
 #endif
 
 #ifdef WITH_WEBDAV
-makeWebDavRemote :: String -> CredPair -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
+makeWebDavRemote :: SpecialRemoteMaker -> String -> CredPair -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
-makeWebDavRemote name creds setup config = do
+makeWebDavRemote maker name creds setup config = do
-	remotename <- liftAnnex $ fromRepo $ uniqueRemoteName name 0
 	liftIO $ WebDAV.setCredsEnv creds
-	r <- liftAnnex $ addRemote $ do
+	r <- liftAnnex $ addRemote $ maker name WebDAV.remote config
-		makeSpecialRemote name WebDAV.remote config
-		return remotename
 	setup r
 	liftAssistant $ syncRemote r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

debian/changelog

@@ -22,6 +22,9 @@ git-annex (4.20130710) UNRELEASED; urgency=low
     if hinotify cannot process a directory (but can't detect changes in it)
   * directory special remote: Fix checking that there is enough disk space
     to hold an object, was broken when using encryption.
+  * webapp: Differentiate between creating a new S3/Glacier/WebDav remote,
+    and initializing an existing remote. When creating a new remote, avoid
+    conflicts with other existing (or deleted) remotes with the same name.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 09 Jul 2013 19:17:13 -0400
 

doc/bugs/Internal_Server_Error_when_adding_an_uncrypted_box.com_repo_after_deleted_an_encrypted_one..mdwn

@@ -24,3 +24,5 @@ after deleted my encrypted box.com remote and tried to add the same box.com acco
 
 # End of transcript or log.
 """]]
+
+> fixed this [[done]] --[[Joey]]