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.
This commit is contained in:
Joey Hess
parent
e344da5ea2
commit
9fc1448947
6 changed files with 65 additions and 41 deletions
|
|
@ -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 name location = makeRemote name location $
|
||||
const $ makeSpecialRemote name Rsync.remote config
|
||||
makeRsyncRemote :: RemoteName -> String -> Annex String
|
||||
makeRsyncRemote name location = makeRemote name location $ const $ void $
|
||||
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.
|
||||
-
|
||||
- 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. -}
|
||||
makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex ()
|
||||
makeSpecialRemote name remotetype config =
|
||||
go =<< Command.InitRemote.findExisting name
|
||||
type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName
|
||||
|
||||
{- Inits a new special remote. The name is used as a suggestion, but
|
||||
- will be changed if there is already a special remote with that name. -}
|
||||
initSpecialRemote :: SpecialRemoteMaker
|
||||
initSpecialRemote name remotetype config = go 0
|
||||
where
|
||||
go Nothing = go =<< Just <$> Command.InitRemote.generateNew name
|
||||
go (Just (u, c)) = do
|
||||
c' <- R.setup remotetype u $
|
||||
M.insert "highRandomQuality" "false" $ M.union config c
|
||||
describeUUID u name
|
||||
configSet u c'
|
||||
go :: Int -> Annex RemoteName
|
||||
go n = do
|
||||
let fullname = if n == 0 then name else name ++ show n
|
||||
r <- Command.InitRemote.findExisting fullname
|
||||
case r of
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 remotetype (AWSCreds ak sk) name setup config = do
|
||||
remotename <- liftAnnex $ fromRepo $ uniqueRemoteName name 0
|
||||
makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
|
||||
makeAWSRemote maker remotetype (AWSCreds ak sk) name setup config = do
|
||||
liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
|
||||
r <- liftAnnex $ addRemote $ do
|
||||
makeSpecialRemote hostname remotetype config
|
||||
return remotename
|
||||
maker hostname remotetype config
|
||||
setup r
|
||||
liftAssistant $ syncRemote r
|
||||
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 name creds setup config = do
|
||||
remotename <- liftAnnex $ fromRepo $ uniqueRemoteName name 0
|
||||
makeWebDavRemote :: SpecialRemoteMaker -> String -> CredPair -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
|
||||
makeWebDavRemote maker name creds setup config = do
|
||||
liftIO $ WebDAV.setCredsEnv creds
|
||||
r <- liftAnnex $ addRemote $ do
|
||||
makeSpecialRemote name WebDAV.remote config
|
||||
return remotename
|
||||
r <- liftAnnex $ addRemote $ maker name WebDAV.remote config
|
||||
setup r
|
||||
liftAssistant $ syncRemote r
|
||||
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
||||
|
|
|
|||
3
debian/changelog
vendored
3
debian/changelog
vendored
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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]]
|
||||
|
|
|
|||
Loading…
Reference in a new issue