add CredPair cache

Note that this does not yet use SecureMem. It would probably make sense for
the Password part of a CredPair to use SecureMem, and making that change
is better than passing in a String and having it converted to SecureMem in
this code.

3 files changed, 74 insertions, 0 deletions

diff --git a/Assistant/CredPairCache.hs b/Assistant/CredPairCache.hs
new file mode 100644
index 000000000..2b8f72e7c
--- /dev/null
+++ b/Assistant/CredPairCache.hs
@@ -0,0 +1,53 @@
+{- git-annex assistant CredPair cache.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Assistant.CredPairCache (
+	cacheCred,
+	getCachedCred,
+	expireCachedCred,
+) where
+
+import Assistant.Types.CredPairCache
+import Types.Creds
+import Assistant.Common
+import Utility.ThreadScheduler
+
+import qualified Data.Map as M
+import Control.Concurrent
+
+{- Caches a CredPair, but only for a limited time, after which it
+ - will expire.
+ -
+ - Note that repeatedly caching the same CredPair
+ - does not reset its expiry time.
+ -}
+cacheCred :: CredPair -> Seconds -> Assistant ()
+cacheCred (login, password) expireafter = do
+	cache <- getAssistant credPairCache
+	liftIO $ do
+		changeStrict cache $ M.insert login password
+		void $ forkIO $ do
+			threadDelaySeconds expireafter
+			changeStrict cache $ M.delete login
+
+getCachedCred :: Login -> Assistant (Maybe Password)
+getCachedCred login = do
+	cache <- getAssistant credPairCache
+	liftIO $ M.lookup login <$> readMVar cache
+
+expireCachedCred :: Login -> Assistant ()
+expireCachedCred login = do
+	cache <- getAssistant credPairCache
+	liftIO $ changeStrict cache $ M.delete login
+
+{- Update map strictly to avoid keeping references to old creds in memory. -}
+changeStrict :: CredPairCache -> (M.Map Login Password -> M.Map Login Password) -> IO ()
+changeStrict cache a = modifyMVar_ cache $ \m -> do
+	let !m' = a m
+	return m'
diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs
index 350e3d33b..5b3f5abb4 100644
--- a/Assistant/Monad.hs
+++ b/Assistant/Monad.hs
@@ -44,6 +44,7 @@ import Assistant.Types.Buddies
 import Assistant.Types.NetMessager
 import Assistant.Types.ThreadName
 import Assistant.Types.RemoteControl
+import Assistant.Types.CredPairCache
 
 newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
 	deriving (
@@ -70,6 +71,7 @@ data AssistantData = AssistantData
 	, buddyList :: BuddyList
 	, netMessager :: NetMessager
 	, remoteControl :: RemoteControl
+	, credPairCache :: CredPairCache
 	}
 
 newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
@@ -89,6 +91,7 @@ newAssistantData st dstatus = AssistantData
 	<*> newBuddyList
 	<*> newNetMessager
 	<*> newRemoteControl
+	<*> newCredPairCache
 
 runAssistant :: AssistantData -> Assistant a -> IO a
 runAssistant d a = runReaderT (mkAssistant a) d
diff --git a/Assistant/Types/CredPairCache.hs b/Assistant/Types/CredPairCache.hs
new file mode 100644
index 000000000..a1e11c257
--- /dev/null
+++ b/Assistant/Types/CredPairCache.hs
@@ -0,0 +1,18 @@
+{- git-annex assistant CredPair cache.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Types.CredPairCache where
+
+import Types.Creds
+
+import Control.Concurrent
+import qualified Data.Map as M
+
+type CredPairCache = MVar (M.Map Login Password)
+
+newCredPairCache :: IO CredPairCache
+newCredPairCache = newMVar M.empty