feat(metrics): observe login attempts

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

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

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

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