fix(ldap-failover): improve concurrency & error handling
This commit is contained in:
Gregor Kleen
parent
a3c1c20567
commit
da1bf86d5e
@ -10,6 +10,7 @@
|
||||
- ignore: { name: "Use &&" }
|
||||
- ignore: { name: "Use ++" }
|
||||
- ignore: { name: "Use ***" }
|
||||
- ignore: { name: "Redundant void" }
|
||||
|
||||
- arguments:
|
||||
- -XQuasiQuotes
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user