diff --git a/config/settings.yml b/config/settings.yml index e45f7995b..1b0913f6f 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -42,6 +42,7 @@ ldap: pass: "_env:LDAPPASS:" baseDN: "_env:LDAPBASE:" scope: "_env:LDAPSCOPE:WholeSubtree" + timeout: "_env:LDAPTIMEOUT:5" default-favourites: 12 default-theme: Default diff --git a/messages/campus/de.msg b/messages/campus/de.msg index e80603d2b..5fdf477b7 100644 --- a/messages/campus/de.msg +++ b/messages/campus/de.msg @@ -1,4 +1,5 @@ CampusIdentNote: Campus-Kennung bitte inkl. Domain-Teil (@campus.lmu.de) angeben. CampusIdent: Campus-Kennung CampusPassword: Passwort -CampusSubmit: Abschicken \ No newline at end of file +CampusSubmit: Abschicken +CampusInvalidCredentials: Ungültige Logindaten \ No newline at end of file diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index e15418668..d8672bfe8 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -5,11 +5,14 @@ , FlexibleContexts , FlexibleInstances , NoImplicitPrelude + , ScopedTypeVariables #-} module Auth.LDAP ( campusLogin + , campusUser , CampusMessage(..) + , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue ) where import Import.NoFoundation @@ -17,6 +20,12 @@ import Control.Lens 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, campusPassword :: Text } @@ -24,6 +33,7 @@ data CampusMessage = MsgCampusIdentNote | MsgCampusIdent | MsgCampusPassword | MsgCampusSubmit + | MsgCampusInvalidCredentials campusForm :: ( RenderMessage site FormMessage @@ -36,20 +46,91 @@ campusForm = CampusLogin <*> areq passwordField (fslI MsgCampusPassword) Nothing <* submitButton -campusLogin :: ( YesodAuth site +campusLogin :: forall site. + ( YesodAuth site , RenderMessage site FormMessage , RenderMessage site CampusMessage , Button site SubmitButton , Show (ButtonCssClass site) ) => LdapConf -> AuthPlugin site -campusLogin conf = AuthPlugin{..} +campusLogin LdapConf{..} = AuthPlugin{..} where apName = "LDAP" + apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent + apDispatch "POST" [] = do + ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm + case loginRes of + FormFailure errs -> do + forM_ errs $ addMessage "error" . toHtml + redirect LoginR + FormMissing -> redirect LoginR + FormSuccess CampusLogin{..} -> do + ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do + Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) + Ldap.bind ldap ldapDn ldapPassword + let + userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent + userSearchSettings = mconcat + [ Ldap.scope ldapScope + , Ldap.size 2 + , Ldap.time ldapTimeout + , Ldap.derefAliases Ldap.DerefAlways + ] + Ldap.search ldap ldapBase userSearchSettings userFilter [userPrincipalName] + case ldapResult of + Left err + | 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 searchResults + | [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults + , Just [principalName] <- lookup userPrincipalName userAttrs + , Right credsIdent <- Text.decodeUtf8' principalName + -> do + $logDebugS "LDAP" $ tshow searchResults + lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] + | otherwise -> do + $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults + loginErrorMessageI LoginR Msg.AuthError apDispatch _ _ = notFound apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm $(widgetFile "widgets/campus-login-form") +userPrincipalName :: Ldap.Attr +userPrincipalName = Ldap.Attr "userPrincipalName" + +data CampusUserException = CampusUserLdapError Ldap.LdapError + | CampusUserNoDN + | CampusUserNoResult + | CampusUserAmbiguous + deriving (Show, Eq, Typeable) + +instance Exception CampusUserException + +campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList []) +campusUser LdapConf{..} Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do + userDN <- case lookup "DN" credsExtra of + Just userDN -> return userDN + Nothing -> throwM CampusUserNoDN + let userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 credsIdent + userSearchSettings = mconcat + [ Ldap.scope Ldap.BaseObject + , Ldap.size 2 + , Ldap.time ldapTimeout + , Ldap.derefAliases Ldap.DerefAlways + ] + Ldap.bind ldap ldapDn ldapPassword + results <- Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter [] + case results of + [] -> throwM CampusUserNoResult + [Ldap.SearchEntry _ attrs] -> return attrs + _otherwise -> throwM CampusUserAmbiguous + -- ldapConfig :: UniWorX -> LDAPConfig -- ldapConfig _app@(appSettings -> settings) = LDAPConfig -- { usernameFilter = \u -> principalName <> "=" <> u diff --git a/src/Foundation.hs b/src/Foundation.hs index 5c1e72361..566f5068b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1093,49 +1093,76 @@ instance YesodAuth UniWorX where isPWFile = credsPlugin == "PWFile" uAuth = UniqueAuthentication userPlugin userIdent - $logDebugS "auth" $ tshow ((userPlugin, userIdent), creds) - - when (isDummy || isPWFile) . (throwError =<<) . lift $ - maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth - - let - userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra - userEmail' = lookup "mail" credsExtra - userDisplayName' = lookup "displayName" credsExtra - - userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") (return . CI.mk) userEmail' - userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName' + $logDebugS "auth" $ tshow creds AppSettings{..} <- getsYesod appSettings - let - userMaxFavourites = appDefaultMaxFavourites - userTheme = appDefaultTheme - userDateTimeFormat = appDefaultDateTimeFormat - userDateFormat = appDefaultDateFormat - userTimeFormat = appDefaultTimeFormat - newUser = User{..} - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName - , UserEmail =. userEmail + case appLdapConf of + Just ldapConf -> do + ldapData <- campusUser ldapConf creds + + let + userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData + userEmail' = lookup (Attr "mail") ldapData + userDisplayName' = lookup (Attr "displayName") ldapData + + userEmail <- if + | Just [bs] <- userEmail' + , Right userEmail <- Text.decodeUtf8' bs + -> return $ CI.mk userEmail + | otherwise + -> throwError $ ServerError "Could not retrieve user email" + userDisplayName <- if + | Just [bs] <- userDisplayName' + , Right userDisplayName <- Text.decodeUtf8' bs + -> return userDisplayName + | otherwise + -> throwError $ ServerError "Could not retrieve user name" + userMatrikelnummer <- if + | Just [bs] <- userMatrikelnummer' + , Right userMatrikelnummer <- Text.decodeUtf8' bs + -> return $ Just userMatrikelnummer + | Nothing <- userMatrikelnummer' + -> return Nothing + | otherwise + -> throwError $ ServerError "Could not decode user matriculation" + + let + userMaxFavourites = appDefaultMaxFavourites + userTheme = appDefaultTheme + userDateTimeFormat = appDefaultDateTimeFormat + userDateFormat = appDefaultDateFormat + userTimeFormat = appDefaultTimeFormat + newUser = User{..} + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + , UserDisplayName =. userDisplayName + , UserEmail =. userEmail ] - userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate + userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate - let - userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' - userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ] + let + userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' + userStudyFeatures' = do + (k, v) <- ldapData + guard $ k == Attr "dfnEduPersonFeaturesOfStudy" + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str - fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures + fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - lift $ deleteWhere [StudyFeaturesUser ==. userId] + lift $ deleteWhere [StudyFeaturesUser ==. userId] - forM_ fs $ \StudyFeatures{..} -> do - lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing - lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing + forM_ fs $ \StudyFeatures{..} -> do + lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing + lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing + + lift $ insertMany_ fs + return $ Authenticated userId + Nothing -> (throwError =<<) . lift $ + maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth - lift $ insertMany_ fs - return $ Authenticated userId where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) diff --git a/src/Settings.hs b/src/Settings.hs index c4b5d1eb1..b7aa64493 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -91,6 +91,7 @@ data LdapConf = LdapConf , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password , ldapBase :: Ldap.Dn , ldapScope :: Ldap.Scope + , ldapTimeout :: Int32 } deriveFromJSON defaultOptions ''Ldap.Scope @@ -111,6 +112,7 @@ instance FromJSON LdapConf where ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .: "pass" ldapBase <- Ldap.Dn <$> o .: "baseDN" ldapScope <- o .: "scope" + ldapTimeout <- o .: "timeout" return LdapConf{..} instance FromJSON AppSettings where