add credential storage support for external special remotes & update example

Creds.hs

@@ -35,25 +35,27 @@ 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 = go =<< getRemoteCredPair c storage
+setRemoteCredPair c storage = 
-  where
+	maybe (return c) (setRemoteCredPair' c storage)
-	go (Just creds)
+		=<< getRemoteCredPair c storage
-		| embedCreds c = case credPairRemoteKey storage of
-			Nothing -> localcache creds
-			Just key -> storeconfig creds key =<< remoteCipher c
-		| otherwise = localcache creds
-	go Nothing = return c
 
-	localcache creds = do
+setRemoteCredPair' :: RemoteConfig -> CredPairStorage -> CredPair -> Annex RemoteConfig
+setRemoteCredPair' c storage creds
+	| embedCreds c = case credPairRemoteKey storage of
+		Nothing -> localcache
+		Just key -> storeconfig key =<< remoteCipher c
+	| otherwise = localcache
+  where
+	localcache = do
 		writeCacheCredPair creds storage
 		return c
 
-	storeconfig creds key (Just cipher) = do
+	storeconfig key (Just cipher) = do
 		s <- liftIO $ encrypt [] cipher
 			(feedBytes $ L.pack $ encodeCredPair creds)
 			(readBytes $ return . L.unpack)
 		return $ M.insert key (toB64 s) c
-	storeconfig creds key Nothing =
+	storeconfig key Nothing =
 		return $ M.insert key (toB64 $ encodeCredPair creds) c
 
 {- Gets a remote's credpair, from the environment if set, otherwise

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 ->

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 -> UUID -> RemoteConfig -> Annex External
-newExternal externaltype c = liftIO $ 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

doc/design/external_special_remote_protocol.mdwn

@@ -189,6 +189,23 @@ in control.
   can have been set by a previous SETCONFIG. Can be run at any time.  
   (git-annex replies with VALUE followed by the value. If the setting is
   not set, the value will be empty.)
+* `SETCREDS Setting User Password`  
+  When some form of user and password is needed to access a special remote,
+  this can be used to securely store them for later use.
+  (Like SETCONFIG, this is normally sent only during INITREMOTE.)  
+  The Setting indicates which value in a remote's configuration can be
+  used to store the creds.  
+  Note that creds are normally only stored in the remote's configuration
+  when it's surely safe to do so; when gpg encryption is used, in which
+  case the creds will be encrypted using it. If creds are not stored in
+  the configuration, they'll only be stored in a local file.  
+  (embedcreds can be set to yes by the user or by SETCONFIG to force
+   the creds to be stored in the remote's configuration).
+* `GETCREDS Setting`  
+  Gets any creds that were previously stored in the remote's configuration
+  or a file.
+  (git-annex replies with "CREDS User Password". If no creds are found,
+  User and Password are both empty.)
 
 ## general messages
 

doc/special_remotes/external/example.sh

@@ -48,6 +48,32 @@ ask () {
 	esac
 }
 
+# This remote doesn't need credentials to access it,
+# but many of them will. Here's how to handle requiring the user
+# set MYPASSWORD and MYLOGIN when running initremote. The creds
+# will be stored securely for later use, so the user only needs
+# to provide them once.
+setupcreds () {
+	if [ -z "$MYPASSWORD" ] || [ -z "$MYLOGIN" ]; then
+		echo INITREMOTE-FAILURE "You need to set MYPASSWORD and MYLOGIN environment variables when running initremote."
+	else
+		echo SETCREDS mycreds "$MYLOGIN" "$MYPASSWORD"	
+		echo INITREMOTE-SUCCESS
+	fi
+}
+
+getcreds () {
+	echo GETCREDS mycreds
+	read resp
+	case "${resp%% *}" in
+		CREDS)
+			MYLOGIN="$(echo "$resp" | sed 's/^CREDS \([^ ]*\) .*/\1/')"
+			MYPASSWORD="$(echo "$resp" | sed 's/^CREDS [^ ]* //')"
+		;;
+	esac
+
+}
+
 # This has to come first, to get the protocol started.
 echo VERSION 1
 
@@ -66,16 +92,17 @@ while read line; do
 			# git annex initremote or git annex enableremote is
 			# run.)
 
+			# The directory provided by the user
+			# could be relative; make it absolute,
+			# and store that.
 			getconfig directory
-			# Input directory could be relative; make it
+			mydirectory="$(readlink -f "$RET")" || true
-			# absolute, and store that.
-			mydirectory="$(readlink -f "$RET")"
 			setconfig directory "$mydirectory"
 			if [ -z "$mydirectory" ]; then
 				echo INITREMOTE-FAILURE "You need to set directory="
 			else
 				if mkdir -p "$mydirectory"; then
-					echo INITREMOTE-SUCCESS
+					setupcreds
 				else
 					echo INITREMOTE-FAILURE "Failed to write to $mydirectory"
 				fi
@@ -87,6 +114,7 @@ while read line; do
 			# special remote here.
 			getconfig directory
 			mydirectory="$RET"
+			getcreds
 			echo PREPARE-SUCCESS
 		;;
 		TRANSFER)