From 0c7e56f4054593eef757dffba49fdc27f7b060df Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 21 Jul 2020 16:57:38 +0200 Subject: [PATCH] feat(metrics): observe login attempts --- src/Auth/Dummy.hs | 4 +++- src/Auth/LDAP.hs | 15 ++++++++++----- src/Auth/PWHash.hs | 7 +++++-- src/Utils/Metrics.hs | 22 ++++++++++++++++++++++ 4 files changed, 40 insertions(+), 8 deletions(-) diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index c433cae8a..a1cd8ad3b 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -6,6 +6,7 @@ module Auth.Dummy import Import.NoFoundation import Database.Persist.Sql (SqlBackendCanRead) +import Utils.Metrics import Utils.Form import qualified Data.CaseInsensitive as CI @@ -56,7 +57,8 @@ dummyLogin = AuthPlugin{..} FormMissing -> do addMessageI Warning MsgDummyNoFormData redirect $ tp LoginR - FormSuccess ident -> + FormSuccess ident -> do + observeLoginOutcome apName LoginSuccessful setCredsRedirect $ Creds apName (CI.original ident) [] apDispatch _ [] = badMethod apDispatch _ _ = notFound diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 9bb6c70d3..0e52e4f13 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -16,6 +16,7 @@ import Import.NoFoundation import qualified Data.CaseInsensitive as CI +import Utils.Metrics import Utils.Form import qualified Ldap.Client as Ldap @@ -196,15 +197,19 @@ campusLogin pool mode = AuthPlugin{..} Left err | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err -> do - $logDebugS "LDAP" "Invalid credentials" + $logDebugS apName "Invalid credentials" + observeLoginOutcome apName LoginInvalidCredentials loginErrorMessageI LoginR Msg.InvalidLogin | otherwise -> do - $logErrorS "LDAP" $ "Error during login: " <> tshow err + $logErrorS apName $ "Error during login: " <> tshow err + observeLoginOutcome apName LoginError loginErrorMessageI LoginR Msg.AuthError - Right (Right (userDN, credsIdent)) -> + Right (Right (userDN, credsIdent)) -> do + observeLoginOutcome apName LoginSuccessful setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] Right (Left searchResults) -> do - $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults + $logWarnS apName $ "Could not extract principal name: " <> tshow searchResults + observeLoginOutcome apName LoginError loginErrorMessageI LoginR Msg.AuthError maybe (redirect $ tp LoginR) return resp @@ -216,7 +221,7 @@ campusLogin pool mode = AuthPlugin{..} (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm let loginForm = wrapForm login FormSettings { formMethod = POST - , formAction = Just . SomeRoute . toMaster $ PluginR "LDAP" [] + , formAction = Just . SomeRoute . toMaster $ PluginR apName [] , formEncoding = loginEnctype , formAttrs = [("uw-no-navigate-away-prompt","")] , formSubmit = FormSubmit diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index da0b94f22..c5c7d53a8 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -6,6 +6,7 @@ module Auth.PWHash import Import.NoFoundation import Database.Persist.Sql (SqlBackendCanRead) +import Utils.Metrics import Utils.Form import qualified Data.CaseInsensitive as CI @@ -63,10 +64,12 @@ hashLogin pwHashAlgo = AuthPlugin{..} user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent case user of Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent }) - | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic. + | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> do -- (2^) is magic. + observeLoginOutcome apName LoginSuccessful setCredsRedirect $ Creds apName userIdent [] other -> do - $logDebugS "PWHash" $ tshow other + $logDebugS apName $ tshow other + observeLoginOutcome apName LoginInvalidCredentials loginErrorMessageI LoginR Msg.InvalidLogin maybe (redirect $ tp LoginR) return resp diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 7509c83fd..f4d942b1d 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -6,6 +6,7 @@ module Utils.Metrics , withJobWorkerStateLbls , observeYesodCacheSize , observeFavouritesQuickActionsDuration + , LoginOutcome(..), observeLoginOutcome ) where import Import.NoFoundation hiding (Vector, Info) @@ -100,6 +101,12 @@ favouritesQuickActionsDuration = unsafeRegister $ histogram info buckets "Duration of time needed to calculate a set of favourite quick actions" buckets = histogramBuckets 500e-6 50 +{-# NOINLINE loginOutcomes #-} +loginOutcomes :: Vector Label2 Counter +loginOutcomes = unsafeRegister . vector ("plugin", "outcome") $ counter info + where info = Info "uni2work_login_attempts_total" + "Number of login attempts" + withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics act = do @@ -171,3 +178,18 @@ observeFavouritesQuickActionsDuration act = do liftIO . observe favouritesQuickActionsDuration . realToFrac $ end - start either throwM return res + +data LoginOutcome + = LoginSuccessful + | LoginInvalidCredentials + | LoginError + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +nullaryPathPiece ''LoginOutcome $ camelToPathPiece' 1 + +observeLoginOutcome :: MonadHandler m + => Text -- ^ Plugin + -> LoginOutcome + -> m () +observeLoginOutcome plugin outcome + = liftIO $ withLabel loginOutcomes (plugin, toPathPiece outcome) incCounter