diff options
| -rw-r--r-- | Creds.hs | 24 | ||||
| -rw-r--r-- | Remote/External.hs | 29 | ||||
| -rw-r--r-- | Remote/External/Types.hs | 12 | ||||
| -rw-r--r-- | doc/design/external_special_remote_protocol.mdwn | 17 | ||||
| -rwxr-xr-x | doc/special_remotes/external/example.sh | 36 |
5 files changed, 96 insertions, 22 deletions
@@ -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 = + maybe (return c) (setRemoteCredPair' c storage) + =<< getRemoteCredPair c storage + +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 - go (Just creds) - | 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 + 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 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 diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn index e93ead8d6..8fef581a0 100644 --- a/doc/design/external_special_remote_protocol.mdwn +++ b/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 diff --git a/doc/special_remotes/external/example.sh b/doc/special_remotes/external/example.sh index 97f8a2813..428e2ecb9 100755 --- a/doc/special_remotes/external/example.sh +++ b/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 - # absolute, and store that. - mydirectory="$(readlink -f "$RET")" + mydirectory="$(readlink -f "$RET")" || true 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) |