diff --git a/.hlint.yaml b/.hlint.yaml index 7f5b23d47..6a77d647a 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -10,6 +10,7 @@ - ignore: { name: "Use &&" } - ignore: { name: "Use ++" } - ignore: { name: "Use ***" } + - ignore: { name: "Redundant void" } - arguments: - -XQuasiQuotes diff --git a/src/Application.hs b/src/Application.hs index 49a6ae0a9..c1080b99f 100644 --- a/src/Application.hs +++ b/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 - $logDebugS "setup" $ "LDAP-Pool " <> tshow ldapHost - (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) + ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do + let ldapLabel = case ldapHost of + 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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index e4f8bbfdd..9bb6c70d3 100644 --- a/src/Auth/LDAP.hs +++ b/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 [])) - -> IO (Either LdapPoolError (Ldap.AttrList [])) + -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) + -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) ) -> Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site - -> m (Ldap.AttrList []) -campusUserWith withLdap' pool mode Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do - Ldap.bind ldap ldapDn ldapPassword + -> m (Either CampusUserException (Ldap.AttrList [])) +campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do + 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 pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool +campusUserReTest :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) +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 = campusUserWith withLdapFailover +campusUser :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) +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 pool mode userMatr = liftIO $ either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do +campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList []) +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 diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index 64d90d692..2a96f5096 100644 --- a/src/Jobs/HealthReport.hs +++ b/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) - hCampusExc _ = return $ Sum 0 - Sum numResolved <- fmap fold . forM ldapAdminUsers $ - \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent []) + Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) -> + let hCampusExc :: CampusUserException -> Handler (Sum Integer) + hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err) + in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent []) return $ numResolved % numAdmins _other -> return Nothing diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index eced26712..d14289125 100644 --- a/src/Ldap/Client/Pool.hs +++ b/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` - [ 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) - ] + where + convertErrors' = flip catches + [ 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 -> m () go waiting ldap = do diff --git a/src/Utils/Failover.hs b/src/Utils/Failover.hs index e461340a1..76e616da9 100644 --- a/src/Utils/Failover.hs +++ b/src/Utils/Failover.hs @@ -1,16 +1,21 @@ module Utils.Failover - ( Failover - , mkFailover + ( Failover, failoverLabels + , mkFailover, mkFailoverLabeled , FailoverMode(..) + , FailoverException(..) , withFailover, withFailoverReTest + , FailoverMetrics, registerFailoverMetrics ) where -import ClassyPrelude hiding (try) -import Utils (foldMapM) +import ClassyPrelude hiding (try, Vector, finally, onException) 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.Cont.Class (MonadCont(..)) +import Control.Monad.State.Strict (runState) +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 - , failoverLastTest :: Maybe TimeSpec + { failoverValue :: a + , 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 - 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'' +withFailover = withFailover' $ const P.focus -withFailoverReTest :: ( MonadIO m, MonadCatch m - , Exception e - ) - => Failover a - -> (Nano -> Bool) - -> FailoverMode - -> (b -> ExceptT e m c) - -> (a -> m b) - -> m c -withFailoverReTest f@Failover{..} doTest mode detAcceptable act = do - now <- liftIO $ getTime Monotonic +withFailoverReTest :: forall m a b c e. + ( MonadIO m, MonadMask m + , Exception e + , MonadLogger m + ) + => Failover a + -> (Nano -> Bool) + -> FailoverMode + -> (b -> ExceptT e m c) + -> (a -> m b) + -> 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 - - failover' <- fmap (reverse . filterFailover . unfoldr (\(i, l) -> ((i, ) &&& (succ i, )) <$> P.previous l) . (0,)) . liftIO $ readTVarIO failover +withFailover' :: forall m a b c e. + ( MonadIO m, MonadMask m + , 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 - FailoverUnlimited -> failover' - FailoverLimited n -> genericTake (succ n) failover' - FailoverNone -> take 1 failover' + FailoverItem{failoverLabel, failoverValue} <- maybe (maybe (throwM FailoverNoItemsAvailable) throwM pErr) return <=< atomically $ + stateTVar failover . runState $ do + let testTarget :: Traversal' (PointedList (FailoverItem a)) (FailoverItem a) + 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 - res <- lift $ act failoverValue - res' <- lift . runExceptT $ detAcceptable res + let + recordFailure = do + $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 - Left _ -> do - atomically . modifyTVar failover $ P.reversedPrefix . ix i . _failoverLastTest ?~ now - return Nothing - Right res'' -> do - atomically . writeTVar failover $ view _2 failover''' & P.focus . _failoverLastTest ?~ now - retRes res'' + $logDebugS "withFailover'" $ tshow (hashUnique alreadyTested) <> " using item " <> failoverLabel + res' <- handleAll (\err -> $logErrorS "withFailover'" (tshow (hashUnique alreadyTested) <> " exception during act or detAcceptable: " <> tshow err) >> recordFailure >> throwM err) $ + runExceptT . detAcceptable =<< act failoverValue + case res' of + Right _ -> $logDebugS "withFailover'" $ tshow (hashUnique alreadyTested) <> " used item " <> failoverLabel <> " successfully" + Left err -> $logErrorS "withFailover'" $ tshow (hashUnique alreadyTested) <> " used item " <> failoverLabel <> ", " <> tshow mode' <> ": " <> tshow err - case reTestRes of - Nothing -> withFailover f mode detAcceptable act - Just r -> return r + let + recordSuccess = do + $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