-- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} module Auth.LDAP ( apLdap , ADError(..), ADInvalidCredentials(..) , campusLogin , CampusUserException(..) , campusUser, campusUser', campusUser'' , campusUserReTest, campusUserReTest' , campusUserMatr, campusUserMatr' , CampusMessage(..) , ldapPrimaryKey , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserFirstName, ldapUserSurname , ldapAffiliation , ldapUserMobile, ldapUserTelephone , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung , ldapUserTitle ) where import Import.NoFoundation import qualified Data.CaseInsensitive as CI import Utils.Metrics import Utils.Form import qualified Ldap.Client as Ldap import qualified Data.Text.Encoding as Text import qualified Yesod.Auth.Message as Msg import Auth.LDAP.AD -- allow Ldap.Attr usage as key for Data.Map deriving newtype instance Ord Ldap.Attr data CampusLogin = CampusLogin { campusIdent :: CI Text , campusPassword :: Text } deriving (Generic, Typeable) data CampusMessage = MsgCampusIdentPlaceholder | MsgCampusIdent | MsgCampusPassword | MsgCampusPasswordPlaceholder deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters where userFilters = [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@fraport.de|] ] ++ [ ldapUserEmail' Ldap.:= Text.encodeUtf8 ident' | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@fraport.de|]] , ldapUserEmail' <- toList ldapUserEmail -- ] ++ -- [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident -- for Fraport, userDisplayName has the pattern "Surname, Firstnames" ] ++ [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident ] findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters where userFilters = [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr ] userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search userSearchSettings LdapConf{..} = mconcat [ Ldap.scope ldapScope , Ldap.size 2 , Ldap.time ldapSearchTimeout , Ldap.derefAliases Ldap.DerefAlways ] ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone, ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr ldapPrimaryKey = Ldap.Attr "cn" -- should always be identical to "sAMAccountName" ldapUserPrincipalName = Ldap.Attr "userPrincipalName" ldapUserDisplayName = Ldap.Attr "displayName" ldapUserFirstName = Ldap.Attr "givenName" ldapUserSurname = Ldap.Attr "sn" ldapAffiliation = Ldap.Attr "memberOf" -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions ldapUserTitle = Ldap.Attr "title" -- not used at Fraport -- new ldapUserTelephone = Ldap.Attr "telephoneNumber" ldapUserMobile = Ldap.Attr "mobile" ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName" ldapUserFraportAbteilung = Ldap.Attr "department" ldapUserEmail :: NonEmpty Ldap.Attr ldapUserEmail = Ldap.Attr "mail" :| [ Ldap.Attr "userPrincipalName" ] data CampusUserException = CampusUserLdapError LdapPoolError | CampusUserNoResult | CampusUserAmbiguous deriving (Show, Eq, Generic, Typeable) instance Exception CampusUserException makePrisms ''CampusUserException campusUserWith :: ( MonadUnliftIO m , MonadCatch m ) => ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap -> Failover (LdapConf, LdapPool) -> FailoverMode -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) ) -> Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> 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 lift $ Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter [] Nothing -> do lift $ findUser conf ldap credsIdent [] case results of [] -> throwE CampusUserNoResult [Ldap.SearchEntry _ attrs] -> return attrs _otherwise -> throwE CampusUserAmbiguous campusUserReTest :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) campusUserReTest pool doTest mode creds = throwLeft =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds 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, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) campusUser' pool mode User{userIdent} = campusUser'' pool mode $ CI.original userIdent campusUser'' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Text -> m (Maybe (Ldap.AttrList [])) campusUser'' pool mode ident = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident []) 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 [] -> throwM CampusUserNoResult [Ldap.SearchEntry _ attrs] -> return attrs _otherwise -> throwM CampusUserAmbiguous 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 newtype ADInvalidCredentials = ADInvalidCredentials ADError deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (Universe, Finite, Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey) isUnusualADError :: ADError -> Bool isUnusualADError = flip notElem [ADNoSuchObject, ADLogonFailure] campusForm :: ( RenderMessage (HandlerSite m) FormMessage , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m)) , RenderMessage (HandlerSite m) CampusMessage , MonadHandler m ) => WForm m (FormResult CampusLogin) campusForm = do MsgRenderer mr <- getMsgRenderer aFormToWForm $ CampusLogin <$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "" & addAttr "autocomplete" "username") Nothing <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing apLdap :: Text apLdap = "LDAP" campusLogin :: forall site. ( YesodAuth site , RenderMessage site CampusMessage , RenderAFormSite site , RenderMessage site (ValueRequired site) , RenderMessage site ADInvalidCredentials , Button site ButtonSubmit ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site campusLogin pool mode = AuthPlugin{..} where apName :: Text apName = apLdap apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do ((loginRes, _), _) <- runFormPost $ renderWForm FormLogin campusForm tp <- getRouteToParent resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> do ldapResult <- withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] | [principalName] <- nubOrd $ fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ] , Right credsIdent <- Text.decodeUtf8' principalName -> handleIf isInvalidCredentials (return . Left) $ do Ldap.bind ldap (Ldap.Dn credsIdent) . Ldap.Password $ Text.encodeUtf8 campusPassword return . Right $ Right (userDN, credsIdent) other -> return . Right $ Left other case ldapResult of Left err -> do $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 MsgRenderer mr <- liftHandler getMsgRenderer setSessionJson SessionError . PermissionDenied . toPathPiece $ ADInvalidCredentials adError loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError Right (Left bindErr) -> do case bindErr of Ldap.ResponseErrorCode _ _ _ errTxt -> $logInfoS apName [st|#{campusIdent}: #{errTxt}|] _other -> return () $logDebugS apName "Invalid credentials" observeLoginOutcome apName LoginInvalidCredentials loginErrorMessageI LoginR Msg.InvalidLogin Right (Right (Left searchResults)) | null searchResults -> do $logDebugS apName "User not found" observeLoginOutcome apName LoginInvalidCredentials loginErrorMessageI LoginR Msg.InvalidLogin | otherwise -> do $logWarnS apName $ "Could not extract principal name: " <> tshow searchResults observeLoginOutcome apName LoginError loginErrorMessageI LoginR Msg.AuthError Right (Right (Right (userDN, credsIdent))) -> do observeLoginOutcome apName LoginSuccessful setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] maybe (redirect $ tp LoginR) return resp apDispatch _ [] = badMethod apDispatch _ _ = notFound apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormLogin campusForm let loginForm = wrapForm login FormSettings { formMethod = POST , formAction = Just . SomeRoute . toMaster $ PluginR apName [] , formEncoding = loginEnctype , formAttrs = [("uw-no-navigate-away-prompt","")] , formSubmit = FormSubmit , formAnchor = Just "login--campus" :: Maybe Text } $(widgetFile "widgets/campus-login/campus-login-form") isInvalidCredentials = \case Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _ -> True _other -> False