mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

webapp: Fix creation of box.com, S3, and Glacier repositories, broken in 5.20140221.

Browse source
This commit is contained in:
Joey Hess 2014-02-24 15:14:44 -04:00
parent d70220e0f4
commit 45e7040142
4 changed files with 14 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
Remote/Glacier.hs
View file

@ -73,16 +73,16 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup mu mcreds c = do glacierSetup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
glacierSetup' (isJust mu) u mcreds c c' <- setRemoteCredPair c (AWS.creds u) mcreds
glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) glacierSetup' (isJust mu) u c'
glacierSetup' enabling u mcreds c = do glacierSetup' :: Bool -> UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup' enabling u c = do
c' <- encryptionSetup c c' <- encryptionSetup c
let fullconfig = c' `M.union` defaults let fullconfig = c' `M.union` defaults
unless enabling $ unless enabling $
genVault fullconfig u genVault fullconfig u
gitConfigSpecialRemote u fullconfig "glacier" "true" gitConfigSpecialRemote u fullconfig "glacier" "true"
c'' <- setRemoteCredPair fullconfig (AWS.creds u) mcreds return (c', u)
return (c'', u)
where where
remotename = fromJust (M.lookup "name" c) remotename = fromJust (M.lookup "name" c)
defvault = remotename ++ "-" ++ fromUUID u defvault = remotename ++ "-" ++ fromUUID u

10
Remote/S3.hs
View file

@ -76,9 +76,10 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup mu mcreds c = do s3Setup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
s3Setup' u mcreds c c' <- setRemoteCredPair c (AWS.creds u) mcreds
s3Setup' :: UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) s3Setup' u c'
s3Setup' u mcreds c = if isIA c then archiveorg else defaulthost s3Setup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup' u c = if isIA c then archiveorg else defaulthost
where where
remotename = fromJust (M.lookup "name" c) remotename = fromJust (M.lookup "name" c)
defbucket = remotename ++ "-" ++ fromUUID u defbucket = remotename ++ "-" ++ fromUUID u
@ -92,8 +93,7 @@ s3Setup' u mcreds c = if isIA c then archiveorg else defaulthost
use fullconfig = do use fullconfig = do
gitConfigSpecialRemote u fullconfig "s3" "true" gitConfigSpecialRemote u fullconfig "s3" "true"
c' <- setRemoteCredPair fullconfig (AWS.creds u) mcreds return (fullconfig, u)
return (c', u)
defaulthost = do defaulthost = do
c' <- encryptionSetup c c' <- encryptionSetup c

4
Remote/WebDAV.hs
View file

@ -82,10 +82,10 @@ webdavSetup mu mcreds c = do
let url = fromMaybe (error "Specify url=") $ let url = fromMaybe (error "Specify url=") $
M.lookup "url" c M.lookup "url" c
c' <- encryptionSetup c c' <- encryptionSetup c
creds <- getCreds c' u creds <- maybe (getCreds c' u) (return . Just) mcreds
testDav url creds testDav url creds
gitConfigSpecialRemote u c' "webdav" "true" gitConfigSpecialRemote u c' "webdav" "true"
c'' <- setRemoteCredPair c' (davCreds u) mcreds c'' <- setRemoteCredPair c' (davCreds u) creds
return (c'', u) return (c'', u)
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool

2
debian/changelog vendored
View file

@ -15,6 +15,8 @@ git-annex (5.20140222) UNRELEASED; urgency=medium
* metadata: Field names limited to alphanumerics and a few whitelisted * metadata: Field names limited to alphanumerics and a few whitelisted
punctuation characters to avoid issues with views, etc. punctuation characters to avoid issues with views, etc.
* metadata: Support --json * metadata: Support --json
* webapp: Fix creation of box.com and Amazon S3 and Glacier
repositories, broken in 5.20140221.
-- Joey Hess <joeyh@debian.org> Fri, 21 Feb 2014 13:03:04 -0400 -- Joey Hess <joeyh@debian.org> Fri, 21 Feb 2014 13:03:04 -0400