From 30a5aff70efc7dcc948c55aba4efc25b793fc65d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 11 Dec 2018 21:21:02 +0100 Subject: [PATCH] Implement connection pooling for LDAP --- config/keter_testworx.yml | 3 ++ config/keter_uni2work.yml | 3 ++ config/settings.yml | 6 ++- src/Application.hs | 7 ++- src/Auth/LDAP.hs | 13 ++--- src/Foundation.hs | 13 ++--- src/Import/NoFoundation.hs | 2 + src/Ldap/Client/Pool.hs | 100 +++++++++++++++++++++++++++++++++++++ src/Settings.hs | 2 + 9 files changed, 134 insertions(+), 15 deletions(-) create mode 100644 src/Ldap/Client/Pool.hs diff --git a/config/keter_testworx.yml b/config/keter_testworx.yml index be7037613..4f1d648db 100644 --- a/config/keter_testworx.yml +++ b/config/keter_testworx.yml @@ -27,7 +27,10 @@ stanzas: - LDAPPASS - LDAPBASE - LDAPSCOPE + - LDAPSEARCHTIME + - LDAPSTRIPES - LDAPTIMEOUT + - LDAPLIMIT - DUMMY_LOGIN - DETAILED_LOGGING - LOG_ALL diff --git a/config/keter_uni2work.yml b/config/keter_uni2work.yml index 873124070..15f9eee7e 100644 --- a/config/keter_uni2work.yml +++ b/config/keter_uni2work.yml @@ -27,7 +27,10 @@ stanzas: - LDAPPASS - LDAPBASE - LDAPSCOPE + - LDAPSEARCHTIME + - LDAPSTRIPES - LDAPTIMEOUT + - LDAPLIMIT - DETAILED_LOGGING - LOG_ALL - LOGLEVEL diff --git a/config/settings.yml b/config/settings.yml index 2ff396932..0a8252dae 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -66,7 +66,11 @@ ldap: pass: "_env:LDAPPASS:" baseDN: "_env:LDAPBASE:" scope: "_env:LDAPSCOPE:WholeSubtree" - timeout: "_env:LDAPTIMEOUT:5" + timeout: "_env:LDAPSEARCHTIME:5" + pool: + stripes: "_env:LDAPSTRIPES:1" + timeout: "_env:LDAPTIMEOUT:20" + limit: "_env:LDAPLIMIT:10" smtp: host: "_env:SMTPHOST:" diff --git a/src/Application.hs b/src/Application.hs index cdf4d9ecc..144945e00 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -139,13 +139,14 @@ makeFoundation appSettings@AppSettings{..} = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation") + (error "ldapPool forced in tempFoundation") (error "cryptoIDKey forced in tempFoundation") (error "sessionKey forced in tempFoundation") (error "secretBoxKey forced in tempFoundation") @@ -166,6 +167,8 @@ makeFoundation appSettings@AppSettings{..} = do sqlPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) + + ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) (poolLimit ldapPool) -- Perform database migration using our application's logging settings. migrateAll `runSqlPool` sqlPool @@ -173,7 +176,7 @@ makeFoundation appSettings@AppSettings{..} = do appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool - let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached + let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached handleJobs foundation diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 2b053ce05..ce07bb83c 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -17,6 +17,7 @@ import qualified Control.Monad.Catch as Exc import Utils.Form +import Ldap.Client (Ldap) import qualified Ldap.Client as Ldap import qualified Data.Text.Encoding as Text @@ -36,7 +37,7 @@ data CampusMessage = MsgCampusIdentNote | MsgCampusInvalidCredentials -findUser :: LdapConf -> Ldap.Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] +findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter where userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent @@ -66,8 +67,8 @@ campusLogin :: forall site. , RenderMessage site CampusMessage , Button site SubmitButton , Show (ButtonCssClass site) - ) => LdapConf -> AuthPlugin site -campusLogin conf@LdapConf{..} = AuthPlugin{..} + ) => LdapConf -> LdapPool -> AuthPlugin site +campusLogin conf@LdapConf{..} pool = AuthPlugin{..} where apName = "LDAP" apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent @@ -79,7 +80,7 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..} redirect LoginR FormMissing -> redirect LoginR FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do - ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do + ldapResult <- withLdap pool $ \ldap -> do Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) Ldap.bind ldap ldapDn ldapPassword findUser conf ldap campusIdent [userPrincipalName] @@ -117,8 +118,8 @@ data CampusUserException = CampusUserLdapError Ldap.LdapError instance Exception CampusUserException -campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList []) -campusUser conf@LdapConf{..} Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do +campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) +campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do Ldap.bind ldap ldapDn ldapPassword results <- case lookup "DN" credsExtra of Just userDN -> do diff --git a/src/Foundation.hs b/src/Foundation.hs index 601db3527..cf3483b6d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -102,6 +102,7 @@ data UniWorX = UniWorX , appStatic :: EmbeddedStatic -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. , appSmtpPool :: Maybe SMTPPool + , appLdapPool :: Maybe LdapPool , appWidgetMemcached :: Maybe Memcached.Connection , appHttpManager :: Manager , appLogger :: (ReleaseKey, TVar Logger) @@ -1581,11 +1582,11 @@ instance YesodAuth UniWorX where acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth $logDebugS "auth" $ tshow Creds{..} - AppSettings{ appUserDefaults = UserDefaultConf{..}, ..} <- getsYesod appSettings + UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod - flip catches excHandlers $ case appLdapConf of - Just ldapConf -> fmap (either id id) . runExceptT $ do - ldapData <- campusUser ldapConf $ Creds credsPlugin (CI.original userIdent) credsExtra + flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of + Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do + ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (CI.original userIdent) credsExtra $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData let @@ -1669,8 +1670,8 @@ instance YesodAuth UniWorX where where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) - authPlugins (appSettings -> AppSettings{..}) = catMaybes - [ campusLogin <$> appLdapConf + authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes + [ campusLogin <$> appLdapConf <*> appLdapPool , Just . hashLogin $ pwHashAlgorithm appAuthPWHash , dummyLogin <$ guard appAuthDummyLogin ] diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index a832df0db..868ba4b67 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -50,6 +50,8 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey) import Network.Mail.Mime.Instances as Import () import Yesod.Core.Instances as Import () +import Ldap.Client.Pool as Import + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs new file mode 100644 index 000000000..ad84150e2 --- /dev/null +++ b/src/Ldap/Client/Pool.hs @@ -0,0 +1,100 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ldap.Client.Pool + ( LdapPool + , LdapExecutor, Ldap, LdapError + , withLdap + , createLdapPool + ) where + +import ClassyPrelude + +import Ldap.Client (Ldap, LdapError) +import qualified Ldap.Client as Ldap + +import Data.Pool + +import Control.Monad.Logger +import Data.Time.Clock (NominalDiffTime) + +import Data.Dynamic + + +type LdapPool = Pool LdapExecutor +data LdapExecutor = LdapExecutor + { ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a) + , ldapDestroy :: TMVar () + } + +instance Exception LdapError + + +withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapError a) +withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act + + +createLdapPool :: ( MonadLoggerIO m, MonadIO m ) + => Ldap.Host + -> Ldap.PortNumber + -> Int -- ^ Stripes + -> NominalDiffTime -- ^ Timeout + -> Int -- ^ Limit + -> m LdapPool +createLdapPool host port stripes timeout limit = do + logFunc <- askLoggerIO + + let + mkExecutor :: IO LdapExecutor + mkExecutor = do + ldapDestroy <- newEmptyTMVarIO + ldapAct <- newEmptyTMVarIO + + let + ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a) + ldapExec act = do + ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic)) + atomically $ putTMVar ldapAct (fmap toDyn . act, ldapAnswer) + either throwIO (return . Right . flip fromDyn (error "Could not cast dynamic")) =<< atomically (takeTMVar ldapAnswer) + `catches` + [ Handler $ return . Left . Ldap.ParseError + , Handler $ return . Left . Ldap.ResponseError + , Handler $ return . Left . Ldap.IOError + , Handler $ return . Left . Ldap.DisconnectError + ] + + go :: Maybe (TMVar (Maybe a)) -> Ldap -> LoggingT IO () + go waiting ldap = do + $logDebugS "LdapExecutor" "Waiting" + for_ waiting $ atomically . flip putTMVar Nothing + instruction <- atomically $ (Nothing <$ takeTMVar ldapDestroy) <|> (Just <$> takeTMVar ldapAct) + case instruction of + Nothing -> $logDebugS "LdapExecutor" "Terminating" + Just (act, returnRes) -> do + $logDebugS "LdapExecutor" "Executing" + res <- try . liftIO $ act ldap + didReturn <- atomically $ tryPutTMVar returnRes res + unless didReturn $ + $logErrorS "LdapExecutor" "Could not return result" + either throwM (const $ return ()) res + `catches` + [ Handler (\(Ldap.ResponseError _) -> return ()) + ] + go Nothing ldap + + setup <- newEmptyTMVarIO + void . fork . flip runLoggingT logFunc $ do + $logDebugS "LdapExecutor" "Starting" + res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup) + case res of + Left exc -> do + $logWarnS "LdapExecutor" $ tshow exc + atomically . void . tryPutTMVar setup $ Just exc + Right res' -> return res' + + maybe (return ()) throwM =<< atomically (takeTMVar setup) + + return LdapExecutor{..} + + delExecutor :: LdapExecutor -> IO () + delExecutor LdapExecutor{..} = atomically . void $ tryPutTMVar ldapDestroy () + liftIO $ createPool mkExecutor delExecutor stripes timeout limit diff --git a/src/Settings.hs b/src/Settings.hs index 8abbc1fe1..f511e579b 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -162,6 +162,7 @@ data LdapConf = LdapConf , ldapBase :: Ldap.Dn , ldapScope :: Ldap.Scope , ldapTimeout :: Int32 + , ldapPool :: ResourcePoolConf } deriving (Show) data SmtpConf = SmtpConf @@ -248,6 +249,7 @@ instance FromJSON LdapConf where ldapBase <- Ldap.Dn <$> o .: "baseDN" ldapScope <- o .: "scope" ldapTimeout <- o .: "timeout" + ldapPool <- o .: "pool" return LdapConf{..} deriveFromJSON