fix(failover): don't always record as failed

Also improve ldap error handling

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
   

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

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)
-
+  deriving anyclass (Exception)
-instance Exception LdapPoolError
 
 
 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 :: m LdapExecutor
-    mkExecutor rSt = Resource.runInternalState ?? rSt $ do
+    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.ResponseError Ldap.ResponseErrorCode{}
-                    Ldap.DisconnectError _ -> return ()
+                      -> return ()
-                    other                  -> throwM other
+                    other
+                      -> throwM other
                 ]
               go Nothing ldap
 
       ldapAsync <- withTimeout $ do
         setup <- liftIO newEmptyTMVarIO
 
-        ldapAsync <- allocateAsync . flip runLoggingT logFunc $ do
+        ldapAsync <- allocateLinkedAsync . handleAny (atomically . void . tryPutTMVar setup . Just) $ do
-          $logDebugS "LdapExecutor" "Starting"
+          $logDebugS "LdapExecutor" $ "Starting " <> tshow (host, port)
-          res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
+          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
+  withRunInIO $ \runInIO -> 
-  liftIO $ createPool (mkExecutor rSt) delExecutor stripes timeoutConn limit
+    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
+      ]

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)
+    (Left  err  , FailoverLimited n) | n > 0
-      | n > 0
+      -> doRetry err
-        -> doRetry err
+    (Left  err  , _)
-    _other
+      -> void recordFailure >> throwM err
-      -> void recordFailure >> either throwM return res'
+    (Right res'', _)
+      -> return res''
 
 withFailoverReTest :: ( MonadIO m, MonadCatch m
                       , Exception e