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

plumb creds from webapp to initremote

Browse source 
Avoids abusing setting environment variables, which was always a hack
and won't work on windows.
This commit is contained in:
Joey Hess 2014-02-11 14:06:50 -04:00
parent b2fae4b78f
commit fa24ba2520
24 changed files with 96 additions and 92 deletions
Download patch file Download diff file Expand all files Collapse all files

5
Remote/Bup.hs
View file

@ -15,6 +15,7 @@ import Data.ByteString.Lazy.UTF8 (fromString)
import Common.Annex
import Types.Remote
import Types.Key
import Types.Creds
import qualified Git
import qualified Git.Command
import qualified Git.Config
@ -82,8 +83,8 @@ gen r u c gc = do
where
buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
bupSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
bupSetup mu c = do
bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
bupSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane

5
Remote/Directory.hs
View file

@ -16,6 +16,7 @@ import Data.Int
import Common.Annex
import Types.Remote
import Types.Creds
import qualified Git
import Config.Cost
import Config
@ -67,8 +68,8 @@ gen r u c gc = do
where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
directorySetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
directorySetup mu c = do
directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
directorySetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let dir = fromMaybe (error "Specify directory=") $

8
Remote/External.hs
View file

@ -73,8 +73,8 @@ gen r u c gc = do
where
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
externalSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
externalSetup mu c = do
externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
externalSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
let externaltype = fromMaybe (error "Specify externaltype=") $
M.lookup "externaltype" c
@ -225,8 +225,8 @@ handleRequest' lck external req mp responsehandler
send $ VALUE value
handleRemoteRequest (SETCREDS setting login password) = do
c <- liftIO $ atomically $ readTMVar $ externalConfig external
c' <- setRemoteCredPair' c (credstorage setting)
(login, password)
c' <- setRemoteCredPair c (credstorage setting) $
Just (login, password)
void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
handleRemoteRequest (GETCREDS setting) = do
c <- liftIO $ atomically $ readTMVar $ externalConfig external

5
Remote/GCrypt.hs
View file

@ -21,6 +21,7 @@ import Common.Annex
import Types.Remote
import Types.GitConfig
import Types.Crypto
import Types.Creds
import qualified Git
import qualified Git.Command
import qualified Git.Config
@ -149,8 +150,8 @@ noCrypto = error "cannot use gcrypt remote without encryption enabled"
unsupportedUrl :: Annex a
unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported"
gCryptSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
gCryptSetup mu c = go $ M.lookup "gitrepo" c
gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
where
remotename = fromJust (M.lookup "name" c)
go Nothing = error "Specify gitrepo="

12
Remote/Glacier.hs
View file

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

3
Remote/Helper/AWS.hs
View file

@ -22,9 +22,6 @@ creds u = CredPairStorage
, credPairRemoteKey = Just "s3creds"
}
setCredsEnv :: CredPair -> IO ()
setCredsEnv p = setEnvCredPair p $ creds undefined
data Service = S3 | Glacier
deriving (Eq)

5
Remote/Hook.hs
View file

@ -13,6 +13,7 @@ import qualified Data.Map as M
import Common.Annex
import Types.Remote
import Types.Key
import Types.Creds
import qualified Git
import Config
import Config.Cost
@ -65,8 +66,8 @@ gen r u c gc = do
where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
hookSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
hookSetup mu c = do
hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
hookSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
let hooktype = fromMaybe (error "Specify hooktype=") $
M.lookup "hooktype" c

5
Remote/Rsync.hs
View file

@ -42,6 +42,7 @@ import Utility.CopyFile
import Utility.Metered
import Annex.Perms
import Logs.Transfer
import Types.Creds
type RsyncUrl = String
@ -138,8 +139,8 @@ rsyncTransport gc rawurl
loginopt = maybe [] (\l -> ["-l",l]) login
fromNull as xs = if null xs then as else xs
rsyncSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
rsyncSetup mu c = do
rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
rsyncSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let url = fromMaybe (error "Specify rsyncurl=") $

12
Remote/S3.hs
View file

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

5
Remote/Tahoe.hs
View file

@ -29,6 +29,7 @@ import Control.Concurrent.STM
import Common.Annex
import Types.Remote
import Types.Creds
import qualified Git
import Config
import Config.Cost
@ -85,8 +86,8 @@ gen r u c gc = do
remotetype = remote
}
tahoeSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
tahoeSetup mu c = do
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
tahoeSetup mu _ c = do
furl <- fromMaybe (fromMaybe missingfurl $ M.lookup furlk c)
<$> liftIO (getEnv "TAHOE_FURL")
u <- maybe (liftIO genUUID) return mu

13
Remote/WebDAV.hs
View file

@ -1,13 +1,13 @@
{- WebDAV remotes.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE ScopedTypeVariables, CPP #-}
module Remote.WebDAV (remote, davCreds, setCredsEnv, configUrl) where
module Remote.WebDAV (remote, davCreds, configUrl) where
import Network.Protocol.HTTP.DAV
import qualified Data.Map as M
@ -76,8 +76,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
remotetype = remote
}
webdavSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
webdavSetup mu c = do
webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
webdavSetup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu
let url = fromMaybe (error "Specify url=") $
M.lookup "url" c
@ -85,7 +85,7 @@ webdavSetup mu c = do
creds <- getCreds c' u
testDav url creds
gitConfigSpecialRemote u c' "webdav" "true"
c'' <- setRemoteCredPair c' (davCreds u)
c'' <- setRemoteCredPair c' (davCreds u) mcreds
return (c'', u)
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
@ -354,6 +354,3 @@ davCreds u = CredPairStorage
, credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
, credPairRemoteKey = Just "davcreds"
}
setCredsEnv :: (String, String) -> IO ()
setCredsEnv creds = setEnvCredPair creds $ davCreds undefined