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 $ makeRsyncRemote name location = makeRemote name location $ const $ void $
go =<< Command.InitRemote.findExisting name go =<< Command.InitRemote.findExisting name
where where
go Nothing = setupSpecialRemote name Rsync.remote config go Nothing = setupSpecialRemote name Rsync.remote config Nothing
(Nothing, Command.InitRemote.newConfig name) (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 config = M.fromList
[ ("encryption", "shared") [ ("encryption", "shared")
, ("rsyncurl", location) , ("rsyncurl", location)
@ -60,44 +61,44 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $
{- Inits a gcrypt special remote, and returns its name. -} {- Inits a gcrypt special remote, and returns its name. -}
makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName
makeGCryptRemote remotename location keyid = makeGCryptRemote remotename location keyid =
initSpecialRemote remotename GCrypt.remote $ M.fromList initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList
[ ("type", "gcrypt") [ ("type", "gcrypt")
, ("gitrepo", location) , ("gitrepo", location)
, configureEncryption HybridEncryption , configureEncryption HybridEncryption
, ("keyid", keyid) , ("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 {- 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. -} - will be changed if there is already a special remote with that name. -}
initSpecialRemote :: SpecialRemoteMaker initSpecialRemote :: SpecialRemoteMaker
initSpecialRemote name remotetype config = go 0 initSpecialRemote name remotetype mcreds config = go 0
where where
go :: Int -> Annex RemoteName go :: Int -> Annex RemoteName
go n = do go n = do
let fullname = if n == 0 then name else name ++ show n let fullname = if n == 0 then name else name ++ show n
r <- Command.InitRemote.findExisting fullname r <- Command.InitRemote.findExisting fullname
case r of case r of
Nothing -> setupSpecialRemote fullname remotetype config Nothing -> setupSpecialRemote fullname remotetype config mcreds
(Nothing, Command.InitRemote.newConfig fullname) (Nothing, Command.InitRemote.newConfig fullname)
Just _ -> go (n + 1) Just _ -> go (n + 1)
{- Enables an existing special remote. -} {- Enables an existing special remote. -}
enableSpecialRemote :: SpecialRemoteMaker enableSpecialRemote :: SpecialRemoteMaker
enableSpecialRemote name remotetype config = do enableSpecialRemote name remotetype mcreds config = do
r <- Command.InitRemote.findExisting name r <- Command.InitRemote.findExisting name
case r of case r of
Nothing -> error $ "Cannot find a special remote named " ++ name 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 :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote name remotetype config (mu, c) = do setupSpecialRemote name remotetype config mcreds (mu, c) = do
{- Currently, only 'weak' ciphers can be generated from the {- Currently, only 'weak' ciphers can be generated from the
- assistant, because otherwise GnuPG may block once the entropy - assistant, because otherwise GnuPG may block once the entropy
- pool is drained, and as of now there's no way to tell the user - pool is drained, and as of now there's no way to tell the user
- to perform IO actions to refill the pool. -} - 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 M.insert "highRandomQuality" "false" $ M.union config c
describeUUID u name describeUUID u name
configSet u c' configSet u c'

View file

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

View file

@ -314,7 +314,7 @@ getFinishAddDriveR drive = go
remotename' <- liftAnnex $ getGCryptRemoteName u dir remotename' <- liftAnnex $ getGCryptRemoteName u dir
makewith $ const $ do makewith $ const $ do
r <- liftAnnex $ addRemote $ r <- liftAnnex $ addRemote $
enableSpecialRemote remotename' GCrypt.remote $ M.fromList enableSpecialRemote remotename' GCrypt.remote Nothing $ M.fromList
[("gitrepo", dir)] [("gitrepo", dir)]
return (u, r) return (u, r)
{- Making a new unencrypted repo, or combining with an existing one. -} {- 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 -> RemoteName -> Handler Html
enableGCrypt sshdata reponame = enableGCrypt sshdata reponame =
setupCloudRemote TransferGroup Nothing $ setupCloudRemote TransferGroup Nothing $
enableSpecialRemote reponame GCrypt.remote $ M.fromList enableSpecialRemote reponame GCrypt.remote Nothing $ M.fromList
[("gitrepo", genSshUrl sshdata)] [("gitrepo", genSshUrl sshdata)]
{- Combining with a gcrypt repository that may not be {- 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 #ifdef WITH_WEBDAV
makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler () makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()
makeWebDavRemote maker name creds config = do makeWebDavRemote maker name creds config =
liftIO $ WebDAV.setCredsEnv creds
setupCloudRemote TransferGroup Nothing $ setupCloudRemote TransferGroup Nothing $
maker name WebDAV.remote config maker name WebDAV.remote (Just creds) config
{- Only returns creds previously used for the same hostname. -} {- Only returns creds previously used for the same hostname. -}
previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair) 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 setting it up, then starts syncing with it,
- and finishes by displaying the page to edit it. -} - and finishes by displaying the page to edit it. -}
setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
setupCloudRemote defaultgroup mcost maker = do setupCloudRemote defaultgroup mcost name = do
r <- liftAnnex $ addRemote maker r <- liftAnnex $ addRemote name
liftAnnex $ do liftAnnex $ do
setStandardGroup (Remote.uuid r) defaultgroup setStandardGroup (Remote.uuid r) defaultgroup
maybe noop (Config.setRemoteCost (Remote.repo r)) mcost maybe noop (Config.setRemoteCost (Remote.repo r)) mcost

View file

@ -47,7 +47,7 @@ unknownNameError prefix = do
perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
perform t u c = do 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' next $ cleanup u' c'
cleanup :: UUID -> R.RemoteConfig -> CommandCleanup 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 :: RemoteType -> String -> R.RemoteConfig -> CommandPerform
perform t name c = do 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' next $ cleanup u name c'
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup

View file

@ -1,29 +1,34 @@
{- Credentials storage {- 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. - Licensed under the GNU GPL version 3 or higher.
-} -}
{-# LANGUAGE CPP #-} module Creds (
module Types.Creds,
module Creds where CredPairStorage(..),
setRemoteCredPair,
getRemoteCredPairFor,
getRemoteCredPair,
getEnvCredPair,
writeCacheCreds,
readCacheCreds,
) where
import Common.Annex import Common.Annex
import Types.Creds
import Annex.Perms import Annex.Perms
import Utility.FileMode import Utility.FileMode
import Crypto import Crypto
import Types.Remote (RemoteConfig, RemoteConfigKey) import Types.Remote (RemoteConfig, RemoteConfigKey)
import Remote.Helper.Encryptable (remoteCipher, embedCreds) 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.ByteString.Lazy.Char8 as L
import qualified Data.Map as M import qualified Data.Map as M
import Utility.Base64 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 {- A CredPair can be stored in a file, or in the environment, or perhaps
- in a remote's configuration. -} - in a remote's configuration. -}
data CredPairStorage = CredPairStorage data CredPairStorage = CredPairStorage
@ -33,14 +38,13 @@ data CredPairStorage = CredPairStorage
} }
{- Stores creds in a remote's configuration, if the remote allows {- Stores creds in a remote's configuration, if the remote allows
- that. Otherwise, caches them locally. -} - that. Otherwise, caches them locally.
setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex RemoteConfig - The creds are found in storage if not provided. -}
setRemoteCredPair c storage = setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
maybe (return c) (setRemoteCredPair' c storage) setRemoteCredPair c storage Nothing =
maybe (return c) (setRemoteCredPair c storage . Just)
=<< getRemoteCredPair c storage =<< getRemoteCredPair c storage
setRemoteCredPair c storage (Just creds)
setRemoteCredPair' :: RemoteConfig -> CredPairStorage -> CredPair -> Annex RemoteConfig
setRemoteCredPair' c storage creds
| embedCreds c = case credPairRemoteKey storage of | embedCreds c = case credPairRemoteKey storage of
Nothing -> localcache Nothing -> localcache
Just key -> storeconfig key =<< remoteCipher c Just key -> storeconfig key =<< remoteCipher c
@ -105,19 +109,6 @@ getEnvCredPair storage = liftM2 (,)
where where
(uenv, penv) = credPairEnvironment storage (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 -> CredPairStorage -> Annex ()
writeCacheCredPair credpair storage = writeCacheCredPair credpair storage =
writeCacheCreds (encodeCredPair credpair) (credPairFile storage) writeCacheCreds (encodeCredPair credpair) (credPairFile storage)

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -73,12 +73,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
remotetype = remote remotetype = remote
} }
s3Setup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup mu c = do s3Setup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
s3Setup' u c s3Setup' u mcreds c
s3Setup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) s3Setup' :: UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup' u c = if isIA c then archiveorg else defaulthost s3Setup' u mcreds 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,7 +92,7 @@ s3Setup' u 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) c' <- setRemoteCredPair fullconfig (AWS.creds u) mcreds
return (c', u) return (c', u)
defaulthost = do defaulthost = do

View file

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

View file

@ -1,13 +1,13 @@
{- WebDAV remotes. {- 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. - Licensed under the GNU GPL version 3 or higher.
-} -}
{-# LANGUAGE ScopedTypeVariables, CPP #-} {-# LANGUAGE ScopedTypeVariables, CPP #-}
module Remote.WebDAV (remote, davCreds, setCredsEnv, configUrl) where module Remote.WebDAV (remote, davCreds, configUrl) where
import Network.Protocol.HTTP.DAV import Network.Protocol.HTTP.DAV
import qualified Data.Map as M import qualified Data.Map as M
@ -76,8 +76,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
remotetype = remote remotetype = remote
} }
webdavSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
webdavSetup mu c = do webdavSetup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
let url = fromMaybe (error "Specify url=") $ let url = fromMaybe (error "Specify url=") $
M.lookup "url" c M.lookup "url" c
@ -85,7 +85,7 @@ webdavSetup mu c = do
creds <- getCreds c' u creds <- getCreds c' u
testDav url creds testDav url creds
gitConfigSpecialRemote u c' "webdav" "true" gitConfigSpecialRemote u c' "webdav" "true"
c'' <- setRemoteCredPair c' (davCreds u) c'' <- setRemoteCredPair c' (davCreds u) mcreds
return (c'', u) return (c'', u)
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
@ -354,6 +354,3 @@ davCreds u = CredPairStorage
, credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD") , credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
, credPairRemoteKey = Just "davcreds" , 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.UUID
import Types.GitConfig import Types.GitConfig
import Types.Availability import Types.Availability
import Types.Creds
import Config.Cost import Config.Cost
import Utility.Metered import Utility.Metered
import Git.Types import Git.Types
@ -41,7 +42,7 @@ data RemoteTypeA a = RemoteType {
-- generates a remote of this type -- generates a remote of this type
generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)), generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)),
-- initializes or changes a remote -- 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 instance Eq (RemoteTypeA a) where

1
debian/changelog vendored
View file

@ -1,6 +1,7 @@
git-annex (5.20140211) UNRELEASED; urgency=medium git-annex (5.20140211) UNRELEASED; urgency=medium
* Add progress display for transfers to/from external special remotes. * 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 -- 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 Error: `could not lock config file /annex/.git/config: No such file or
directory` -- seems to be a drive path problem? directory` -- seems to be a drive path problem?
* Local pairing seems to fail, after acking on Linux box, it stalls. * 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 * rsync.net setup failed. Seems to have generated a hostname including
the directory somehow. the directory somehow.
* gcrypt is not ported to windows (and as a shell script, may need * gcrypt is not ported to windows (and as a shell script, may need