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:
parent
b2fae4b78f
commit
fa24ba2520
24 changed files with 96 additions and 92 deletions
|
@ -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'
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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. -}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
47
Creds.hs
47
Creds.hs
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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=") $
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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="
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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=") $
|
||||||
|
|
12
Remote/S3.hs
12
Remote/S3.hs
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
12
Types/Creds.hs
Normal 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
|
|
@ -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
1
debian/changelog
vendored
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue