plumb creds from webapp to initremote

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

View file

@ -48,9 +48,10 @@ 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
go Nothing = setupSpecialRemote name Rsync.remote config Nothing
(Nothing, Command.InitRemote.newConfig name)
go (Just (u, c)) = setupSpecialRemote name Rsync.remote config (Just u, c)
go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
(Just u, c)
config = M.fromList
[ ("encryption", "shared")
, ("rsyncurl", location)
@ -60,44 +61,44 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $
{- Inits a gcrypt special remote, and returns its name. -}
makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName
makeGCryptRemote remotename location keyid =
initSpecialRemote remotename GCrypt.remote $ M.fromList
initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList
[ ("type", "gcrypt")
, ("gitrepo", location)
, configureEncryption HybridEncryption
, ("keyid", keyid)
]
type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName
type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> 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
initSpecialRemote name remotetype mcreds config = go 0
where
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
Nothing -> setupSpecialRemote fullname remotetype config mcreds
(Nothing, Command.InitRemote.newConfig fullname)
Just _ -> go (n + 1)
{- Enables an existing special remote. -}
enableSpecialRemote :: SpecialRemoteMaker
enableSpecialRemote name remotetype config = do
enableSpecialRemote name remotetype mcreds config = do
r <- Command.InitRemote.findExisting name
case r of
Nothing -> error $ "Cannot find a special remote named " ++ name
Just (u, c) -> setupSpecialRemote name remotetype config (Just u, c)
Just (u, c) -> setupSpecialRemote name remotetype config mcreds (Just u, c)
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote name remotetype config (mu, c) = do
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote name remotetype config mcreds (mu, 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', u) <- R.setup remotetype mu $
(c', u) <- R.setup remotetype mu mcreds $
M.insert "highRandomQuality" "false" $ M.union config c
describeUUID u name
configSet u c'

View file

@ -202,11 +202,11 @@ enableAWSRemote _ _ = error "S3 not supported by this build"
#endif
makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler ()
makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = do
liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config =
setupCloudRemote defaultgroup Nothing $
maker hostname remotetype config
maker hostname remotetype (Just creds) config
where
creds = (T.unpack ak, T.unpack sk)
{- AWS services use the remote name as the basis for a host
- name, so filter it to contain valid characters. -}
hostname = case filter isAlphaNum name of

View file

@ -314,7 +314,7 @@ getFinishAddDriveR drive = go
remotename' <- liftAnnex $ getGCryptRemoteName u dir
makewith $ const $ do
r <- liftAnnex $ addRemote $
enableSpecialRemote remotename' GCrypt.remote $ M.fromList
enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList
[("gitrepo", dir)]
return (u, r)
{- Making a new unencrypted repo, or combining with an existing one. -}

View file

@ -354,7 +354,7 @@ checkExistingGCrypt sshdata nope = checkGCryptRepoEncryption repourl nope nope $
enableGCrypt :: SshData -> RemoteName -> Handler Html
enableGCrypt sshdata reponame =
setupCloudRemote TransferGroup Nothing $
enableSpecialRemote reponame GCrypt.remote $ M.fromList
enableSpecialRemote reponame GCrypt.remote Nothing $ M.fromList
[("gitrepo", genSshUrl sshdata)]
{- Combining with a gcrypt repository that may not be

View file

@ -123,10 +123,9 @@ postEnableWebDAVR _ = error "WebDAV not supported by this build"
#ifdef WITH_WEBDAV
makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()
makeWebDavRemote maker name creds config = do
liftIO $ WebDAV.setCredsEnv creds
makeWebDavRemote maker name creds config =
setupCloudRemote TransferGroup Nothing $
maker name WebDAV.remote config
maker name WebDAV.remote (Just creds) config
{- Only returns creds previously used for the same hostname. -}
previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)

View file

@ -28,8 +28,8 @@ import Utility.Yesod
- and finishes setting it up, then starts syncing with it,
- and finishes by displaying the page to edit it. -}
setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
setupCloudRemote defaultgroup mcost maker = do
r <- liftAnnex $ addRemote maker
setupCloudRemote defaultgroup mcost name = do
r <- liftAnnex $ addRemote name
liftAnnex $ do
setStandardGroup (Remote.uuid r) defaultgroup
maybe noop (Config.setRemoteCost (Remote.repo r)) mcost

View file

@ -47,7 +47,7 @@ unknownNameError prefix = do
perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
perform t u c = do
(c', u') <- R.setup t (Just u) c
(c', u') <- R.setup t (Just u) Nothing c
next $ cleanup u' c'
cleanup :: UUID -> R.RemoteConfig -> CommandCleanup

View file

@ -44,7 +44,7 @@ start (name:ws) = ifM (isJust <$> findExisting name)
perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform
perform t name c = do
(c', u) <- R.setup t Nothing c
(c', u) <- R.setup t Nothing Nothing c
next $ cleanup u name c'
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup

View file

@ -1,29 +1,34 @@
{- Credentials storage
-
- 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 CPP #-}
module Creds where
module Creds (
module Types.Creds,
CredPairStorage(..),
setRemoteCredPair,
getRemoteCredPairFor,
getRemoteCredPair,
getEnvCredPair,
writeCacheCreds,
readCacheCreds,
) where
import Common.Annex
import Types.Creds
import Annex.Perms
import Utility.FileMode
import Crypto
import Types.Remote (RemoteConfig, RemoteConfigKey)
import Remote.Helper.Encryptable (remoteCipher, embedCreds)
import Utility.Env (setEnv, getEnv)
import Utility.Env (getEnv)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import Utility.Base64
type Creds = String -- can be any data
type CredPair = (String, String) -- login, password
{- A CredPair can be stored in a file, or in the environment, or perhaps
- in a remote's configuration. -}
data CredPairStorage = CredPairStorage
@ -33,14 +38,13 @@ data CredPairStorage = CredPairStorage
}
{- Stores creds in a remote's configuration, if the remote allows
- that. Otherwise, caches them locally. -}
setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex RemoteConfig
setRemoteCredPair c storage =
maybe (return c) (setRemoteCredPair' c storage)
- that. Otherwise, caches them locally.
- The creds are found in storage if not provided. -}
setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
setRemoteCredPair c storage Nothing =
maybe (return c) (setRemoteCredPair c storage . Just)
=<< getRemoteCredPair c storage
setRemoteCredPair' :: RemoteConfig -> CredPairStorage -> CredPair -> Annex RemoteConfig
setRemoteCredPair' c storage creds
setRemoteCredPair c storage (Just creds)
| embedCreds c = case credPairRemoteKey storage of
Nothing -> localcache
Just key -> storeconfig key =<< remoteCipher c
@ -105,19 +109,6 @@ getEnvCredPair storage = liftM2 (,)
where
(uenv, penv) = credPairEnvironment storage
{- Stores a CredPair in the environment. -}
setEnvCredPair :: CredPair -> CredPairStorage -> IO ()
#ifndef mingw32_HOST_OS
setEnvCredPair (l, p) storage = do
set uenv l
set penv p
where
(uenv, penv) = credPairEnvironment storage
set var val = void $ setEnv var val True
#else
setEnvCredPair _ _ = error "setEnvCredPair TODO"
#endif
writeCacheCredPair :: CredPair -> CredPairStorage -> Annex ()
writeCacheCredPair credpair storage =
writeCacheCreds (encodeCredPair credpair) (credPairFile storage)

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

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=") $

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

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="

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)

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)

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

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=") $

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

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

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

12
Types/Creds.hs Normal file
View file

@ -0,0 +1,12 @@
{- credentials
-
- Copyright 2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Types.Creds where
type Creds = String -- can be any data that contains credentials
type CredPair = (String, String) -- login, password

View file

@ -24,6 +24,7 @@ import Types.Key
import Types.UUID
import Types.GitConfig
import Types.Availability
import Types.Creds
import Config.Cost
import Utility.Metered
import Git.Types
@ -41,7 +42,7 @@ data RemoteTypeA a = RemoteType {
-- generates a remote of this type
generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)),
-- initializes or changes a remote
setup :: Maybe UUID -> RemoteConfig -> a (RemoteConfig, UUID)
setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> a (RemoteConfig, UUID)
}
instance Eq (RemoteTypeA a) where

1
debian/changelog vendored
View file

@ -1,6 +1,7 @@
git-annex (5.20140211) UNRELEASED; urgency=medium
* Add progress display for transfers to/from external special remotes.
* Windows webapp: Can set up box.com, Amazon S3 remotes.
-- Joey Hess <joeyh@debian.org> Mon, 10 Feb 2014 21:33:03 -0400

View file

@ -42,7 +42,6 @@ now! --[[Joey]]
Error: `could not lock config file /annex/.git/config: No such file or
directory` -- seems to be a drive path problem?
* Local pairing seems to fail, after acking on Linux box, it stalls.
* box.com and S3 repo setup fails: `setEnvCredPair TODO`
* rsync.net setup failed. Seems to have generated a hostname including
the directory somehow.
* gcrypt is not ported to windows (and as a shell script, may need