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 Network.Connection import qualified Data.CaseInsensitive as CI import qualified Control.Monad.Catch as Exc 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 | MsgCampusSubmit | MsgCampusInvalidCredentials 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 | CampusUserHostNotResolved String | CampusUserLineTooLong | CampusUserHostCannotConnect String [IOException] | CampusUserNoResult | CampusUserAmbiguous deriving (Show, Eq, Generic, Typeable) instance Exception CampusUserException makePrisms ''CampusUserException campusUserWith :: MonadUnliftIO m => ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap -> Failover (LdapConf, LdapPool) -> FailoverMode -> ((LdapConf, Ldap) -> IO (Ldap.AttrList [])) -> IO (Either LdapPoolError (Ldap.AttrList [])) ) -> Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) campusUserWith withLdap' pool mode Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do Ldap.bind ldap ldapDn ldapPassword results <- case lookup "DN" credsExtra of Just userDN -> do let userFilter = Ldap.Present ldapUserPrincipalName Ldap.search ldap (Ldap.Dn userDN) (userSearchSettings conf) userFilter [] Nothing -> do findUser conf ldap credsIdent [] case results of [] -> throwM CampusUserNoResult [Ldap.SearchEntry _ attrs] -> return attrs _otherwise -> throwM CampusUserAmbiguous where errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs ] campusUserReTest :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) campusUserReTest pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool campusUserReTest' :: (MonadCatch 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 => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) campusUser = campusUserWith withLdapFailover campusUser' :: (MonadCatch m, MonadUnliftIO 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 => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList []) campusUserMatr pool mode userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do Ldap.bind ldap ldapDn ldapPassword results <- findUserMatr conf ldap userMatr [] case results of [] -> throwM CampusUserNoResult [Ldap.SearchEntry _ attrs] -> return attrs _otherwise -> throwM CampusUserAmbiguous where errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs ] campusUserMatr' :: (MonadCatch m, MonadUnliftIO 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) CampusMessage , MonadHandler m ) => WForm m (FormResult CampusLogin) campusForm = do MsgRenderer mr <- getMsgRenderer ident <- wreq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "") Nothing password <- wreq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder)) Nothing return $ CampusLogin <$> ident <*> password apLdap :: Text apLdap = "LDAP" campusLogin :: forall site. ( YesodAuth site , RenderMessage site CampusMessage , RenderMessage site AFormMessage , 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 "POST" [] = liftSubHandler $ do ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm tp <- getRouteToParent case loginRes of FormFailure errs -> do forM_ errs $ addMessage Error . toHtml redirect $ tp LoginR FormMissing -> redirect $ tp LoginR FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> 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 "LDAP" "Invalid credentials" loginErrorMessageI LoginR Msg.InvalidLogin | otherwise -> do $logErrorS "LDAP" $ "Error during login: " <> tshow err loginErrorMessageI LoginR Msg.AuthError Right (Right (userDN, credsIdent)) -> setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] Right (Left searchResults) -> do $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults loginErrorMessageI LoginR Msg.AuthError 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 "LDAP" [] , formEncoding = loginEnctype , formAttrs = [("uw-no-navigate-away-prompt","")] , formSubmit = FormSubmit , formAnchor = Just "login--campus" :: Maybe Text } $(widgetFile "widgets/campus-login/campus-login-form")