factor out Creds

Assistant/WebApp/Configurators/S3.hs

@@ -116,7 +116,7 @@ getEnableS3R uuid = s3Configurator $ do
 makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
 makeS3Remote (S3Creds ak sk) name setup config = do
 	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
-	liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)
+	liftIO $ S3.s3SetCredsEnv (T.unpack ak, T.unpack sk)
 	r <- liftAssistant $ liftAnnex $ addRemote $ do
 		makeSpecialRemote name S3.remote config
 		return remotename

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"

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

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)
+s3Creds :: UUID -> CredPairStorage
+s3Creds u = CredPairStorage
+	{ credPairFile = fromUUID u
+	, credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY")
+	, credPairRemoteKey = Just "s3creds"
+	}
 
-{- 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
-
-{- 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

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 {