module Auth.LDAP ( apLdap , campusLogin , CampusUserException(..) , campusUser, campusUser' , campusUserReTest, campusUserReTest' , campusUserMatr, campusUserMatr' , CampusMessage(..) , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName , ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex ) 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 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}@campus.lmu.de|] ] ++ [ ldapUserEmail' Ldap.:= Text.encodeUtf8 ident' | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@campus.lmu.de|]] , ldapUserEmail' <- toList ldapUserEmail ] ++ [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident , ldapUserMatriculation 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 = [ ldapUserMatriculation 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 ] ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester :: Ldap.Attr ldapUserPrincipalName = Ldap.Attr "userPrincipalName" ldapUserDisplayName = Ldap.Attr "displayName" ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" ldapUserFirstName = Ldap.Attr "givenName" ldapUserSurname = Ldap.Attr "sn" 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 "name" ] 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 = either throwM return =<< 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 = either throwM return =<< 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 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) , 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] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ] , Right credsIdent <- Text.decodeUtf8' principalName -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) other -> return $ Left other case ldapResult of Left err | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err -> do $logDebugS apName "Invalid credentials" observeLoginOutcome apName LoginInvalidCredentials loginErrorMessageI LoginR Msg.InvalidLogin | otherwise -> do $logErrorS apName $ "Error during login: " <> tshow err observeLoginOutcome apName LoginError loginErrorMessageI LoginR Msg.AuthError Right (Right (userDN, credsIdent)) -> do observeLoginOutcome apName LoginSuccessful setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] Right (Left searchResults) -> do $logWarnS apName $ "Could not extract principal name: " <> tshow searchResults observeLoginOutcome apName LoginError loginErrorMessageI LoginR Msg.AuthError 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")