diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 97cf7991c..89f502ad9 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -22,6 +22,8 @@ BtnNameCandidatesDeleteConflicts: Namenskonflikte löschen BtnNameCandidatesDeleteAll: Alle Namens-Beobachtungen löschen BtnParentCandidatesInfer: Unterstudiengangs-Zuordnung automatisch lernen BtnParentCandidatesDeleteAll: Alle Unterstudiengangs-Beobachtungen löschen +BtnStandaloneCandidatesDeleteAll: Alle Einzelstudiengangs-Beobachtungen löschen +BtnStandaloneCandidatesDeleteRedundant: Redundante Einzelstudiengangs-Beobachtungen löschen BtnResetTokens: Authorisierungs-Tokens invalidieren BtnLecInvAccept: Annehmen BtnLecInvDecline: Ablehnen @@ -767,6 +769,7 @@ StudyFeaturesDegrees: Abschlüsse StudyFeaturesTerms: Studiengänge StudyFeaturesNameCandidates: Namens-Kandidaten StudyFeaturesParentCandidates: Kandidaten für Unterstudiengänge +StudyFeaturesStandaloneCandidates: Kandidaten für Einzelstudiengänge StudyFeatureNameInference: Studiengangschlüssel-Inferenz StudyFeatureParentInference: Unterstudiengang-Inferenz StudyFeatureInferenceNoNameConflicts: Keine Konflikte beobachtet @@ -801,6 +804,7 @@ ParentCandidatesInferred n@Int: #{show n} #{pluralDE n "neuer Unterstudiengang" NoParentCandidatesInferred: Keine neuen Unterstudiengänge inferiert AllNameIncidencesDeleted: Alle Namens-Beobachtungen wurden gelöscht. AllParentIncidencesDeleted: Alle Unterstudiengang-Beobachtungen wurden gelöscht. +AllStandaloneIncidencesDeleted: Alle Einzelstudiengang-Beobachtungen wurden gelöscht. IncidencesDeleted n@Int: #{show n} #{pluralDE n "Beobachtung" "Beobachtungen"} gelöscht StudyTermIsNew: Neu StudyFeatureConflict: Es wurden Konflikte in der Studiengang-Zuordnung gefunden diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index b2bcae6f2..818b327c4 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -22,6 +22,8 @@ BtnNameCandidatesDeleteConflicts: Delete name-conflicts BtnNameCandidatesDeleteAll: Delete all name-observations BtnParentCandidatesInfer: Infer parent-relation BtnParentCandidatesDeleteAll: Delete all parent-observations +BtnStandaloneCandidatesDeleteAll: Delete all standalone-observations +BtnStandaloneCandidatesDeleteRedundant: Delete redundant standalone-observations BtnResetTokens: Invalidate tokens BtnLecInvAccept: Accept BtnLecInvDecline: Decline @@ -764,6 +766,7 @@ StudyFeaturesDegrees: Degrees StudyFeaturesTerms: Terms of Study StudyFeaturesNameCandidates: Name candidates StudyFeaturesParentCandidates: Parent candidates +StudyFeaturesStandaloneCandidates: Standalone candidates StudyFeatureNameInference: Infer field of study mapping StudyFeatureParentInference: Infer field of study parent relation StudyFeatureInferenceNoNameConflicts: No observed conflicts @@ -796,6 +799,7 @@ NameCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping NoNameCandidatesInferred: No new name-mappings inferred AllNameIncidencesDeleted: Successfully deleted all name observations AllParentIncidencesDeleted: Successfully deleted all parent-relation observations +AllStandaloneIncidencesDeleted: Successfully deleted all standalone observations ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"} NoParentCandidatesInferred: No new parent-relations inferred IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"} diff --git a/src/Foundation.hs b/src/Foundation.hs index 389163364..483064a9f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -3484,11 +3484,13 @@ upsertCampusUser ldapData Creds{..} = 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_ studySubTermParentCandidates' insertMany_ studyTermStandaloneCandidates' E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs index abfa5f831..02c45f97a 100644 --- a/src/Handler/Admin/StudyFeatures.hs +++ b/src/Handler/Admin/StudyFeatures.hs @@ -47,6 +47,20 @@ 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] getAdminFeaturesR, postAdminFeaturesR :: Handler Html @@ -64,7 +78,6 @@ postAdminFeaturesR = 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 infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone unless (null infConflicts) $ do let badKeys = map entityKey infConflicts setSessionJson SessionConflictingStudyTerms badKeys @@ -117,6 +130,23 @@ postAdminFeaturesR = do 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 @@ -124,14 +154,15 @@ postAdminFeaturesR = do , (studyTermsResult,studytermsTable) , ((), candidateTable) , userSchools - , ((), parentCandidateTable)) <- runDB $ do + , ((), 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) @@ -139,6 +170,7 @@ postAdminFeaturesR = do <*> mkCandidateTable <*> pure schools <*> mkParentCandidateTable + <*> mkStandaloneCandidateTable let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text)) degreeResult' = degreeResult <&> getDBFormResult @@ -151,6 +183,38 @@ postAdminFeaturesR = do 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 @@ -395,15 +459,17 @@ postAdminFeaturesR = do dbtProj = return dbtColonnade = dbColonnade $ mconcat [ dbRow - , sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey)) - , sortable Nothing (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just)) - , sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent)) - , sortable Nothing (i18nCell MsgStudySubTermsParentName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just)) - , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateIncidence)) + , 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 @@ -415,5 +481,48 @@ postAdminFeaturesR = do dbtCsvDecode = Nothing 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 = return + dbtColonnade = formColonnade $ mconcat + [ dbRow + , 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 + + 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/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index 4f61eb195..729fd0eaa 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/src/Handler/Utils/TermCandidates.hs @@ -252,7 +252,11 @@ acceptSingletonParents = do = ((k, p) : acc, bad) | otherwise = (acc, bad) - inserted <- forM fixedParents $ \(key, parent) -> + inserted <- forM fixedParents $ \(key, parent) -> do + unlessM (existsKey $ StudyTermsKey' key) $ + insert_ (StudyTerms key Nothing Nothing Nothing Nothing) + unlessM (existsKey $ StudyTermsKey' parent) $ + insert_ (StudyTerms parent Nothing Nothing Nothing Nothing) insertUnique $ StudySubTerms { studySubTermsChild = StudyTermsKey' key , studySubTermsParent = StudyTermsKey' parent diff --git a/templates/adminFeatures.hamlet b/templates/adminFeatures.hamlet index 49b28758a..8bbf0b8b8 100644 --- a/templates/adminFeatures.hamlet +++ b/templates/adminFeatures.hamlet @@ -32,3 +32,9 @@ $newline never

_{MsgStudyFeaturesParentCandidates} ^{parentCandidateTable} +
+

+ _{MsgStudyFeaturesStandaloneCandidates} + ^{standaloneBtnForm} + + ^{standaloneCandidateTable}