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

Introduce timeouts for all ldap actions

Browse Source
This commit is contained in:
Gregor Kleen 2019-01-22 20:05:19 +01:00
parent b938981d0e
commit 0a69047acf
6 changed files with 47 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
config/settings.yml
View File

@ -66,7 +66,8 @@ ldap:
pass: "_env:LDAPPASS:"
baseDN: "_env:LDAPBASE:"
scope: "_env:LDAPSCOPE:WholeSubtree"
timeout: "_env:LDAPSEARCHTIME:5"
timeout: "_env:LDAPTIMEOUT:5"
search-timeout: "_env:LDAPSEARCHTIME:5"
pool:
stripes: "_env:LDAPSTRIPES:1"
timeout: "_env:LDAPTIMEOUT:20"

1
package.yaml
View File

@ -113,6 +113,7 @@ dependencies:
- pkcs7
- memcached-binary
- directory-tree
- lifted-base
other-extensions:
- GeneralizedNewtypeDeriving

2
src/Application.hs
View File

@ -168,7 +168,7 @@ makeFoundation appSettings@AppSettings{..} = do
(pgConnStr appDatabaseConf)
(pgPoolSize appDatabaseConf)
ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) (poolLimit ldapPool)
ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
-- Perform database migration using our application's logging settings.
migrateAll `runSqlPool` sqlPool

8
src/Auth/LDAP.hs
View File

@ -44,7 +44,7 @@ findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSet
userSearchSettings = mconcat
[ Ldap.scope ldapScope
, Ldap.size 2
, Ldap.time ldapTimeout
, Ldap.time ldapSearchTimeout
, Ldap.derefAliases Ldap.DerefAlways
]
@ -88,7 +88,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
findUser conf ldap campusIdent [userPrincipalName]
case ldapResult of
Left err
| Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
| LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
-> do
$logDebugS "LDAP" "Invalid credentials"
loginErrorMessageI LoginR Msg.InvalidLogin
@ -110,7 +110,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
$(widgetFile "widgets/campus-login-form")
data CampusUserException = CampusUserLdapError Ldap.LdapError
data CampusUserException = CampusUserLdapError LdapPoolError
| CampusUserHostNotResolved String
| CampusUserLineTooLong
| CampusUserHostCannotConnect String [IOException]
@ -129,7 +129,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
userSearchSettings = mconcat
[ Ldap.scope Ldap.BaseObject
, Ldap.size 2
, Ldap.time ldapTimeout
, Ldap.time ldapSearchTimeout
, Ldap.derefAliases Ldap.DerefAlways
]
Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []

57
src/Ldap/Client/Pool.hs
View File

@ -3,6 +3,7 @@
module Ldap.Client.Pool
( LdapPool
, LdapExecutor, Ldap, LdapError
, LdapPoolError(..)
, withLdap
, createLdapPool
) where
@ -19,17 +20,24 @@ import Data.Time.Clock (NominalDiffTime)
import Data.Dynamic
import System.Timeout.Lifted
type LdapPool = Pool LdapExecutor
data LdapExecutor = LdapExecutor
{ ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
{ ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
, ldapDestroy :: TMVar ()
}
instance Exception LdapError
data LdapPoolError = LdapPoolTimeout | LdapError LdapError
deriving (Eq, Show, Generic, Typeable)
withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapError a)
instance Exception LdapPoolError
withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapPoolError a)
withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act
@ -37,10 +45,11 @@ createLdapPool :: ( MonadLoggerIO m, MonadIO m )
=> Ldap.Host
-> Ldap.PortNumber
-> Int -- ^ Stripes
-> NominalDiffTime -- ^ Timeout
-> NominalDiffTime -- ^ Connection Timeout
-> NominalDiffTime -- ^ Action Timeout
-> Int -- ^ Limit
-> m LdapPool
createLdapPool host port stripes timeout limit = do
createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) limit = do
logFunc <- askLoggerIO
let
@ -50,16 +59,17 @@ createLdapPool host port stripes timeout limit = do
ldapAct <- newEmptyTMVarIO
let
ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError 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
[ Handler $ return . Left . LdapError . Ldap.ParseError
, Handler $ return . Left . LdapError . Ldap.ResponseError
, Handler $ return . Left . LdapError . Ldap.IOError
, Handler $ return . Left . LdapError . Ldap.DisconnectError
, Handler $ return . Left . (id :: LdapPoolError -> LdapPoolError)
]
go :: Maybe (TMVar (Maybe a)) -> Ldap -> LoggingT IO ()
@ -71,7 +81,7 @@ createLdapPool host port stripes timeout limit = do
Nothing -> $logDebugS "LdapExecutor" "Terminating"
Just (act, returnRes) -> do
$logDebugS "LdapExecutor" "Executing"
res <- try . liftIO $ act ldap
res <- try . withTimeout . liftIO $ act ldap
didReturn <- atomically $ tryPutTMVar returnRes res
unless didReturn $
$logErrorS "LdapExecutor" "Could not return result"
@ -81,20 +91,25 @@ createLdapPool host port stripes timeout limit = do
]
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'
withTimeout $ do
setup <- newEmptyTMVarIO
maybe (return ()) throwM =<< atomically (takeTMVar setup)
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
liftIO $ createPool mkExecutor delExecutor stripes timeoutConn limit
where
withTimeout :: forall m a. (MonadBaseControl IO m, MonadThrow m) => m a -> m a
withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct

4
src/Settings.hs
View File

@ -165,7 +165,8 @@ data LdapConf = LdapConf
, ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
, ldapBase :: Ldap.Dn
, ldapScope :: Ldap.Scope
, ldapTimeout :: Int32
, ldapTimeout :: NominalDiffTime
, ldapSearchTimeout :: Int32
, ldapPool :: ResourcePoolConf
} deriving (Show)
@ -253,6 +254,7 @@ instance FromJSON LdapConf where
ldapBase <- Ldap.Dn <$> o .: "baseDN"
ldapScope <- o .: "scope"
ldapTimeout <- o .: "timeout"
ldapSearchTimeout <- o .: "search-timeout"
ldapPool <- o .: "pool"
return LdapConf{..}