feat(ldap): expose active directory errors

messages/uniworx/de-de-formal.msg

@@ -2880,4 +2880,16 @@ SystemExamOffice: Prüfungsverwaltung
 SystemFaculty: Fakultätsmitglied
 
 ChangelogItemFeature: Feature
-ChangelogItemBugfix: Bugfix
+ChangelogItemBugfix: Bugfix
+
+InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht
+InvalidCredentialsADLogonFailure: Ungültiges Passwort
+InvalidCredentialsADAccountRestriction: Kontobeschränkungen verhindern Login
+InvalidCredentialsADInvalidLogonHours: Benutzer darf sich zur aktuellen Tageszeit nicht anmelden
+InvalidCredentialsADInvalidWorkstation: Benutzer darf sich von diesem System aus nicht anmelden
+InvalidCredentialsADPasswordExpired: Passwort abgelaufen
+InvalidCredentialsADAccountDisabled: Benutzereintrag gesperrt
+InvalidCredentialsADTooManyContextIds: Benutzereintrag trägt zu viele Sicherheitskennzeichen
+InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen
+InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden
+InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt

messages/uniworx/en-eu.msg

@@ -2883,3 +2883,15 @@ SystemFaculty: Faculty member
 
 ChangelogItemFeature: Feature
 ChangelogItemBugfix: Bugfix
+
+InvalidCredentialsADNoSuchObject: User entry does not exist
+InvalidCredentialsADLogonFailure: Invalid passwod
+InvalidCredentialsADAccountRestriction: Account restrictions are preventing login
+InvalidCredentialsADInvalidLogonHours: User may not login at the current time of day
+InvalidCredentialsADInvalidWorkstation: User may not login from this system
+InvalidCredentialsADPasswordExpired: Password expired
+InvalidCredentialsADAccountDisabled: Account disabled
+InvalidCredentialsADTooManyContextIds: Account carries to many security identifiers
+InvalidCredentialsADAccountExpired: Account expired
+InvalidCredentialsADPasswordMustChange: Password needs to be changed
+InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection

package.yaml

@@ -70,6 +70,7 @@ dependencies:
   - blaze-html
   - conduit-resumablesink >=0.2
   - parsec
+  - parsec-numbers
   - attoparsec
   - uuid
   - exceptions

src/Auth/LDAP.hs

@@ -1,5 +1,6 @@
 module Auth.LDAP
   ( apLdap
+  , ADError(..), ADInvalidCredentials(..)
   , campusLogin
   , CampusUserException(..)
   , campusUser, campusUser'
@@ -26,6 +27,8 @@ import qualified Data.Text.Encoding as Text
 
 import qualified Yesod.Auth.Message as Msg
 
+import Auth.LDAP.AD
+
 
 data CampusLogin = CampusLogin
   { campusIdent :: CI Text
@@ -155,6 +158,13 @@ campusUserMatr' pool mode
 
 
 
+newtype ADInvalidCredentials = ADInvalidCredentials ADError
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+isUnusualADError :: ADError -> Bool
+isUnusualADError = flip notElem [ADNoSuchObject, ADLogonFailure]
+
+  
 campusForm :: ( RenderMessage (HandlerSite m) FormMessage
               , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
               , RenderMessage (HandlerSite m) CampusMessage
@@ -174,6 +184,7 @@ campusLogin :: forall site.
                , RenderMessage site CampusMessage
                , RenderMessage site AFormMessage
                , RenderMessage site (ValueRequired site)
+               , RenderMessage site ADInvalidCredentials
                , Button site ButtonSubmit
                ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
 campusLogin pool mode = AuthPlugin{..}
@@ -203,6 +214,14 @@ campusLogin pool mode = AuthPlugin{..}
             $logErrorS apName $ "Error during login: " <> tshow err
             observeLoginOutcome apName LoginError
             loginErrorMessageI LoginR Msg.AuthError
+          Right (Left (Ldap.ResponseErrorCode _ errCode _ errTxt))
+            | Right adError <- parseADError errCode errTxt
+            , isUnusualADError adError -> do
+                $logInfoS apName [st|#{campusIdent}: #{toPathPiece adError}|]
+                observeLoginOutcome apName LoginADInvalidCredentials
+                setSessionJson SessionError . InternalError $ toPathPiece adError
+                MsgRenderer mr <- liftHandler getMsgRenderer
+                loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError
           Right (Left bindErr) -> do
             case bindErr of
               Ldap.ResponseErrorCode _ _ _ errTxt -> 

src/Auth/LDAP/AD.hs

@@ -0,0 +1,76 @@
+module Auth.LDAP.AD
+  ( ADError(..)
+  , parseADError
+  ) where
+
+import Import.NoFoundation hiding (try)
+
+import Model.Types.TH.PathPiece
+
+import qualified Data.IntMap.Strict as IntMap
+import qualified Data.Map.Strict as Map
+
+import Text.Parsec hiding ((<|>))
+import Text.Parsec.String
+import Text.ParserCombinators.Parsec.Number (hexnum)
+
+import Ldap.Client (ResultCode(..))
+
+
+-- | Copied from <https://ldapwiki.com/wiki/Common%20Active%20Directory%20Bind%20Errors>
+data ADError
+  = ADNoSuchObject
+  | ADLogonFailure
+  | ADAccountRestriction
+  | ADInvalidLogonHours
+  | ADInvalidWorkstation
+  | ADPasswordExpired
+  | ADAccountDisabled
+  | ADTooManyContextIds
+  | ADAccountExpired
+  | ADPasswordMustChange
+  | ADAccountLockedOut
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''ADError $ camelToPathPiece' 1
+pathPieceJSON ''ADError
+pathPieceJSONKey ''ADError
+derivePersistFieldPathPiece ''ADError
+
+
+fromADErrorCode :: ResultCode -> Word32 -> Maybe ADError
+fromADErrorCode resCode subResCode = IntMap.lookup (fromIntegral subResCode) =<< Map.lookup resCode errorCodes
+  where
+    errorCodes = Map.fromList
+      [ ( InvalidCredentials
+        , IntMap.fromList
+            [ ( 0x525,      ADNoSuchObject       )
+            , ( 0x52e,      ADLogonFailure       )
+            , ( 0x52f,      ADAccountRestriction )
+            , ( 0x530,      ADInvalidLogonHours  )
+            , ( 0x531,      ADInvalidWorkstation )
+            , ( 0x532,      ADPasswordExpired    )
+            , ( 0x533,      ADAccountDisabled    )
+            , ( 0x568,      ADTooManyContextIds  )
+            , ( 0x701,      ADAccountExpired     )
+            , ( 0x773,      ADPasswordMustChange )
+            , ( 0x775,      ADAccountLockedOut   )
+            , ( 0x80090346, ADAccountLockedOut   )
+            ]
+        )
+      ]
+
+parseADError :: ResultCode -> Text -> Either ParseError ADError
+parseADError resCode = parse (pADError resCode <* eof) "LDAP" . unpack
+
+pADError :: ResultCode -> Parser ADError
+pADError resCode = do
+  void . manyTill anyChar . try $ string ": "
+  let pItem = asum
+        [ do
+            void $ string "data "
+            fmap Just $ hexnum >>= hoistMaybe . fromADErrorCode resCode
+        , Nothing <$ manyTill anyChar (lookAhead . try $ void (string ", ") <|> eof)
+        ]
+  (hoistMaybe =<<) $ ala First foldMap <$> pItem `sepBy1` try (string ", ")

src/Foundation/I18n.hs

@@ -231,6 +231,8 @@ embedRenderMessage ''UniWorX ''AuthenticationMode id
 
 embedRenderMessage ''UniWorX ''RatingValidityException id
 
+embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" <>)
+
 newtype ShortSex = ShortSex Sex
 embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
 

src/Import/NoModel.hs

@@ -175,6 +175,7 @@ import Data.Word.Word24.Instances as Import ()
 import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)
 import Database.Persist.Sql.Types.Instances as Import ()
 import Control.Monad.Catch.Instances as Import ()
+import Ldap.Client.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
 import Crypto.Random as Import (ChaChaDRG, Seed)

src/Ldap/Client/Instances.hs

@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Ldap.Client.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Ldap.Client
+
+
+deriving instance Ord ResultCode

src/Utils/Metrics.hs

@@ -305,6 +305,7 @@ observeFavouritesQuickActionsDuration act = do
 data LoginOutcome
   = LoginSuccessful
   | LoginInvalidCredentials
+  | LoginADInvalidCredentials
   | LoginError
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
   deriving anyclass (Universe, Finite)

templates/i18n/changelog/ldap-ad-errors.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Bessere Fehlermeldungen bei fehlgeschlagenem Login

templates/i18n/changelog/ldap-ad-errors.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Better error messages on failed login

test/Auth/LDAP/ADSpec.hs

@@ -0,0 +1,18 @@
+module Auth.LDAP.ADSpec where
+
+import TestImport
+
+import Auth.LDAP.AD
+import Ldap.Client
+
+
+spec :: Spec
+spec = do
+  describe "parseADError" $ do
+    it "parses some examples" . mapM_ exampleEntry $
+      [ ( InvalidCredentials, ADAccountDisabled, "80090308: LdapErr: DSID-0C090446, comment: AcceptSecurityContext error, data 533, v2580")
+      , ( InvalidCredentials, ADLogonFailure   , "80090308: LdapErr: DSID-0C090446, comment: AcceptSecurityContext error, data 52e, v2580")
+      ]
+
+exampleEntry :: ( ResultCode, ADError, Text ) -> Expectation
+exampleEntry ( resCode, adError, errMsg ) = example $ parseADError resCode errMsg `shouldBe` Right adError