fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Implement connection pooling for LDAP

Browse Source
This commit is contained in:
Gregor Kleen 2018-12-11 21:21:02 +01:00
parent 0407d10654
commit 30a5aff70e
9 changed files with 134 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
config/keter_testworx.yml
View File

@ -27,7 +27,10 @@ stanzas:
- LDAPPASS
- LDAPBASE
- LDAPSCOPE
- LDAPSEARCHTIME
- LDAPSTRIPES
- LDAPTIMEOUT
- LDAPLIMIT
- DUMMY_LOGIN
- DETAILED_LOGGING
- LOG_ALL

3
config/keter_uni2work.yml
View File

@ -27,7 +27,10 @@ stanzas:
- LDAPPASS
- LDAPBASE
- LDAPSCOPE
- LDAPSEARCHTIME
- LDAPSTRIPES
- LDAPTIMEOUT
- LDAPLIMIT
- DETAILED_LOGGING
- LOG_ALL
- LOGLEVEL

6
config/settings.yml
View File

@ -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:"

7
src/Application.hs
View File

@ -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

13
src/Auth/LDAP.hs
View File

@ -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

13
src/Foundation.hs
View File

@ -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
]

2
src/Import/NoFoundation.hs
View File

@ -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)

100
src/Ldap/Client/Pool.hs Normal file
View File

@ -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

2
src/Settings.hs
View File

@ -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