add credential storage support for external special remotes & update example

2 files changed, 34 insertions, 7 deletions

diff --git a/Remote/External.hs b/Remote/External.hs
index 251f423a6..2d777ff7f 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -22,6 +22,7 @@ import Config.Cost
 import Annex.Content
 import Annex.UUID
 import Annex.Exception
+import Creds
 
 import Control.Concurrent.STM
 import System.Process (std_in, std_out, std_err)
@@ -39,7 +40,7 @@ remote = RemoteType {
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
 gen r u c gc = do
-	external <- newExternal externaltype c
+	external <- newExternal externaltype u c
 	Annex.addCleanup (fromUUID u) $ stopExternal external
 	cst <- getCost external r gc
 	return $ Just $ encryptableRemote c
@@ -76,7 +77,7 @@ externalSetup mu c = do
 		M.lookup "externaltype" c
 	c' <- encryptionSetup c
 
-	external <- newExternal externaltype c'
+	external <- newExternal externaltype u c'
 	handleRequest external INITREMOTE Nothing $ \resp -> case resp of
 		INITREMOTE_SUCCESS -> Just noop
 		INITREMOTE_FAILURE errmsg -> Just $ error errmsg
@@ -201,7 +202,7 @@ handleRequest' lck external req mp responsehandler = do
 	handleRemoteRequest (PROGRESS bytesprocessed) =
 		maybe noop (\a -> liftIO $ a bytesprocessed) mp
 	handleRemoteRequest (DIRHASH k) = 
-		sendMessage lck external (VALUE $ hashDirMixed k)
+		sendMessage lck external $ VALUE $ hashDirMixed k
 	handleRemoteRequest (SETCONFIG setting value) =
 		liftIO $ atomically $ do
 			let v = externalConfig external
@@ -210,12 +211,30 @@ handleRequest' lck external req mp responsehandler = do
 	handleRemoteRequest (GETCONFIG setting) = do
 		value <- fromMaybe "" . M.lookup setting
 			<$> liftIO (atomically $ readTMVar $ externalConfig external)
-		sendMessage lck external (VALUE value)
+		sendMessage lck external $ VALUE value
+	handleRemoteRequest (SETCREDS setting login password) = do
+		c <- liftIO $ atomically $ readTMVar $ externalConfig external
+		c' <- setRemoteCredPair' c (credstorage setting)
+			(login, password)
+		void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
+	handleRemoteRequest (GETCREDS setting) = do
+		c <- liftIO $ atomically $ readTMVar $ externalConfig external
+		creds <- fromMaybe ("", "") <$> 
+			getRemoteCredPair c (credstorage setting)
+		sendMessage lck external $ CREDS (fst creds) (snd creds)
 	handleRemoteRequest (VERSION _) =
-		sendMessage lck external (ERROR "too late to send VERSION")
+		sendMessage lck external $ ERROR "too late to send VERSION"
 
 	handleAsyncMessage (ERROR err) = error $ "external special remote error: " ++ err
 
+	credstorage setting = CredPairStorage
+		{ credPairFile = base
+		, credPairEnvironment = (base ++ "login", base ++ "password")
+		, credPairRemoteKey = Just setting
+		}
+	  where
+		base = replace "/" "_" $ fromUUID (externalUUID external) ++ "-" ++ setting
+
 sendMessage :: Sendable m => ExternalLock -> External -> m -> Annex ()
 sendMessage lck external m = 
 	fromExternal lck external externalSend $ \h ->
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index a4d49ddf1..fbd050fe1 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -44,6 +44,7 @@ import Control.Concurrent.STM
 -- The 
 data External = External
 	{ externalType :: ExternalType
+	, externalUUID :: UUID
 	-- Empty until the remote is running.
 	, externalState :: TMVar ExternalState
 	-- Empty when a remote is in use.
@@ -52,9 +53,10 @@ data External = External
 	, externalConfig :: TMVar RemoteConfig
 	}
 
-newExternal :: ExternalType -> RemoteConfig -> Annex External
-newExternal externaltype c = liftIO $ External
+newExternal :: ExternalType -> UUID -> RemoteConfig -> Annex External
+newExternal externaltype u c = liftIO $ External
 	<$> pure externaltype
+	<*> pure u
 	<*> atomically newEmptyTMVar
 	<*> atomically (newTMVar ExternalLock)
 	<*> atomically (newTMVar c)
@@ -157,6 +159,8 @@ data RemoteRequest
 	| DIRHASH Key
 	| SETCONFIG Setting String
 	| GETCONFIG Setting
+	| SETCREDS Setting String String
+	| GETCREDS Setting
 	deriving (Show)
 
 instance Receivable RemoteRequest where
@@ -165,15 +169,19 @@ instance Receivable RemoteRequest where
 	parseCommand "DIRHASH" = parse1 DIRHASH
 	parseCommand "SETCONFIG" = parse2 SETCONFIG
 	parseCommand "GETCONFIG" = parse1 GETCONFIG
+	parseCommand "SETCREDS" = parse3 SETCREDS
+	parseCommand "GETCREDS" = parse1 GETCREDS
 	parseCommand _ = parseFail
 
 -- Responses to RemoteRequest.
 data RemoteResponse
 	= VALUE String
+	| CREDS String String
 	deriving (Show)
 
 instance Sendable RemoteResponse where
 	formatMessage (VALUE s) = [ "VALUE", serialize s ]
+	formatMessage (CREDS login password) = [ "CREDS", serialize login, serialize password ]
 
 -- Messages that can be sent at any time by either git-annex or the remote.
 data AsyncMessage