From ec32a24af7e14fbd273092b55a633f58cf550c74 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Dec 2021 16:58:36 +0100 Subject: [PATCH] chore(ldap): user function configured --- src/Auth/LDAP.hs | 7 +- src/Foundation/Yesod/Auth.hs | 167 ------- src/Handler/Admin/StudyFeatures.hs | 533 ----------------------- src/Handler/Utils/LdapSystemFunctions.hs | 5 +- 4 files changed, 5 insertions(+), 707 deletions(-) delete mode 100644 src/Handler/Admin/StudyFeatures.hs diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 4d2d18492..a18dbc1b6 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -77,15 +77,14 @@ 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" -{- -Maybe keep: -- ldapAffiliation --- outdated to be removed +{- --outdated to be removed ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" ldapUserTitle = Ldap.Attr "title" ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" @@ -93,8 +92,6 @@ ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach" ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" ldapSex = Ldap.Attr "schacGender" ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS" -ldapAffiliation = Ldap.Attr "eduPersonAffiliation" -- was used to determin user function, i.e. rights - -} ldapUserEmail :: NonEmpty Ldap.Attr diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 4a642998b..88e7d9473 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -291,173 +291,6 @@ upsertCampusUser upsertMode ldapData = do unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ update userId [ UserDisplayName =. userDisplayName' ] - let - termNames = nubOrdOn CI.mk $ do - (k, v) <- ldapData - guard $ k == ldapUserFieldName - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester - userSubTermsSemesters' = do - (k, v) <- ldapData - guard $ k == ldapUserSubTermsSemester - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures - sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters - - let - studyTermCandidates = Set.fromList $ do - let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs' - subTermsKeys = unStudyTermsKey . fst <$> sts - - (,) <$> sfKeys ++ subTermsKeys <*> termNames - - let - assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) (SqlPersistT m) [StudyFeatures] - assimilateSubTerms [] xs = return xs - assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do - standalone <- lift $ get subterm - case standalone of - _other - | (match : matches, unusedFeats') <- partition - (\StudyFeatures{..} -> subterm == studyFeaturesField - && subSemester == studyFeaturesSemester - ) unusedFeats - -> do - $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|] - (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats') - | any ((== subterm) . studyFeaturesField) unusedFeats - -> do - $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|] - assimilateSubTerms subterms unusedFeats - Just StudyTerms{..} - | Just defDegree <- studyTermsDefaultDegree - , Just defType <- studyTermsDefaultType - -> do - $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|] - let sf = StudyFeatures - { studyFeaturesUser = userId - , studyFeaturesDegree = defDegree - , studyFeaturesField = subterm - , studyFeaturesSuperField = Nothing - , studyFeaturesType = defType - , studyFeaturesSemester = subSemester - , studyFeaturesFirstObserved = Just now - , studyFeaturesLastObserved = now - , studyFeaturesValid = True - , studyFeaturesRelevanceCached = Nothing - } - (sf :) <$> assimilateSubTerms subterms unusedFeats - Nothing - | [] <- unusedFeats -> do - $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|] - tell $ Set.singleton (subterm, Nothing) - assimilateSubTerms subterms [] - _other -> do - knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] [] - let matchingFeatures = case knownParents of - [] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats - ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats - when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} -> - tell $ Set.singleton (subterm, Just studyFeaturesField) - if - | not $ null knownParents -> do - $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|] - let setSuperField sf = sf - & _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField)) - & _studyFeaturesField .~ subterm - (++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures) - | otherwise -> do - $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|] - assimilateSubTerms subterms unusedFeats - $logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|] - (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs' - - let - studyTermCandidateIncidence - = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen - . UUID.fromByteString - . fromStrict - . (convert :: Digest (SHAKE128 128) -> ByteString) - . runConduitPure - $ C.yieldMany ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash - - candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do - E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence - E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence - E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) - E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) - E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) - - unless candidatesRecorded $ do - let - studyTermCandidates' = do - (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates - let studyTermNameCandidateIncidence = studyTermCandidateIncidence - return StudyTermNameCandidate{..} - insertMany_ studyTermCandidates' - - let - studySubTermParentCandidates' = do - (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates - let studySubTermParentCandidateIncidence = studyTermCandidateIncidence - return StudySubTermParentCandidate{..} - insertMany_ studySubTermParentCandidates' - - let - studyTermStandaloneCandidates' = do - (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates - let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence - return StudyTermStandaloneCandidate{..} - insertMany_ studyTermStandaloneCandidates' - - 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 Nothing Nothing - void $ upsert f - [ StudyFeaturesLastObserved =. now - , StudyFeaturesValid =. True - , StudyFeaturesSuperField =. studyFeaturesSuperField - ] - associateUserSchoolsByTerms userId - - cacheStudyFeatureRelevance $ \studyFeatures -> studyFeatures E.^. StudyFeaturesUser E.==. E.val userId - - let - userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools - userAssociatedSchools' = do - (k, v) <- ldapData - guard $ k == ldapUserSchoolAssociation - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools - - forM_ ss $ \frag -> void . runMaybeT $ do - let - exactMatch = MaybeT . getBy $ UniqueOrgUnit frag - infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do - E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit - E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool) - return schoolLdap - Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch - ssh <- hoistMaybe schoolLdapSchool - - lift . void $ insertUnique UserSchool - { userSchoolUser = userId - , userSchoolSchool = ssh - , userSchoolIsOptOut = False - } - - forM_ ss $ void . insertUnique . SchoolLdap Nothing - let userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' userSystemFunctions' = do diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs deleted file mode 100644 index ef6b7f051..000000000 --- a/src/Handler/Admin/StudyFeatures.hs +++ /dev/null @@ -1,533 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module Handler.Admin.StudyFeatures - ( getAdminFeaturesR, postAdminFeaturesR - ) where - -import Import -import Handler.Utils - -import qualified Data.Text as Text - -import qualified Data.Set as Set -import qualified Data.Map as Map - -import qualified Database.Esqueleto.Legacy as E -import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter) - -import qualified Handler.Utils.TermCandidates as Candidates - - -data ButtonAdminStudyTermsNames - = BtnNameCandidatesInfer - | BtnNameCandidatesDeleteConflicts - | BtnNameCandidatesDeleteAll - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonAdminStudyTermsNames -instance Finite ButtonAdminStudyTermsNames - -nullaryPathPiece ''ButtonAdminStudyTermsNames $ camelToPathPiece' 1 -embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsNames id - -instance Button UniWorX ButtonAdminStudyTermsNames where - btnClasses BtnNameCandidatesInfer = [BCIsButton, BCPrimary] - btnClasses BtnNameCandidatesDeleteConflicts = [BCIsButton, BCDanger] - btnClasses BtnNameCandidatesDeleteAll = [BCIsButton, BCDanger] - -data ButtonAdminStudyTermsParents - = BtnParentCandidatesInfer - | BtnParentCandidatesDeleteAll - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonAdminStudyTermsParents -instance Finite ButtonAdminStudyTermsParents - -nullaryPathPiece ''ButtonAdminStudyTermsParents $ camelToPathPiece' 1 -embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id - -instance Button UniWorX ButtonAdminStudyTermsParents where - btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary] - btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger] - -data ButtonAdminStudyTermsStandalone - = BtnStandaloneCandidatesDeleteRedundant - | BtnStandaloneCandidatesDeleteAll - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonAdminStudyTermsStandalone -instance Finite ButtonAdminStudyTermsStandalone - -nullaryPathPiece ''ButtonAdminStudyTermsStandalone $ camelToPathPiece' 1 -embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsStandalone id - -instance Button UniWorX ButtonAdminStudyTermsStandalone where - btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary] - btnClasses BtnStandaloneCandidatesDeleteAll = [BCIsButton, BCDanger] - - -{-# ANN postAdminFeaturesR ("HLint: ignore Redundant void" :: String) #-} -getAdminFeaturesR, postAdminFeaturesR :: Handler Html -getAdminFeaturesR = postAdminFeaturesR -postAdminFeaturesR = do - uid <- requireAuthId - ((nameBtnResult, nameBtnWdgt), nameBtnEnctype) <- runFormPost $ identifyForm ("infer-names-button" :: Text) buttonForm - let nameBtnForm = wrapForm nameBtnWdgt def - { formAction = Just $ SomeRoute AdminFeaturesR - , formEncoding = nameBtnEnctype - , formSubmit = FormNoSubmit - } - infNameConflicts <- case nameBtnResult of - FormSuccess BtnNameCandidatesInfer -> do - (infConflicts, infAmbiguous, infRedundantNames, infAccepted) <- Candidates.inferNamesHandler - unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousNameCandidatesRemoved $ length infAmbiguous - unless (null infRedundantNames) . addMessageI Info . MsgRedundantNameCandidatesRemoved $ length infRedundantNames - unless (null infConflicts) $ do - let badKeys = map entityKey infConflicts - setSessionJson SessionConflictingStudyTerms badKeys - addMessageI Warning MsgStudyFeatureConflict - - let newKeys = map fst infAccepted - setSessionJson SessionNewStudyTerms newKeys - - if | null infAccepted - -> addMessageI Info MsgNoNameCandidatesInferred - | otherwise - -> addMessageI Success . MsgNameCandidatesInferred $ length infAccepted - redirect AdminFeaturesR - FormSuccess BtnNameCandidatesDeleteConflicts -> do - runDB $ do - confs <- Candidates.nameConflicts - incis <- Candidates.getNameIncidencesFor $ map entityKey confs - deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)] - addMessageI Success $ MsgIncidencesDeleted $ length incis - redirect AdminFeaturesR - FormSuccess BtnNameCandidatesDeleteAll -> do - runDB $ do - deleteWhere ([] :: [Filter StudyTermNameCandidate]) - addMessageI Success MsgAllNameIncidencesDeleted - redirect AdminFeaturesR - _other -> runDB Candidates.nameConflicts - - ((parentsBtnResult, parentsBtnWdgt), parentsBtnEnctype) <- runFormPost $ identifyForm ("infer-parents-button" :: Text) buttonForm - let parentsBtnForm = wrapForm parentsBtnWdgt def - { formAction = Just $ SomeRoute AdminFeaturesR - , formEncoding = parentsBtnEnctype - , formSubmit = FormNoSubmit - } - formResult parentsBtnResult $ \case - BtnParentCandidatesInfer -> do - (infRedundantParents, infAccepted) <- Candidates.inferParentsHandler - unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents - - let newKeys = map (studySubTermsChild . entityVal) infAccepted - setSessionJson SessionNewStudyTerms newKeys - - if | null infAccepted - -> addMessageI Info MsgNoParentCandidatesInferred - | otherwise - -> addMessageI Success . MsgParentCandidatesInferred $ length infAccepted - redirect AdminFeaturesR - BtnParentCandidatesDeleteAll -> do - runDB $ do - deleteWhere ([] :: [Filter StudySubTermParentCandidate]) - addMessageI Success MsgAllParentIncidencesDeleted - redirect AdminFeaturesR - - ((standaloneBtnResult, standaloneBtnWdgt), standaloneBtnEnctype) <- runFormPost $ identifyForm ("infer-standalone-button" :: Text) buttonForm - let standaloneBtnForm = wrapForm standaloneBtnWdgt def - { formAction = Just $ SomeRoute AdminFeaturesR - , formEncoding = standaloneBtnEnctype - , formSubmit = FormNoSubmit - } - formResult standaloneBtnResult $ \case - BtnStandaloneCandidatesDeleteRedundant -> do - infRedundantStandalone <- runDB Candidates.removeRedundantStandalone - unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone - redirect AdminFeaturesR - BtnStandaloneCandidatesDeleteAll -> do - runDB $ do - deleteWhere ([] :: [Filter StudyTermStandaloneCandidate]) - addMessageI Success MsgAllStandaloneIncidencesDeleted - redirect AdminFeaturesR - - - newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms - badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms - ( (degreeResult,degreeTable) - , (studyTermsResult,studytermsTable) - , ((), candidateTable) - , userSchools - , ((), parentCandidateTable) - , (standaloneResult, standaloneCandidateTable)) <- runDB $ do - schools <- E.select . E.from $ \school -> do - E.where_ . E.exists . E.from $ \schoolFunction -> - E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId - E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid - E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin - return school - (,,,,,) - <$> mkDegreeTable - <*> mkStudytermsTable (Set.fromList newStudyTermKeys) - (Set.fromList $ fromMaybe (map entityKey infNameConflicts) badStudyTermKeys) - (Set.fromList schools) - <*> mkCandidateTable - <*> pure schools - <*> mkParentCandidateTable - <*> mkStandaloneCandidateTable - - let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text)) - degreeResult' = degreeResult <&> getDBFormResult - (\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName - , row ^. _dbrOutput . _entityVal . _studyDegreeShorthand - )) - updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short] - formResult degreeResult' $ \res -> do - void . runDB $ Map.traverseWithKey updateDegree res - addMessageI Success MsgStudyDegreeChangeSuccess - redirect $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text) - - let standaloneResult' :: FormResult (Map (Key StudyTermStandaloneCandidate) (Maybe StudyDegreeId, Maybe StudyFieldType)) - standaloneResult' = standaloneResult <&> getDBFormResult - (\row -> ( row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultDegree . _Just - , row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultType . _Just - )) - formResult standaloneResult' $ \res -> do - updated <- runDB . iforM res $ \candidateId (mDegree, mType) -> do - StudyTermStandaloneCandidate{..} <- getJust candidateId - let termsId = StudyTermsKey' studyTermStandaloneCandidateKey - updated <- case (,) <$> mDegree <*> mType of - Nothing -> return Nothing - Just (degree, typ) -> do - ifM (existsKey termsId) - ( update termsId - [ StudyTermsDefaultDegree =. Just degree - , StudyTermsDefaultType =. Just typ - ] - ) - ( insert_ $ StudyTerms studyTermStandaloneCandidateKey Nothing Nothing (Just degree) (Just typ) - ) - return $ Just termsId - infRedundantStandalone <- Candidates.removeRedundantStandalone - unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone - return updated - - let newKeys = catMaybes $ Map.elems updated - unless (null newKeys) $ do - setSessionJson SessionNewStudyTerms newKeys - - redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text) - - - let studyTermsResult' :: FormResult (Map StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType)) - studyTermsResult' = studyTermsResult <&> getDBFormResult - (\row -> ( row ^? _dbrOutput . _1 . _entityVal . _studyTermsName . _Just - , row ^? _dbrOutput . _1 . _entityVal . _studyTermsShorthand . _Just - , row ^. _dbrOutput . _3 - , row ^. _dbrOutput . _2 . to (Set.map entityKey) - , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree . _Just - , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultType . _Just - )) - updateStudyTerms studyTermsKey (name,short,schools,parents,degree,sType) = do - degreeExists <- fmap (fromMaybe False) . for degree $ fmap (is _Just) . get - update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType] - - forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey - deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools] - - forM_ parents $ void . insertUnique . StudySubTerms studyTermsKey - deleteWhere [StudySubTermsChild ==. studyTermsKey, StudySubTermsParent /<-. Set.toList parents] - formResult studyTermsResult' $ \res -> do - void . runDB $ Map.traverseWithKey updateStudyTerms res - addMessageI Success MsgStudyTermsChangeSuccess - redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text) - - siteLayoutMsg MsgAdminFeaturesHeading $ do - setTitleI MsgAdminFeaturesHeading - $(widgetFile "adminFeatures") - where - textInputCell :: Ord i - => Lens' a (Maybe Text) - -> Getter (DBRow r) (Maybe Text) - -> Getter (DBRow r) i - -> DBRow r - -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) - textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) - (\row _mkUnique -> bimap (fmap $ set lensRes . assertM (not . Text.null)) fvWidget - <$> mopt (textField & cfStrip) "" (Just $ row ^. lensDefault) - ) - - checkboxCell :: Ord i - => Lens' a Bool - -> Getter (DBRow r) Bool - -> Getter (DBRow r) i - -> DBRow r - -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) - checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) - ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget - <$> mpopt checkBoxField "" (Just $ row ^. lensDefault) - ) - - -- termKeyCell :: Ord i - -- => Lens' a (Maybe StudyTermsId) - -- -> Getter (DBRow r) (Maybe StudyTermsId) - -- -> Getter (DBRow r) i - -- -> DBRow r - -- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) - -- termKeyCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) - -- ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvWidget fieldView)) - -- <$> mopt (intField & isoField (from _StudyTermsId)) "" (Just $ row ^. lensDefault) - -- ) - - parentsCell :: Ord i - => Lens' a (Set StudyTermsId) - -> Getter (DBRow r) (Set StudyTermsId) - -> Getter (DBRow r) i - -> DBRow r - -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) - parentsCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) - ( \row mkUnique -> bimap (fmap $ set lensRes . Set.fromList) fvWidget - <$> massInputList - (intField & isoField (from _StudyTermsId)) - (const "") - MsgStudyTermsParentMissing - (Just . SomeRoute . (AdminFeaturesR :#:)) - (mkUnique ("parents" :: Text)) - "" - False - (Just . Set.toList $ row ^. lensDefault) - mempty - ) - - degreeCell :: Ord i - => Lens' a (Maybe StudyDegreeId) - -> Getter (DBRow r) (Maybe StudyDegreeId) - -> Getter (DBRow r) i - -> DBRow r - -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) - degreeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) - ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget - <$> mopt degreeField "" (Just $ row ^. lensDefault) - ) - - fieldTypeCell :: Ord i - => Lens' a (Maybe StudyFieldType) - -> Getter (DBRow r) (Maybe StudyFieldType) - -> Getter (DBRow r) i - -> DBRow r - -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) - fieldTypeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) - ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget - <$> mopt (selectField optionsFinite) "" (Just $ row ^. lensDefault) - ) - - - mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget) - mkDegreeTable = - let dbtIdent = "admin-studydegrees" :: Text - dbtStyle = def - dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree)) - dbtSQLQuery = return - dbtRowKey = (E.^. StudyDegreeKey) - dbtProj = dbtProjId - dbtColonnade = formColonnade $ mconcat - [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey)) - , sortable (Just "name") (i18nCell MsgTableDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey)) - , sortable (Just "short") (i18nCell MsgTableDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey)) - ] - dbtSorting = Map.fromList - [ ("key" , SortColumn (E.^. StudyDegreeKey)) - , ("name" , SortColumn (E.^. StudyDegreeName)) - , ("short", SortColumn (E.^. StudyDegreeShorthand)) - ] - dbtFilter = mempty - dbtFilterUI = mempty - dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text) - } - psValidator = def -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"] - & defaultPagesize PagesizeAll - & defaultSorting [SortAscBy "key"] - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - dbtExtraReps = [] - in dbTable psValidator DBTable{..} - - mkStudytermsTable :: Set StudyTermsId -> Set StudyTermsId -> Set (Entity School) -> DB (FormResult (DBFormResult StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTerms, Set (Entity StudyTerms), Set SchoolId))), Widget) - mkStudytermsTable newKeys badKeys schools = - let dbtIdent = "admin-studyterms" :: Text - dbtStyle = def - dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms)) - dbtSQLQuery = return - dbtRowKey = (E.^. StudyTermsKey) - dbtProj = dbtProjSimple $ \field@(Entity fId _) -> do - fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do - E.where_ . E.exists . E.from $ \schoolTerms -> - E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId - E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId - E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools) - return $ school E.^. SchoolId - fieldParents <- fmap (setOf folded) . E.select . E.from $ \terms -> do - E.where_ . E.exists . E.from $ \subTerms -> - E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId - E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId - return terms - return (field, fieldParents, fieldSchools) - dbtColonnade = formColonnade $ mconcat - [ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey)) - , sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey') - , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey)) - , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey)) - , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) _dbrKey') - , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) _dbrKey') - , sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree) _dbrKey') - , sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultType) _dbrKey') - , flip foldMap schools $ \(Entity ssh School{schoolName}) -> - sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey') - ] - dbtSorting = Map.fromList - [ ("key" , SortColumn $ queryField >>> (E.^. StudyTermsKey)) - -- , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent) - , ("isnew" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys)) - ) - , ("isbad" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys)) - ) - , ("name" , SortColumn $ queryField >>> (E.^. StudyTermsName)) - , ("short" , SortColumn $ queryField >>> (E.^. StudyTermsShorthand)) - , ("degree" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultDegree)) - , ("field-type" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultType)) - ] - dbtFilter = mempty - dbtFilterUI = mempty - dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text) - } - psValidator = def - & defaultPagesize PagesizeAll - & defaultSorting [SortAscBy "isnew", SortAscBy "isbad", SortAscBy "key"] - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - - dbtExtraReps = [] - - queryField = id - _dbrKey' :: Getter (DBRow (Entity StudyTerms, _, _)) StudyTermsId - _dbrKey' = _dbrOutput . _1 . _entityKey - in dbTable psValidator DBTable{..} - - mkCandidateTable = - let dbtIdent = "admin-termcandidate" :: Text - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtSQLQuery :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate)) - dbtSQLQuery = return - dbtRowKey = (E.^. StudyTermNameCandidateId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey)) - , sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName)) - , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateIncidence)) - ] - dbtSorting = Map.fromList - [ ("key" , SortColumn (E.^. StudyTermNameCandidateKey)) - , ("name" , SortColumn (E.^. StudyTermNameCandidateName)) - , ("incidence", SortColumn (E.^. StudyTermNameCandidateIncidence)) - ] - dbtFilter = Map.fromList - [ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateKey)) - , ("name", FilterColumn $ mkContainsFilter (E.^. StudyTermNameCandidateName)) - , ("incidence", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateIncidence)) -- contains filter desired, but impossible here - ] - dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "key" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgStudyTermsKey) - , prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgStudyTermsName) - , prismAForm (singletonFilter "incidence") mPrev $ aopt textField (fslI MsgStudyCandidateIncidence) - ] - dbtParams = def - psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"] - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - dbtExtraReps = [] - in dbTable psValidator DBTable{..} - - mkParentCandidateTable = - let dbtIdent = "admin-termparentcandidate" :: Text - dbtStyle = def - dbtSQLQuery :: E.SqlExpr (Entity StudySubTermParentCandidate) - `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms)) - `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms)) - -> E.SqlQuery ( E.SqlExpr (Entity StudySubTermParentCandidate) - , E.SqlExpr (Maybe (Entity StudyTerms)) - , E.SqlExpr (Maybe (Entity StudyTerms)) - ) - dbtSQLQuery (candidate `E.LeftOuterJoin` parent `E.LeftOuterJoin` child) = do - E.on $ child E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateKey) - E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent) - return (candidate, parent, child) - dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey)) - , sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just)) - , sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent)) - , sortable (Just "parent-name") (i18nCell MsgStudySubTermsParentName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just)) - , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateIncidence)) - ] - dbtSorting = Map.fromList - [ ("child" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateKey)) - , ("child-name", SortColumn $ queryChild >>> (E.?. StudyTermsName) >>> E.joinV) - , ("parent" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateParent)) - , ("parent-name", SortColumn $ queryParent >>> (E.?. StudyTermsName) >>> E.joinV) - , ("incidence", SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateIncidence)) - ] - dbtFilter = mempty - dbtFilterUI = mempty - dbtParams = def - psValidator = def - & defaultSorting [SortAscBy "child", SortAscBy "incidence", SortAscBy "parent"] - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - - dbtExtraReps = [] - - queryCandidate (c `E.LeftOuterJoin` _ `E.LeftOuterJoin` _) = c - queryParent (_ `E.LeftOuterJoin` p `E.LeftOuterJoin` _) = p - queryChild (_ `E.LeftOuterJoin` _ `E.LeftOuterJoin` c) = c - in dbTable psValidator DBTable{..} - - mkStandaloneCandidateTable :: DB (FormResult (DBFormResult StudyTermStandaloneCandidateId (Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTermStandaloneCandidate, Maybe (Entity StudyTerms)))), Widget) - mkStandaloneCandidateTable = - let dbtIdent = "admin-termstandalonecandidate" :: Text - dbtStyle = def - dbtSQLQuery :: E.SqlExpr (Entity StudyTermStandaloneCandidate) - `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms)) - -> E.SqlQuery ( E.SqlExpr (Entity StudyTermStandaloneCandidate) - , E.SqlExpr (Maybe (Entity StudyTerms)) - ) - dbtSQLQuery (candidate `E.LeftOuterJoin` sterm) = do - E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey) - return (candidate, sterm) - dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId) - dbtProj = dbtProjId - dbtColonnade = formColonnade $ mconcat - [ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey)) - , sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just)) - , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateIncidence)) - , sortable Nothing (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _1 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultDegree . _Just) _dbrKey') - , sortable Nothing (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _2 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultType . _Just) _dbrKey') - ] - dbtSorting = Map.fromList - [ ("key" , SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateKey)) - , ("name" , SortColumn $ queryTerm >>> (E.?. StudyTermsName) >>> E.joinV) - , ("incidence", SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateIncidence)) - ] - dbtFilter = mempty - dbtFilterUI = mempty - dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text) - } - psValidator = def - & defaultSorting [SortAscBy "key", SortAscBy "incidence"] - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - - dbtExtraReps = [] - - queryCandidate (c `E.LeftOuterJoin` _) = c - queryTerm (_ `E.LeftOuterJoin` t) = t - _dbrKey' :: Getter (DBRow (Entity StudyTermStandaloneCandidate, _)) StudyTermStandaloneCandidateId - _dbrKey' = _dbrOutput . _1 . _entityKey - in dbTable psValidator DBTable{..} diff --git a/src/Handler/Utils/LdapSystemFunctions.hs b/src/Handler/Utils/LdapSystemFunctions.hs index 8bd2d6c97..913ddb503 100644 --- a/src/Handler/Utils/LdapSystemFunctions.hs +++ b/src/Handler/Utils/LdapSystemFunctions.hs @@ -10,5 +10,6 @@ import qualified Data.Set as Set determineSystemFunctions :: Set (CI Text) -> (SystemFunction -> Bool) determineSystemFunctions ldapFuncs = \case SystemExamOffice -> False - SystemFaculty -> "faculty" `Set.member` ldapFuncs - SystemStudent -> "student" `Set.member` ldapFuncs + SystemFaculty -> "CN=PROJ-Fahrerausbildung Admin_rw,OU=Projekte,OU=Sicherheitsgruppen,DC=fra,DC=fraport,DC=de" `Set.member` ldapFuncs -- Fahrerausbildungadmins are lecturers + -- SJ: not sure this LDAP-specific key belongs here? + SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort