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

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

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

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]

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 (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 "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") (i18nCell MsgStudySubTermsParentKey)  (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent))
-            , sortable Nothing             (i18nCell MsgStudySubTermsParentName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
+            , 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))
+            , 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{..}

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

templates/adminFeatures.hamlet

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