fix(ldap-failover): improve concurrency & error handling

.hlint.yaml

@@ -10,6 +10,7 @@
   - ignore: { name: "Use &&" }
   - ignore: { name: "Use ++" }
   - ignore: { name: "Use ***" }
+  - ignore: { name: "Redundant void" }
 
   - arguments:
       - -XQuasiQuotes

src/Application.hs

@@ -94,7 +94,9 @@ import Handler.Utils.Routes (classifyHandler)
 
 import qualified Data.Acid.Memory as Acid
 import qualified Web.ServerSession.Backend.Acid as Acid
-
+  
+import qualified Ldap.Client as Ldap (Host(Plain, Tls))
+  
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.News
@@ -208,9 +210,13 @@ makeFoundation appSettings'@AppSettings{..} = do
         (pgConnStr  appDatabaseConf)
         (pgPoolSize appDatabaseConf)
 
-      ldapPool <- traverse mkFailover <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
+      ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
-        $logDebugS "setup" $ "LDAP-Pool " <> tshow ldapHost
+        let ldapLabel = case ldapHost of
-        (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
+              Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
+              Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
+        $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
+        (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
+      forM_ ldapPool $ registerFailoverMetrics "ldap"
 
       -- Perform database migration using our application's logging settings.
       if

src/Auth/LDAP.hs

@@ -95,47 +95,49 @@ instance Exception CampusUserException
 
 makePrisms ''CampusUserException
 
-campusUserWith :: MonadUnliftIO m
+campusUserWith :: ( MonadUnliftIO m
+                  , MonadCatch m
+                  )
                => (    Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
                     -> Failover (LdapConf, LdapPool)
                     -> FailoverMode
-                    -> ((LdapConf, Ldap) -> IO (Ldap.AttrList []))
+                    -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
-                    -> IO (Either LdapPoolError (Ldap.AttrList []))
+                    -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
                   )
                -> Failover (LdapConf, LdapPool)
                -> FailoverMode
                -> Creds site
-               -> m (Ldap.AttrList [])
+               -> m (Either CampusUserException (Ldap.AttrList []))
-campusUserWith withLdap' pool mode Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
+campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do
-  Ldap.bind ldap ldapDn ldapPassword
+  lift $ Ldap.bind ldap ldapDn ldapPassword
   results <- case lookup "DN" credsExtra of
     Just userDN -> do
       let userFilter = Ldap.Present ldapUserPrincipalName
-      Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter []
+      lift $ Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter []
     Nothing -> do
-      findUser conf ldap credsIdent []
+      lift $ findUser conf ldap credsIdent []
   case results of
-    [] -> throwM CampusUserNoResult
+    [] -> throwE CampusUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs
-    _otherwise -> throwM CampusUserAmbiguous
+    _otherwise -> throwE CampusUserAmbiguous
 
-campusUserReTest  :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
+campusUserReTest  :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
-campusUserReTest pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool
+campusUserReTest pool doTest mode creds = either throwM return =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
 
-campusUserReTest' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
+campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
 campusUserReTest' pool doTest mode User{userIdent}
   = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) [])
 
-campusUser :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
+campusUser :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
-campusUser = campusUserWith withLdapFailover
+campusUser pool mode creds = either throwM return =<< campusUserWith withLdapFailover pool mode creds
 
-campusUser' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
+campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
 campusUser' pool mode User{userIdent}
   = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) [])
 
 
-campusUserMatr :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
+campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
-campusUserMatr pool mode userMatr = liftIO $ either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
+campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
   Ldap.bind ldap ldapDn ldapPassword
   results <- findUserMatr conf ldap userMatr []
   case results of
@@ -143,7 +145,7 @@ campusUserMatr pool mode userMatr = liftIO $ either (throwM . CampusUserLdapErro
     [Ldap.SearchEntry _ attrs] -> return attrs
     _otherwise -> throwM CampusUserAmbiguous
   
-campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
+campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
 campusUserMatr' pool mode
   = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
 

src/Jobs/HealthReport.hs

@@ -103,10 +103,10 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea
         return $ user E.^. UserIdent
       for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
         let numAdmins = genericLength ldapAdminUsers
-            hCampusExc :: CampusUserException -> Handler (Sum Integer)
+        Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) ->
-            hCampusExc _ = return $ Sum 0
+          let hCampusExc :: CampusUserException -> Handler (Sum Integer)
-        Sum numResolved <- fmap fold . forM ldapAdminUsers $
+              hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err)
-          \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
+           in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
         return $ numResolved % numAdmins
     _other -> return Nothing
 

src/Ldap/Client/Pool.hs

@@ -51,10 +51,10 @@ data LdapPoolError = LdapPoolTimeout
 withLdap :: (MonadUnliftIO m, MonadCatch m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
 withLdap pool act = fmap join . try . withResource pool $ \LdapExecutor{..} -> ldapExec act
 
-withLdapFailover :: (MonadUnliftIO m, MonadCatch m, Typeable a) => Lens p p' LdapPool Ldap -> Failover p -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
+withLdapFailover :: (MonadUnliftIO m, MonadMask m, Typeable a, MonadLogger m) => Lens p p' LdapPool Ldap -> Failover p -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
 withLdapFailover l@(flip withLens const -> proj) pool' mode act = try . withFailover pool' mode (either throwE return) $ \x -> withLdap (proj x) (\c -> act $ x & l .~ c)
 
-withLdapFailoverReTest :: (MonadUnliftIO m, MonadCatch m, Typeable a) => Lens p p' LdapPool Ldap -> Failover p -> (Nano -> Bool) -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
+withLdapFailoverReTest :: (MonadUnliftIO m, MonadMask m, Typeable a, MonadLogger m) => Lens p p' LdapPool Ldap -> Failover p -> (Nano -> Bool) -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
 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)
 
 
@@ -79,17 +79,18 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
 
       let
         ldapExec :: forall a m'. (Typeable a, MonadUnliftIO m') => (Ldap -> m' a) -> m' (Either LdapPoolError a)
-        ldapExec act = withRunInIO $ \runInIO -> do
+        ldapExec act = withRunInIO $ \runInIO -> convertErrors' . withTimeout $ do
           ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
           atomically $ putTMVar ldapAct (runInIO . fmap toDyn . act, ldapAnswer)
           either throwIO (return . Right . flip fromDyn (error "Could not cast dynamic")) =<< atomically (takeTMVar ldapAnswer)
-          `catches`
+          where
-          [ Handler $ return . Left . LdapError . Ldap.ParseError
+            convertErrors' = flip catches
-          , Handler $ return . Left . LdapError . Ldap.ResponseError
+              [ Handler $ return . Left . LdapError . Ldap.ParseError
-          , Handler $ return . Left . LdapError . Ldap.IOError
+              , Handler $ return . Left . LdapError . Ldap.ResponseError
-          , Handler $ return . Left . LdapError . Ldap.DisconnectError
+              , Handler $ return . Left . LdapError . Ldap.IOError
-          , Handler $ return . Left . (id :: LdapPoolError -> LdapPoolError)
+              , Handler $ return . Left . LdapError . Ldap.DisconnectError
-          ]
+              , Handler $ return . Left . (id :: LdapPoolError -> LdapPoolError)
+              ]
 
         go :: Maybe (TMVar (Maybe a)) -> Ldap -> m ()
         go waiting ldap = do

src/Utils/Failover.hs

@@ -1,16 +1,21 @@
 module Utils.Failover
-  ( Failover
+  ( Failover, failoverLabels
-  , mkFailover
+  , mkFailover, mkFailoverLabeled
   , FailoverMode(..)
+  , FailoverException(..)
   , withFailover, withFailoverReTest
+  , FailoverMetrics, registerFailoverMetrics
   ) where
 
-import ClassyPrelude hiding (try)
+import ClassyPrelude hiding (try, Vector, finally, onException)
-import Utils (foldMapM)
 
 import Data.List.PointedList (PointedList)
 import qualified Data.List.PointedList as P
 
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.Monoid (Endo(..))
+
 import Numeric.Natural
 
 import System.Clock
@@ -18,23 +23,28 @@ import System.Clock
 import Control.Lens hiding (failover)
 import Utils.Lens.TH
 
-import Data.List (unfoldr, genericTake)
-
 import Control.Monad.Catch
 import Control.Monad.Trans.Except (ExceptT, runExceptT)
-import Control.Monad.Trans.Cont (runContT)
+import Control.Monad.State.Strict (runState)
-import Control.Monad.Cont.Class (MonadCont(..))
+import Control.Monad.Logger
 
 import Control.Concurrent.STM.TVar (stateTVar)
 
-import Data.Void (vacuous)
-
 import Data.Fixed
 
+import Data.Time.Clock.POSIX
+import Prometheus
+
+import qualified Data.Foldable as F
+
+import Data.Unique
+
 
 data FailoverItem a = FailoverItem
-  { failoverValue :: a
+  { failoverValue      :: a
-  , failoverLastTest :: Maybe TimeSpec
+  , failoverLabel      :: Text
+  , failoverLastTest   :: Maybe TimeSpec
+  , failoverReferences :: Set Unique
   }
 makeLenses_ ''FailoverItem
 
@@ -47,86 +57,183 @@ data FailoverMode
   | FailoverNone
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
+data FailoverException
+  = FailoverNoItemsAvailable
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Exception)
+
+failoverLabels :: MonadIO m => Failover a -> m [Text]
+failoverLabels Failover{..} = do
+  items <- readTVarIO failover
+  return $ items ^.. folded . _failoverLabel
+
 
 mkFailover :: MonadIO m
            => PointedList a
            -> m (Failover a)
 mkFailover opts = fmap Failover . liftIO $ newTVarIO opts'
-  where opts' = opts <&> \failoverValue -> FailoverItem{ failoverLastTest = Nothing, .. } 
+  where opts' = flip (iover $ indexing traverse) opts $ \i failoverValue -> FailoverItem{ failoverLabel = tshow i, failoverLastTest = Nothing, failoverReferences = Set.empty, .. } 
+
+mkFailoverLabeled :: MonadIO m
+                  => PointedList (Text, a)
+                  -> m (Failover a)
+mkFailoverLabeled opts = fmap Failover . liftIO $ newTVarIO opts'
+  where opts' = flip map opts $ \(failoverLabel, failoverValue) -> FailoverItem{ failoverLastTest = Nothing, failoverReferences = Set.empty, .. }
 
 
-withFailover :: ( MonadIO m, MonadCatch m
+withFailoverReference :: (MonadIO m, MonadMask m)
+                      => Failover a
+                      -> (Unique -> m b)
+                      -> m b
+withFailoverReference Failover{..} cont = do
+  ref <- liftIO newUnique
+  finally (cont ref) $ 
+    atomically . modifyTVar failover $ traverse . _failoverReferences %~ Set.delete ref
+
+
+withFailover :: ( MonadIO m, MonadMask m
                 , Exception e
+                , MonadLogger m
                 )
              => Failover a
              -> FailoverMode
              -> (b -> ExceptT e m c)
              -> (a -> m b)
              -> m c
-withFailover f@Failover{..} mode detAcceptable act = do
+withFailover = withFailover' $ const P.focus
-  now <- liftIO $ getTime Monotonic
-  
-  FailoverItem{failoverValue} <- fmap (view P.focus) . liftIO $ readTVarIO failover
-  
-  res <- act failoverValue
-  res' <- runExceptT $ detAcceptable res
-  
-  let
-    recordFailure =
-        atomically . stateTVar failover $ \failover' -> case P.next $ failover' & P.focus . _failoverLastTest ?~ now of
-          Just failover'' -> (True, failover'')
-          Nothing -> (False, failover')
-    doRetry err = do
-        didNext <- recordFailure
-        let newMode = case mode of
-              FailoverLimited n -> FailoverLimited $ pred n
-              other -> other
-        if | didNext   -> withFailover f newMode detAcceptable act
-           | otherwise -> throwM err
-        
-  case (res', mode) of
-    (Left  err  , FailoverUnlimited)
-      -> doRetry err
-    (Left  err  , FailoverLimited n) | n > 0
-      -> doRetry err
-    (Left  err  , _)
-      -> void recordFailure >> throwM err
-    (Right res'', _)
-      -> return res''
 
-withFailoverReTest :: ( MonadIO m, MonadCatch m
+withFailoverReTest :: forall m a b c e.
-                      , Exception e
+                 ( MonadIO m, MonadMask m
-                      )
+                 , Exception e
-                   => Failover a
+                 , MonadLogger m
-                   -> (Nano -> Bool)
+                 )
-                   -> FailoverMode
+              => Failover a
-                   -> (b -> ExceptT e m c)
+              -> (Nano -> Bool)
-                   -> (a -> m b)
+              -> FailoverMode
-                   -> m c
+              -> (b -> ExceptT e m c)
-withFailoverReTest f@Failover{..} doTest mode detAcceptable act = do
+              -> (a -> m b)
-  now <- liftIO $ getTime Monotonic
+              -> m c
+withFailoverReTest f doTest = withFailover' testTargets f
+  where
+    testTargets :: TimeSpec -> Traversal' (PointedList (FailoverItem a)) (FailoverItem a)
+    testTargets now = failing (P.prefix . traverse . filtered shouldTest) P.focus
+      where shouldTest FailoverItem{failoverLastTest}
+              = maybe True (\lT -> doTest . MkFixed . toNanoSecs $ now - lT) failoverLastTest
 
-  let filterFailover = filter $ \(view $ _2 . P.focus -> FailoverItem{failoverLastTest}) -> maybe True (\lT -> doTest . MkFixed . toNanoSecs $ now - lT) failoverLastTest
+withFailover' :: forall m a b c e.
-  
+                 ( MonadIO m, MonadMask m
-  failover' <- fmap (reverse . filterFailover . unfoldr (\(i, l) -> ((i, ) &&& (succ i, )) <$> P.previous l) . (0,)) . liftIO $ readTVarIO failover
+                 , Exception e
+                 , MonadLogger m
+                 )
+              => (TimeSpec -> Traversal' (PointedList (FailoverItem a)) (FailoverItem a))
+              -> Failover a
+              -> FailoverMode
+              -> (b -> ExceptT e m c)
+              -> (a -> m b)
+              -> m c
+withFailover' testTarget' f@Failover{..} mode detAcceptable act = withFailoverReference f $ \alreadyTested ->
+  let loop pErr mode' = withFailoverReference f $ \currentlyTesting -> do
+        now <- liftIO $ getTime Monotonic
 
-  let failover'' = case mode of
+        FailoverItem{failoverLabel, failoverValue} <- maybe (maybe (throwM FailoverNoItemsAvailable) throwM pErr) return <=< atomically $
-        FailoverUnlimited -> failover'
+          stateTVar failover . runState $ do
-        FailoverLimited n -> genericTake (succ n) failover'
+            let testTarget :: Traversal' (PointedList (FailoverItem a)) (FailoverItem a)
-        FailoverNone      -> take 1 failover'
+                testTarget = taking 1 $ testTarget' now . filtered (views _failoverReferences $ Set.notMember alreadyTested)
+            testTarget . _failoverReferences %= Set.insert currentlyTesting
+            testTarget . _failoverLastTest %= Just . maybe now (max now)
+            tgt <- preuse testTarget
+            testTarget . _failoverReferences %= Set.insert alreadyTested
+            return tgt
 
-  reTestRes <- flip runContT return . callCC $ \((. Just) -> retRes) -> fmap vacuous . flip foldMapM failover'' $ \failover'''@(over _2 (view P.focus) -> (i, FailoverItem{failoverValue})) -> do
+        let
-    res <- lift $ act failoverValue
+          recordFailure = do
-    res' <- lift . runExceptT $ detAcceptable res
+            $logErrorS "withFailover'" $ tshow (hashUnique alreadyTested) <> " recording failure for item " <> failoverLabel
+            atomically . modifyTVar failover $ \failover' -> if
+              | views (P.focus . _failoverReferences) (Set.member currentlyTesting) failover'
+                -> case P.next failover' of
+                     Just failover'' -> failover''
+                     Nothing -> failover'
+              | otherwise
+                -> failover'
 
-    case res' of
+        $logDebugS "withFailover'" $ tshow (hashUnique alreadyTested) <> " using item " <> failoverLabel
-      Left _ -> do
+        res' <- handleAll (\err -> $logErrorS "withFailover'" (tshow (hashUnique alreadyTested) <> " exception during act or detAcceptable: " <> tshow err) >> recordFailure >> throwM err) $
-        atomically . modifyTVar failover $ P.reversedPrefix . ix i . _failoverLastTest ?~ now
+          runExceptT . detAcceptable =<< act failoverValue
-        return Nothing
+        case res' of
-      Right res'' -> do
+          Right _  -> $logDebugS "withFailover'" $ tshow (hashUnique alreadyTested) <> " used item " <> failoverLabel <> " successfully"
-        atomically . writeTVar failover $ view _2 failover''' & P.focus . _failoverLastTest ?~ now
+          Left err -> $logErrorS "withFailover'" $ tshow (hashUnique alreadyTested) <> " used item " <> failoverLabel <> ", " <> tshow mode' <> ": " <> tshow err
-        retRes res''
 
-  case reTestRes of
+        let
-    Nothing -> withFailover f mode detAcceptable act
+          recordSuccess = do
-    Just r  -> return r
+            $logDebugS "withFailover'" $ tshow (hashUnique alreadyTested) <> " recording success for item " <> failoverLabel
+            didRecord <- atomically . stateTVar failover $ \failover' -> if
+              | (newPrefix, newFocus : newSuffix) <- break (views _failoverReferences $ Set.member currentlyTesting) $ failover' ^. P.prefix
+                -> ( True
+                   , P.singleton newFocus
+                       & P.prefix .~ newPrefix
+                       & P.suffix .~ newSuffix ++ (view P.focus failover' : view P.suffix failover')
+                   )
+              | otherwise
+                -> ( False, failover' )
+            when didRecord $
+              $logInfoS "withFailover'" $ tshow (hashUnique alreadyTested) <> " recorded success for item " <> failoverLabel
+          doRetry err = do
+            recordFailure
+            case mode' of
+              FailoverUnlimited -> loop (Just err) FailoverUnlimited
+              FailoverLimited n | n > 0 -> loop (Just err) . FailoverLimited $ pred n
+              _other -> throwM err
+
+        case (res', mode') of
+          (Left  err  , FailoverUnlimited)
+            -> doRetry err
+          (Left  err  , FailoverLimited n) | n > 0
+            -> doRetry err
+          (Left  err  , _)
+            -> recordFailure >> throwM err
+          (Right res'', _)
+            -> res'' <$ recordSuccess
+   in loop Nothing mode
+
+
+data FailoverMetrics = forall a. FailoverMetrics
+  { failoverMetricsFailover :: Failover a
+  , failoverMetricsLabelsSeen :: TVar (Map Text (Maybe TimeSpec))
+  }
+
+failoverMetrics :: Text -> Failover a -> Metric FailoverMetrics
+failoverMetrics fLbl failoverMetricsFailover@Failover{..} = Metric $ do
+  failoverMetricsLabelsSeen <- atomically $ do
+    foState <- readTVar failover
+    newTVar . Map.fromList $ [ (failoverLabel, failoverLastTest) | FailoverItem{..} <- F.toList foState ]
+  return (FailoverMetrics{..}, collectFailoverMetrics failoverMetricsLabelsSeen)
+  where
+    collectFailoverMetrics labelsSeen = do
+      now <- liftIO $ getTime Monotonic
+      cTime <- liftIO getPOSIXTime
+
+      metrics <- atomically $ do
+        foState <- readTVar failover
+        labelsSeen' <- stateTVar labelsSeen $ \labelsSeen' -> labelsSeen'
+          & ala Endo foldMap [ Map.insert failoverLabel failoverLastTest | FailoverItem{..} <- F.toList foState ]
+          & (id &&& id)
+        return
+          [ SampleGroup failoverActiveInfo GaugeType
+            [ Sample "uni2work_failover_active_bool" [("failover", fLbl), ("label", lbl)] . bool "0" "1" $ views (P.focus . _failoverLabel) (== lbl) foState
+            | (lbl, _) <- Map.toList labelsSeen'
+            ]
+          , SampleGroup failoverLastTestInfo GaugeType
+            [ Sample "uni2work_failover_last_test_time" [("failover", fLbl), ("label", lbl)] . encodeUtf8 . tshow $ realToFrac cTime - (MkFixed . toNanoSecs $ now - lastTest :: Nano)
+            | (lbl, Just lastTest) <- Map.toList labelsSeen'
+            ]
+          ]
+
+      return metrics
+
+    failoverActiveInfo = Info "uni2work_failover_active_bool"
+                              "Currently active item in the failover set"
+    failoverLastTestInfo = Info "uni2work_failover_last_test_time"
+                                "Time of last attempt to use failover item"
+
+registerFailoverMetrics :: MonadIO m => Text -> Failover a -> m ()
+registerFailoverMetrics fLbl = void . register . failoverMetrics fLbl