module Auth.LDAP ( apLdap , ADError(..), ADInvalidCredentials(..) , campusLogin , CampusUserException(..) , campusUser, campusUser' , campusUserReTest, campusUserReTest' , campusUserMatr, campusUserMatr' , CampusMessage(..) , ldapPrimaryKey , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserFirstName, ldapUserSurname , ldapAffiliation , ldapUserMobile, ldapUserTelephone , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung ) 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 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 ] 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, ldapUserMobile, ldapUserTelephone, 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 -- new ldapUserTelephone = Ldap.Attr "telephoneNumber" ldapUserMobile = Ldap.Attr "mobile" ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName" ldapUserFraportAbteilung = Ldap.Attr "Department" {- --outdated to be removed ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" ldapUserTitle = Ldap.Attr "title" ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach" ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" ldapSex = Ldap.Attr "schacGender" ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS" -} 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} = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) []) 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" "") Nothing <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder)) Nothing apLdap :: Text apLdap = "LDAP" campusLogin :: forall site. ( YesodAuth 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{..} 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 FormStandard 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 FormStandard 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