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 $
|
||||
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'
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
47
Creds.hs
47
Creds.hs
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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=") $
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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="
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
12
Remote/S3.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
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.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
1
debian/changelog
vendored
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue