diff options
| -rw-r--r-- | Assistant/CredPairCache.hs | 53 | ||||
| -rw-r--r-- | Assistant/Monad.hs | 3 | ||||
| -rw-r--r-- | Assistant/Types/CredPairCache.hs | 18 | ||||
| -rw-r--r-- | Types/Creds.hs | 4 |
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 |