summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-04-29 18:01:14 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-04-29 18:08:02 -0400
commite7bb1e85fbfa7b691ed4248cc0359a87cb2fb71e (patch)
treeae6519ac6c37251d6de3e973ee4e160effcb1ee2
parentbb925fe8111b5e807942d1fdd6dc079e4953e905 (diff)
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.
-rw-r--r--Assistant/CredPairCache.hs53
-rw-r--r--Assistant/Monad.hs3
-rw-r--r--Assistant/Types/CredPairCache.hs18
-rw-r--r--Types/Creds.hs4
4 files changed, 77 insertions, 1 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
diff --git a/Types/Creds.hs b/Types/Creds.hs
index cb312f66d..c16e530b1 100644
--- a/Types/Creds.hs
+++ b/Types/Creds.hs
@@ -9,4 +9,6 @@ module Types.Creds where
type Creds = String -- can be any data that contains credentials
-type CredPair = (String, String) -- login, password
+type CredPair = (Login, Password)
+type Login = String
+type Password = String -- todo: use securemem