diff options
| -rw-r--r-- | Assistant/XMPP/Client.hs | 25 | ||||
| -rw-r--r-- | Creds.hs | 129 | ||||
| -rw-r--r-- | Remote/S3.hs | 105 | ||||
| -rw-r--r-- | Types/Remote.hs | 3 |
4 files changed, 156 insertions, 106 deletions
diff --git a/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs index 8ab0c2857..c2a86cb41 100644 --- a/Assistant/XMPP/Client.hs +++ b/Assistant/XMPP/Client.hs @@ -8,8 +8,8 @@ module Assistant.XMPP.Client where import Assistant.Common -import Utility.FileMode import Utility.SRV +import Creds import Network.Protocol.XMPP import Network @@ -63,23 +63,12 @@ runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a runClientError s j u p x = either (error . show) return =<< runClient s j u p x getXMPPCreds :: Annex (Maybe XMPPCreds) -getXMPPCreds = do - f <- xmppCredsFile - s <- liftIO $ catchMaybeIO $ readFile f - return $ readish =<< s +getXMPPCreds = parse <$> readCacheCreds xmppCredsFile + where + parse s = readish =<< s setXMPPCreds :: XMPPCreds -> Annex () -setXMPPCreds creds = do - f <- xmppCredsFile - liftIO $ do - createDirectoryIfMissing True (parentDir f) - h <- openFile f WriteMode - modifyFileMode f $ removeModes - [groupReadMode, otherReadMode] - hPutStr h (show creds) - hClose h +setXMPPCreds creds = writeCacheCreds (show creds) xmppCredsFile -xmppCredsFile :: Annex FilePath -xmppCredsFile = do - dir <- fromRepo gitAnnexCredsDir - return $ dir </> "xmpp" +xmppCredsFile :: FilePath +xmppCredsFile = "xmpp" diff --git a/Creds.hs b/Creds.hs new file mode 100644 index 000000000..b907073f5 --- /dev/null +++ b/Creds.hs @@ -0,0 +1,129 @@ +{- Credentials storage + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Creds where + +import Common.Annex +import Annex.Perms +import Utility.FileMode +import Crypto +import Types.Remote (RemoteConfig, RemoteConfigKey) +import Remote.Helper.Encryptable (remoteCipher, isTrustedCipher) + +import System.Environment +import System.Posix.Env (setEnv) +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 + { credPairFile :: FilePath + , credPairEnvironment :: (String, String) + , credPairRemoteKey :: Maybe RemoteConfigKey + } + +{- Stores creds in a remote's configuration, if the remote is encrypted + - with a GPG key. Otherwise, caches them locally. -} +setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex RemoteConfig +setRemoteCredPair c storage = go =<< getRemoteCredPair c storage + where + go (Just creds) = do + mcipher <- remoteCipher c + case (mcipher, credPairRemoteKey storage) of + (Just cipher, Just key) | isTrustedCipher c -> do + s <- liftIO $ withEncryptedContent cipher + (return $ L.pack $ encodeCredPair creds) + (return . L.unpack) + return $ M.insert key (toB64 s) c + _ -> do + writeCacheCredPair creds storage + return c + go Nothing = return c + +{- Gets a remote's credpair, from the environment if set, otherwise + - from the cache in gitAnnexCredsDir, or failing that, from the encrypted + - value in RemoteConfig. -} +getRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair) +getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv + where + fromenv = liftIO $ getEnvCredPair storage + fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage + fromconfig = case credPairRemoteKey storage of + Just key -> do + mcipher <- remoteCipher c + case (M.lookup key c, mcipher) of + (Just enccreds, Just cipher) -> do + creds <- liftIO $ decrypt enccreds cipher + case decodeCredPair creds of + Just credpair -> do + writeCacheCredPair credpair storage + return $ Just credpair + _ -> do error $ "bad " ++ key + _ -> return Nothing + Nothing -> return Nothing + decrypt enccreds cipher = withDecryptedContent cipher + (return $ L.pack $ fromB64 enccreds) + (return . L.unpack) + +{- Gets a CredPair from the environment. -} +getEnvCredPair :: CredPairStorage -> IO (Maybe CredPair) +getEnvCredPair storage = liftM2 (,) + <$> get uenv + <*> get penv + where + (uenv, penv) = credPairEnvironment storage + get = catchMaybeIO . getEnv + +{- Stores a CredPair in the environment. -} +setEnvCredPair :: CredPair -> CredPairStorage -> IO () +setEnvCredPair (l, p) storage = do + set uenv l + set penv p + where + (uenv, penv) = credPairEnvironment storage + set var val = setEnv var val True + +writeCacheCredPair :: CredPair -> CredPairStorage -> Annex () +writeCacheCredPair credpair storage = + writeCacheCreds (encodeCredPair credpair) (credPairFile storage) + +{- Stores the creds in a file inside gitAnnexCredsDir that only the user + - can read. -} +writeCacheCreds :: Creds -> FilePath -> Annex () +writeCacheCreds creds file = do + d <- fromRepo gitAnnexCredsDir + createAnnexDirectory d + liftIO $ do + let f = d </> file + h <- openFile f WriteMode + modifyFileMode f $ removeModes + [groupReadMode, otherReadMode] + hPutStr h creds + hClose h + +readCacheCredPair :: CredPairStorage -> Annex (Maybe CredPair) +readCacheCredPair storage = maybe Nothing decodeCredPair + <$> readCacheCreds (credPairFile storage) + +readCacheCreds :: FilePath -> Annex (Maybe Creds) +readCacheCreds file = do + d <- fromRepo gitAnnexCredsDir + let f = d </> file + liftIO $ catchMaybeIO $ readFile f + +encodeCredPair :: CredPair -> Creds +encodeCredPair (l, p) = unlines [l, p] + +decodeCredPair :: Creds -> Maybe CredPair +decodeCredPair creds = case lines creds of + l:p:[] -> Just (l, p) + _ -> Nothing diff --git a/Remote/S3.hs b/Remote/S3.hs index 0c9d523b8..b05de6ad4 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -14,8 +14,6 @@ import Network.AWS.AWSResult import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map as M import Data.Char -import System.Environment -import System.Posix.Env (setEnv) import Common.Annex import Types.Remote @@ -25,10 +23,8 @@ import Config import Remote.Helper.Special import Remote.Helper.Encryptable import Crypto +import Creds import Annex.Content -import Utility.Base64 -import Annex.Perms -import Utility.FileMode remote :: RemoteType remote = RemoteType { @@ -87,7 +83,7 @@ s3Setup u c = handlehost $ M.lookup "host" c use fullconfig = do gitConfigSpecialRemote u fullconfig "s3" "true" - s3SetCreds fullconfig u + setRemoteCredPair fullconfig (s3Creds u) defaulthost = do c' <- encryptionSetup c @@ -257,93 +253,28 @@ s3ConnectionRequired c u = maybe (error "Cannot connect to S3") return =<< s3Connection c u s3Connection :: RemoteConfig -> UUID -> Annex (Maybe AWSConnection) -s3Connection c u = do - creds <- s3GetCreds c u - case creds of - Just (ak, sk) -> return $ Just $ AWSConnection host port ak sk - _ -> do - warning $ "Set both " ++ s3AccessKey ++ " and " ++ s3SecretKey ++ " to use S3" - return Nothing +s3Connection c u = go =<< getRemoteCredPair c creds where + go Nothing = do + warning $ "Set both " ++ s3AccessKey ++ " and " ++ s3SecretKey ++ " to use S3" + return Nothing + go (Just (ak, sk)) = return $ Just $ AWSConnection host port ak sk + + creds = s3Creds u + (s3AccessKey, s3SecretKey) = credPairEnvironment creds + host = fromJust $ M.lookup "host" c port = let s = fromJust $ M.lookup "port" c in case reads s of [(p, _)] -> p _ -> error $ "bad S3 port value: " ++ s -{- S3 creds come from the environment if set, otherwise from the cache - - in gitAnnexCredsDir, or failing that, might be stored encrypted in - - the remote's config. -} -s3GetCreds :: RemoteConfig -> UUID -> Annex (Maybe (String, String)) -s3GetCreds c u = maybe fromcache (return . Just) =<< liftIO getenv - where - getenv = liftM2 (,) - <$> get s3AccessKey - <*> get s3SecretKey - where - get = catchMaybeIO . getEnv - fromcache = do - d <- fromRepo gitAnnexCredsDir - let f = d </> fromUUID u - v <- liftIO $ catchMaybeIO $ readFile f - case lines <$> v of - Just (ak:sk:[]) -> return $ Just (ak, sk) - _ -> fromconfig - fromconfig = do - mcipher <- remoteCipher c - case (M.lookup "s3creds" c, mcipher) of - (Just s3creds, Just cipher) -> do - creds <- liftIO $ decrypt s3creds cipher - case creds of - [ak, sk] -> do - s3CacheCreds (ak, sk) u - return $ Just (ak, sk) - _ -> do error "bad s3creds" - _ -> return Nothing - decrypt s3creds cipher = lines - <$> withDecryptedContent cipher - (return $ L.pack $ fromB64 s3creds) - (return . L.unpack) - -{- Stores S3 creds encrypted in the remote's config if possible to do so - - securely, and otherwise locally in gitAnnexCredsDir. -} -s3SetCreds :: RemoteConfig -> UUID -> Annex RemoteConfig -s3SetCreds c u = do - creds <- s3GetCreds c u - case creds of - Just (ak, sk) -> do - mcipher <- remoteCipher c - case mcipher of - Just cipher | isTrustedCipher c -> do - s <- liftIO $ withEncryptedContent cipher - (return $ L.pack $ unlines [ak, sk]) - (return . L.unpack) - return $ M.insert "s3creds" (toB64 s) c - _ -> do - s3CacheCreds (ak, sk) u - return c - _ -> return c - -{- The S3 creds are cached in gitAnnexCredsDir. -} -s3CacheCreds :: (String, String) -> UUID -> Annex () -s3CacheCreds (ak, sk) u = do - d <- fromRepo gitAnnexCredsDir - createAnnexDirectory d - liftIO $ do - let f = d </> fromUUID u - h <- openFile f WriteMode - modifyFileMode f $ removeModes - [groupReadMode, otherReadMode] - hPutStr h $ unlines [ak, sk] - hClose h +s3Creds :: UUID -> CredPairStorage +s3Creds u = CredPairStorage + { credPairFile = fromUUID u + , credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY") + , credPairRemoteKey = Just "s3creds" + } -{- Sets the S3 creds in the environment. -} s3SetCredsEnv :: (String, String) -> IO () -s3SetCredsEnv (ak, sk) = do - setEnv s3AccessKey ak True - setEnv s3SecretKey sk True - -s3AccessKey :: String -s3AccessKey = "AWS_ACCESS_KEY_ID" -s3SecretKey :: String -s3SecretKey = "AWS_SECRET_ACCESS_KEY" +s3SetCredsEnv creds = setEnvCredPair creds $ s3Creds undefined diff --git a/Types/Remote.hs b/Types/Remote.hs index d31d9a78f..572240de0 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -16,7 +16,8 @@ import qualified Git import Types.Key import Types.UUID -type RemoteConfig = M.Map String String +type RemoteConfigKey = String +type RemoteConfig = M.Map RemoteConfigKey String {- There are different types of remotes. -} data RemoteTypeA a = RemoteType { |