fix(failover): don't always record as failed
Also improve ldap error handling
This commit is contained in:
Gregor Kleen
parent
d3c727bab6
commit
16643b6244
@ -132,7 +132,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
|
||||
-- performs initialization and returns a foundation datatype value. This is also
|
||||
-- the place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadThrow m) => AppSettings -> m UniWorX
|
||||
makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadCatch m) => AppSettings -> m UniWorX
|
||||
makeFoundation appSettings'@AppSettings{..} = do
|
||||
registerGHCMetrics
|
||||
|
||||
|
||||
@ -13,12 +13,9 @@ module Auth.LDAP
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Network.Connection
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Control.Monad.Catch as Exc
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
@ -92,9 +89,6 @@ ldapUserEmail = Ldap.Attr "mail" :|
|
||||
|
||||
|
||||
data CampusUserException = CampusUserLdapError LdapPoolError
|
||||
| CampusUserHostNotResolved String
|
||||
| CampusUserLineTooLong
|
||||
| CampusUserHostCannotConnect String [IOException]
|
||||
| CampusUserNoResult
|
||||
| CampusUserAmbiguous
|
||||
deriving (Show, Eq, Generic, Typeable)
|
||||
@ -114,7 +108,7 @@ campusUserWith :: MonadUnliftIO m
|
||||
-> FailoverMode
|
||||
-> Creds site
|
||||
-> m (Ldap.AttrList [])
|
||||
campusUserWith withLdap' pool mode Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
||||
campusUserWith withLdap' pool mode Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
@ -126,11 +120,6 @@ campusUserWith withLdap' pool mode Creds{..} = liftIO . (`catches` errHandlers)
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
where
|
||||
errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
|
||||
, Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
campusUserReTest :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUserReTest pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool
|
||||
@ -148,18 +137,13 @@ campusUser' pool mode User{userIdent}
|
||||
|
||||
|
||||
campusUserMatr :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
|
||||
campusUserMatr pool mode userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
||||
campusUserMatr pool mode userMatr = liftIO $ either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- findUserMatr conf ldap userMatr []
|
||||
case results of
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
where
|
||||
errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
|
||||
, Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserMatr' pool mode
|
||||
|
||||
@ -26,12 +26,13 @@ import Data.Time.Clock (NominalDiffTime)
|
||||
import Data.Dynamic
|
||||
|
||||
import Control.Monad.Trans.Resource (MonadResource)
|
||||
import qualified Control.Monad.Trans.Resource as Resource
|
||||
import Control.Monad.Catch
|
||||
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Fixed (Nano)
|
||||
|
||||
import Network.Connection
|
||||
|
||||
|
||||
type LdapPool = Pool LdapExecutor
|
||||
data LdapExecutor = LdapExecutor
|
||||
@ -40,10 +41,11 @@ data LdapExecutor = LdapExecutor
|
||||
, ldapAsync :: Async ()
|
||||
}
|
||||
|
||||
data LdapPoolError = LdapPoolTimeout | LdapError LdapError
|
||||
data LdapPoolError = LdapPoolTimeout
|
||||
| LdapError LdapError
|
||||
| LdapLineTooLong | LdapHostNotResolved String | LdapHostCannotConnect String [IOException]
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
|
||||
instance Exception LdapPoolError
|
||||
deriving anyclass (Exception)
|
||||
|
||||
|
||||
withLdap :: (MonadUnliftIO m, MonadCatch m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
|
||||
@ -56,7 +58,11 @@ withLdapFailoverReTest :: (MonadUnliftIO m, MonadCatch m, Typeable a) => Lens p
|
||||
withLdapFailoverReTest l@(flip withLens const -> proj) pool' doTest mode act = try . withFailoverReTest pool' doTest mode (either throwE return) $ \x -> withLdap (proj x) (\c -> act $ x & l .~ c)
|
||||
|
||||
|
||||
createLdapPool :: ( MonadLoggerIO m, MonadResource m )
|
||||
createLdapPool :: forall m.
|
||||
( MonadLogger m
|
||||
, MonadResource m, MonadUnliftIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Ldap.Host
|
||||
-> Ldap.PortNumber
|
||||
-> Int -- ^ Stripes
|
||||
@ -65,16 +71,14 @@ createLdapPool :: ( MonadLoggerIO m, MonadResource m )
|
||||
-> Int -- ^ Limit
|
||||
-> m LdapPool
|
||||
createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) limit = do
|
||||
logFunc <- askLoggerIO
|
||||
|
||||
let
|
||||
mkExecutor :: Resource.InternalState -> IO LdapExecutor
|
||||
mkExecutor rSt = Resource.runInternalState ?? rSt $ do
|
||||
mkExecutor :: m LdapExecutor
|
||||
mkExecutor = handleAny (\e -> $logErrorS "LdapExecuter" (tshow e) >> throwM e) . (`catches` convertErrors) $ do
|
||||
ldapDestroy <- liftIO newEmptyTMVarIO
|
||||
ldapAct <- liftIO newEmptyTMVarIO
|
||||
|
||||
let
|
||||
ldapExec :: forall a m. (Typeable a, MonadUnliftIO m) => (Ldap -> m a) -> m (Either LdapPoolError a)
|
||||
ldapExec :: forall a m'. (Typeable a, MonadUnliftIO m') => (Ldap -> m' a) -> m' (Either LdapPoolError a)
|
||||
ldapExec act = withRunInIO $ \runInIO -> do
|
||||
ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
|
||||
atomically $ putTMVar ldapAct (runInIO . fmap toDyn . act, ldapAnswer)
|
||||
@ -87,7 +91,7 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
|
||||
, Handler $ return . Left . (id :: LdapPoolError -> LdapPoolError)
|
||||
]
|
||||
|
||||
go :: Maybe (TMVar (Maybe a)) -> Ldap -> LoggingT IO ()
|
||||
go :: Maybe (TMVar (Maybe a)) -> Ldap -> m ()
|
||||
go waiting ldap = do
|
||||
$logDebugS "LdapExecutor" "Waiting"
|
||||
for_ waiting $ atomically . flip putTMVar Nothing
|
||||
@ -95,7 +99,7 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
|
||||
case instruction of
|
||||
Nothing -> $logDebugS "LdapExecutor" "Terminating"
|
||||
Just (act, returnRes) -> do
|
||||
$logDebugS "LdapExecutor" "Executing"
|
||||
$logDebugS "LdapExecutor" $ "Executing " <> tshow (host, port)
|
||||
res <- try . withTimeout . liftIO $ act ldap
|
||||
didReturn <- atomically $ tryPutTMVar returnRes res
|
||||
unless didReturn $
|
||||
@ -103,22 +107,24 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
|
||||
either throwM (const $ return ()) res
|
||||
`catches`
|
||||
[ Handler $ \case
|
||||
Ldap.ResponseError _ -> return ()
|
||||
Ldap.DisconnectError _ -> return ()
|
||||
other -> throwM other
|
||||
Ldap.ResponseError Ldap.ResponseErrorCode{}
|
||||
-> return ()
|
||||
other
|
||||
-> throwM other
|
||||
]
|
||||
go Nothing ldap
|
||||
|
||||
ldapAsync <- withTimeout $ do
|
||||
setup <- liftIO newEmptyTMVarIO
|
||||
|
||||
ldapAsync <- allocateAsync . flip runLoggingT logFunc $ do
|
||||
$logDebugS "LdapExecutor" "Starting"
|
||||
res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
|
||||
ldapAsync <- allocateLinkedAsync . handleAny (atomically . void . tryPutTMVar setup . Just) $ do
|
||||
$logDebugS "LdapExecutor" $ "Starting " <> tshow (host, port)
|
||||
res <- withRunInIO $ \runInIO ->
|
||||
Ldap.with host port $ runInIO . go (Just setup)
|
||||
case res of
|
||||
Left exc -> do
|
||||
$logWarnS "LdapExecutor" $ tshow exc
|
||||
atomically . void . tryPutTMVar setup $ Just exc
|
||||
atomically . void . tryPutTMVar setup . Just $ toException exc
|
||||
Right res' -> return res'
|
||||
|
||||
maybe (return ()) throwM =<< atomically (takeTMVar setup)
|
||||
@ -131,8 +137,14 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
|
||||
delExecutor LdapExecutor{..} = do
|
||||
atomically . void $ tryPutTMVar ldapDestroy ()
|
||||
wait ldapAsync
|
||||
rSt <- view _2 <$> Resource.allocate Resource.createInternalState Resource.closeInternalState
|
||||
liftIO $ createPool (mkExecutor rSt) delExecutor stripes timeoutConn limit
|
||||
withRunInIO $ \runInIO ->
|
||||
createPool (runInIO mkExecutor) delExecutor stripes timeoutConn limit
|
||||
where
|
||||
withTimeout :: forall m a. (MonadUnliftIO m, MonadThrow m) => m a -> m a
|
||||
withTimeout :: forall m' a. (MonadUnliftIO m', MonadThrow m') => m' a -> m' a
|
||||
withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct
|
||||
|
||||
convertErrors =
|
||||
[ Handler $ \LineTooLong -> throwM LdapLineTooLong
|
||||
, Handler $ \(HostNotResolved h) -> throwM $ LdapHostNotResolved h
|
||||
, Handler $ \(HostCannotConnect h es) -> throwM $ LdapHostCannotConnect h es
|
||||
]
|
||||
|
||||
@ -85,13 +85,14 @@ withFailover f@Failover{..} mode detAcceptable act = do
|
||||
| otherwise -> throwM err
|
||||
|
||||
case (res', mode) of
|
||||
(Left err, FailoverUnlimited)
|
||||
(Left err , FailoverUnlimited)
|
||||
-> doRetry err
|
||||
(Left err, FailoverLimited n)
|
||||
| n > 0
|
||||
-> doRetry err
|
||||
_other
|
||||
-> void recordFailure >> either throwM return res'
|
||||
(Left err , FailoverLimited n) | n > 0
|
||||
-> doRetry err
|
||||
(Left err , _)
|
||||
-> void recordFailure >> throwM err
|
||||
(Right res'', _)
|
||||
-> return res''
|
||||
|
||||
withFailoverReTest :: ( MonadIO m, MonadCatch m
|
||||
, Exception e
|
||||
|
||||
Loading…
Reference in New Issue
Block a user