plumb creds from webapp to initremote

Avoids abusing setting environment variables, which was always a hack
and won't work on windows.

11 files changed, 39 insertions, 39 deletions

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