diff --git a/src/Application.hs b/src/Application.hs index 51bef9a21..20fc7bfc9 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 8f0a40f98..300b20f53 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -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 diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index d85028187..eced26712 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -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 + ] diff --git a/src/Utils/Failover.hs b/src/Utils/Failover.hs index 112ceab53..e461340a1 100644 --- a/src/Utils/Failover.hs +++ b/src/Utils/Failover.hs @@ -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