diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index bc00b4d24..ea133aa73 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -553,6 +553,16 @@ PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team sp DummyLoginTitle: Development-Login LoginNecessary: Bitte melden Sie sich dazu vorher an! +InternalLdapError: Interner Fehler beim Campus-Login + +CampusUserInvalidEmail: Konnte anhand des Campus-Logins keine EMail-Addresse ermitteln +CampusUserInvalidDisplayName: Konnte anhand des Campus-Logins keinen vollen Namen ermitteln +CampusUserInvalidGivenName: Konnte anhand des Campus-Logins keinen Vornamen ermitteln +CampusUserInvalidSurname: Konnte anhand des Campus-Logins keinen Nachname ermitteln +CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Titel ermitteln +CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln +CampusUserInvalidFeaturesOfStudy parseErr@String: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln: #{parseErr} + CorrectorNormal: Normal CorrectorMissing: Abwesend CorrectorExcused: Entschuldigt diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 4f003471a..26026dfee 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,9 +1,12 @@ module Auth.LDAP - ( campusLogin + ( apLdap + , campusLogin , CampusUserException(..) , campusUser , CampusMessage(..) - , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue + , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName + , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname + , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName ) where import Import.NoFoundation hiding (userEmail, userDisplayName) @@ -42,12 +45,12 @@ findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase userSearchSettings) retAttrs) userFilters where userFilters = - [ userPrincipalName Ldap.:= Text.encodeUtf8 ident - , userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] - , userEmail Ldap.:= Text.encodeUtf8 ident - , userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|] - , userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] - , userDisplayName Ldap.:= Text.encodeUtf8 ident + [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident + , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] + , ldapUserEmail Ldap.:= Text.encodeUtf8 ident + , ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|] + , ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] + , ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident ] userSearchSettings = mconcat [ Ldap.scope ldapScope @@ -56,10 +59,53 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not , Ldap.derefAliases Ldap.DerefAlways ] -userPrincipalName, userEmail, userDisplayName :: Ldap.Attr -userPrincipalName = Ldap.Attr "userPrincipalName" -userEmail = Ldap.Attr "mail" -userDisplayName = Ldap.Attr "displayName" +ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr +ldapUserPrincipalName = Ldap.Attr "userPrincipalName" +ldapUserEmail = Ldap.Attr "mail" +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 "dfnEduPersonFieldOfStudyString" + + +data CampusUserException = CampusUserLdapError LdapPoolError + | CampusUserHostNotResolved String + | CampusUserLineTooLong + | CampusUserHostCannotConnect String [IOException] + | CampusUserNoResult + | CampusUserAmbiguous + deriving (Show, Eq, Generic, Typeable) + +instance Exception CampusUserException + +campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) +campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do + Ldap.bind ldap ldapDn ldapPassword + results <- case lookup "DN" credsExtra of + Just userDN -> do + let userFilter = Ldap.Present ldapUserPrincipalName + userSearchSettings = mconcat + [ Ldap.scope Ldap.BaseObject + , Ldap.size 2 + , Ldap.time ldapSearchTimeout + , Ldap.derefAliases Ldap.DerefAlways + ] + Ldap.search ldap (Ldap.Dn userDN) userSearchSettings 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 + ] + campusForm :: ( RenderMessage site FormMessage , RenderMessage site CampusMessage @@ -69,6 +115,9 @@ campusForm = CampusLogin <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing <*> areq passwordField (fslI MsgCampusPassword) Nothing +apLdap :: Text +apLdap = "LDAP" + campusLogin :: forall site. ( YesodAuth site , RenderMessage site FormMessage @@ -78,7 +127,7 @@ campusLogin :: forall site. ) => LdapConf -> LdapPool -> AuthPlugin site campusLogin conf@LdapConf{..} pool = AuthPlugin{..} where - apName = "LDAP" + apName = apLdap apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent apDispatch "POST" [] = do ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm @@ -90,10 +139,10 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do ldapResult <- withLdap pool $ \ldap -> do Ldap.bind ldap ldapDn ldapPassword - searchResults <- findUser conf ldap campusIdent [userPrincipalName] + searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] - | Just [principalName] <- lookup userPrincipalName 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 @@ -123,55 +172,3 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} , formAnchor = Just "login--campus" :: Maybe Text } $(widgetFile "widgets/campus-login/campus-login-form") - -data CampusUserException = CampusUserLdapError LdapPoolError - | CampusUserHostNotResolved String - | CampusUserLineTooLong - | CampusUserHostCannotConnect String [IOException] - | CampusUserNoResult - | CampusUserAmbiguous - deriving (Show, Eq, Generic, Typeable) - -instance Exception CampusUserException - -campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) -campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do - Ldap.bind ldap ldapDn ldapPassword - results <- case lookup "DN" credsExtra of - Just userDN -> do - let userFilter = Ldap.Present userPrincipalName - userSearchSettings = mconcat - [ Ldap.scope Ldap.BaseObject - , Ldap.size 2 - , Ldap.time ldapSearchTimeout - , Ldap.derefAliases Ldap.DerefAlways - ] - Ldap.search ldap (Ldap.Dn userDN) userSearchSettings 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 - ] - --- ldapConfig :: UniWorX -> LDAPConfig --- ldapConfig _app@(appSettings' -> settings) = LDAPConfig --- { usernameFilter = \u -> principalName <> "=" <> u --- , identifierModifier --- , ldapUri = appLDAPURI settings --- , initDN = appLDAPDN settings --- , initPass = appLDAPPw settings --- , baseDN = appLDAPBaseName settings --- , ldapScope = LdapScopeSubtree --- } --- where --- principalName :: IsString a => a --- principalName = "userPrincipalName" --- identifierModifier _ entry = case lookup principalName $ leattrs entry of --- Just [n] -> Text.pack n --- _ -> error "Could not determine user principal name" diff --git a/src/Foundation.hs b/src/Foundation.hs index 8998e23cc..2d67f1f9e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -55,7 +55,7 @@ import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E -import Control.Monad.Except (MonadError(..), ExceptT, runExceptT) +import Control.Monad.Except (MonadError(..), ExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) @@ -88,6 +88,8 @@ import qualified Data.Aeson as JSON import Data.FileEmbed (embedFile) +import qualified Ldap.Client as Ldap + type SMTPPool = Pool SMTPConnection @@ -2732,6 +2734,155 @@ instance YesodPersist UniWorX where instance YesodPersistRunner UniWorX where getDBRunner = defaultGetDBRunner appConnPool +data CampusUserConversionException + = CampusUserInvalidEmail + | CampusUserInvalidDisplayName + | CampusUserInvalidGivenName + | CampusUserInvalidSurname + | CampusUserInvalidTitle + | CampusUserInvalidMatriculation + | CampusUserInvalidFeaturesOfStudy String + deriving (Eq, Ord, Read, Show, Generic, Typeable) +instance Exception CampusUserConversionException + +embedRenderMessage ''UniWorX ''CampusUserConversionException id + +upsertCampusUser :: Ldap.AttrList [] -> Creds UniWorX -> DB (Entity User) +upsertCampusUser ldapData Creds{..} = do + now <- liftIO getCurrentTime + UserDefaultConf{..} <- getsYesod $ view _appUserDefaults + + let + userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ] + userEmail' = fold [ v | (k, v) <- ldapData, k == ldapUserEmail ] + userDisplayName' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ] + userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ] + userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ] + userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ] + + userAuthentication + | isPWHash = error "PWHash should only work for users that are already known" + | otherwise = AuthLDAP + userLastAuthentication = now <$ guard (not isDummy) + + userEmail <- if + | [bs] <- userEmail' + , Right userEmail <- Text.decodeUtf8' bs + -> return $ mk userEmail + | otherwise + -> throwM CampusUserInvalidEmail + userDisplayName <- if + | [bs] <- userDisplayName' + , Right userDisplayName <- Text.decodeUtf8' bs + -> return userDisplayName + | otherwise + -> throwM CampusUserInvalidDisplayName + userFirstName <- if + | [bs] <- userFirstName' + , Right userFirstName <- Text.decodeUtf8' bs + -> return userFirstName + | otherwise + -> throwM CampusUserInvalidGivenName + userSurname <- if + | [bs] <- userSurname' + , Right userSurname <- Text.decodeUtf8' bs + -> return userSurname + | otherwise + -> throwM CampusUserInvalidSurname + userTitle <- if + | all ByteString.null userTitle' + -> return Nothing + | [bs] <- userTitle' + , Right userTitle <- Text.decodeUtf8' bs + -> return $ Just userTitle + | otherwise + -> throwM CampusUserInvalidTitle + userMatrikelnummer <- if + | [bs] <- userMatrikelnummer' + , Right userMatrikelnummer <- Text.decodeUtf8' bs + -> return $ Just userMatrikelnummer + | [] <- userMatrikelnummer' + -> return Nothing + | otherwise + -> throwM CampusUserInvalidMatriculation + + let + newUser = User + { userIdent = mk credsIdent + , userMaxFavourites = userDefaultMaxFavourites + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userNotificationSettings = def + , userMailLanguages = def + , userTokensIssuedAfter = Nothing + , .. + } + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + , UserDisplayName =. userDisplayName + , UserSurname =. userSurname + , UserEmail =. userEmail + ] ++ + [ UserLastAuthentication =. Just now | not isDummy ] + + user@(Entity userId _) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate + + let + userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now + userStudyFeatures' = do + (k, v) <- ldapData + guard $ k == ldapUserStudyFeatures + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + + termNames = nubBy ((==) `on` mk) $ do + (k, v) <- ldapData + guard $ k == ldapUserFieldName + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + + fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures + + let + studyTermCandidates = Set.fromList $ do + name <- termNames + StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs + return (key, name) + studyTermCandidateIncidence + = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen + . UUID.fromByteString + . fromStrict + . (convert :: Digest (SHAKE128 128) -> ByteString) + . runIdentity + $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash + + [E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate -> + E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence + + unless candidatesRecorded $ do + let + studyTermCandidates' = do + (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates + return StudyTermCandidate{..} + insertMany_ studyTermCandidates' + + E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] + forM_ fs $ \f@StudyFeatures{..} -> do + insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing + insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing + void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] + + return user + where + insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) + isDummy = credsPlugin == "dummy" + isPWHash = credsPlugin == "PWHash" + + instance YesodAuth UniWorX where type AuthId UniWorX = UserId @@ -2761,25 +2912,34 @@ instance YesodAuth UniWorX where isDummy = credsPlugin == "dummy" isPWHash = credsPlugin == "PWHash" - excHandlers + excRecovery res | isDummy || isPWHash - = [ C.Handler $ \err -> do - addMessage Error (toHtml $ tshow (err :: CampusUserException)) - $logErrorS "LDAP" $ tshow err - acceptExisting - ] + = do + case res of + UserError err -> addMessageI Error err + ServerError err -> addMessage Error $ toHtml err + _other -> return () + acceptExisting | otherwise - = [ C.Handler $ \case - CampusUserNoResult -> do - $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent - return . UserError $ IdentifierNotFound credsIdent - CampusUserAmbiguous -> do - $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent - return . UserError $ IdentifierNotFound credsIdent - err -> do - $logErrorS "LDAP" $ tshow err - return $ ServerError "LDAP lookup failed" - ] + = return res + + excHandlers = + [ C.Handler $ \case + CampusUserNoResult -> do + $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + excRecovery . UserError $ IdentifierNotFound credsIdent + CampusUserAmbiguous -> do + $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + excRecovery . UserError $ IdentifierNotFound credsIdent + err -> do + $logErrorS "LDAP" $ tshow err + mr <- getMessageRender + excRecovery . ServerError $ mr MsgInternalLdapError + , C.Handler $ \(cExc :: CampusUserConversionException) -> do + $logErrorS "LDAP" $ tshow cExc + mr <- getMessageRender + excRecovery . ServerError $ mr cExc + ] acceptExisting = do res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth @@ -2792,138 +2952,13 @@ instance YesodAuth UniWorX where UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of - Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do - ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (original userIdent) credsExtra + Just (ldapConf, ldapPool) -> do + let userCreds = Creds credsPlugin (original userIdent) credsExtra + ldapData <- campusUser ldapConf ldapPool userCreds $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData - - let - userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData - userEmail' = lookup (Attr "mail") ldapData - userDisplayName' = lookup (Attr "displayName") ldapData - userFirstName' = lookup (Attr "givenName") ldapData - userSurname' = lookup (Attr "sn") ldapData - userTitle' = lookup (Attr "title") ldapData - - userAuthentication - | isPWHash = error "PWHash should only work for users that are already known" - | otherwise = AuthLDAP - userLastAuthentication = now <$ guard (not isDummy) - - userEmail <- if - | Just [bs] <- userEmail' - , Right userEmail <- Text.decodeUtf8' bs - -> return $ 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" - userFirstName <- if - | Just [bs] <- userFirstName' - , Right userFirstName <- Text.decodeUtf8' bs - -> return userFirstName - | otherwise - -> throwError $ ServerError "Could not retrieve user given name" - userSurname <- if - | Just [bs] <- userSurname' - , Right userSurname <- Text.decodeUtf8' bs - -> return userSurname - | otherwise - -> throwError $ ServerError "Could not retrieve user surname" - userTitle <- if - | maybe True (all ByteString.null) userTitle' - -> return Nothing - | Just [bs] <- userTitle' - , Right userTitle <- Text.decodeUtf8' bs - -> return $ Just userTitle - | otherwise - -> throwError $ ServerError "Could not retrieve user title" - 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 - newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userNotificationSettings = def - , userMailLanguages = def - , userTokensIssuedAfter = Nothing - , .. - } - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName - , UserSurname =. userSurname - , UserEmail =. userEmail - ] ++ - [ UserLastAuthentication =. Just now | not isDummy ] - - userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate - - let - userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now - userStudyFeatures' = do - (k, v) <- ldapData - guard $ k == Attr "dfnEduPersonFeaturesOfStudy" - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - termNames = nubBy ((==) `on` mk) $ do - (k, v) <- ldapData - guard $ k == Attr "dfnEduPersonFieldOfStudyString" - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - - let - studyTermCandidates = Set.fromList $ do - name <- termNames - StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs - return (key, name) - studyTermCandidateIncidence - = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") - . UUID.fromByteString - . fromStrict - . (convert :: Digest (SHAKE128 128) -> ByteString) - . runIdentity - $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash - - [E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate -> - E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence - - unless candidatesRecorded $ do - let - studyTermCandidates' = do - (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates - return StudyTermCandidate{..} - lift $ insertMany_ studyTermCandidates' - - lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] - forM_ fs $ \f@StudyFeatures{..} -> do - lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing - lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing - void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] - - return $ Authenticated userId - Nothing -> acceptExisting - - where - insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) + Authenticated . entityKey <$> upsertCampusUser ldapData userCreds + Nothing + -> acceptExisting authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes [ campusLogin <$> appLdapConf <*> appLdapPool diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 804359e44..59f5837c9 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -260,10 +260,7 @@ postAdminUserR uuid = do campusHandler _ = mzero campusResult <- runMaybeT . handle campusHandler $ do (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf - let - campusLogin :: AuthPlugin UniWorX - campusLogin = Auth.campusLogin conf pool - void . Auth.campusUser conf pool $ Creds (apName campusLogin) (CI.original userIdent) [] + void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) [] case campusResult of Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup _other