fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

feat(study-features): complete StudyFeatures admin-interface

Browse Source
This commit is contained in:
Gregor Kleen 2019-11-27 12:14:19 +01:00
parent 5cd2d39f10
commit c4c82f5439
6 changed files with 139 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/uniworx/de-de-formal.msg
View File

@ -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

4
messages/uniworx/en-eu.msg
View File

@ -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"}

4
src/Foundation.hs
View File

@ -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]

125
src/Handler/Admin/StudyFeatures.hs
View File

@ -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{..}

6
src/Handler/Utils/TermCandidates.hs
View File

@ -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

6
templates/adminFeatures.hamlet
View File

@ -32,3 +32,9 @@ $newline never
<h2>
_{MsgStudyFeaturesParentCandidates}
^{parentCandidateTable}
<section>
<h2>
_{MsgStudyFeaturesStandaloneCandidates}
^{standaloneBtnForm}
^{standaloneCandidateTable}