diff options
-rw-r--r-- | Assistant/MakeRemote.hs | 23 | ||||
-rw-r--r-- | Command/EnableRemote.hs | 2 | ||||
-rw-r--r-- | Command/InitRemote.hs | 2 | ||||
-rw-r--r-- | Creds.hs | 47 | ||||
-rw-r--r-- | Remote/Bup.hs | 5 | ||||
-rw-r--r-- | Remote/Directory.hs | 5 | ||||
-rw-r--r-- | Remote/External.hs | 8 | ||||
-rw-r--r-- | Remote/GCrypt.hs | 5 | ||||
-rw-r--r-- | Remote/Glacier.hs | 12 | ||||
-rw-r--r-- | Remote/Helper/AWS.hs | 3 | ||||
-rw-r--r-- | Remote/Hook.hs | 5 | ||||
-rw-r--r-- | Remote/Rsync.hs | 5 | ||||
-rw-r--r-- | Remote/S3.hs | 12 | ||||
-rw-r--r-- | Remote/Tahoe.hs | 5 | ||||
-rw-r--r-- | Remote/WebDAV.hs | 13 | ||||
-rw-r--r-- | Types/Creds.hs | 12 | ||||
-rw-r--r-- | Types/Remote.hs | 3 | ||||
-rw-r--r-- | debian/changelog | 1 | ||||
-rw-r--r-- | doc/todo/windows_support.mdwn | 1 |
19 files changed, 87 insertions, 82 deletions
diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index bf316e49d..349d4af9c 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -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' diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index a00046d5a..42ab43374 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -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 diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 79fbcf39c..dc54023cc 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -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 @@ -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) diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 62af704b2..4e79eca42 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -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 diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 3cbde7aaf..afa2296ec 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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=") $ diff --git a/Remote/External.hs b/Remote/External.hs index 96d665c26..50a0767ea 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 03747314c..ed8fbf480 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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=" diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 3bb92e2f6..77b16cd65 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -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) diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs index 1d80ff1b4..0687a5ee1 100644 --- a/Remote/Helper/AWS.hs +++ b/Remote/Helper/AWS.hs @@ -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) diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 1fcb2912f..3735c228c 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -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 diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index e27286d5a..b543387c3 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -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=") $ diff --git a/Remote/S3.hs b/Remote/S3.hs index 081f7c176..b217892e7 100644 --- a/Remote/S3.hs +++ b/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 diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 6b0113ac3..56a17eb62 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -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 diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 7243e359d..6ce83470b 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -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 diff --git a/Types/Creds.hs b/Types/Creds.hs new file mode 100644 index 000000000..cb312f66d --- /dev/null +++ b/Types/Creds.hs @@ -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 diff --git a/Types/Remote.hs b/Types/Remote.hs index 2a02d99aa..2ddb68dfb 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -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 diff --git a/debian/changelog b/debian/changelog index 0e7103744..e32f0c68f 100644 --- a/debian/changelog +++ b/debian/changelog @@ -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 diff --git a/doc/todo/windows_support.mdwn b/doc/todo/windows_support.mdwn index 4e0ef74f7..f68076f9a 100644 --- a/doc/todo/windows_support.mdwn +++ b/doc/todo/windows_support.mdwn @@ -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 |