diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ce399d6a0..0155c491a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -346,7 +346,6 @@ NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter AdminHeading: Administration -AdminFeaturesHeading: Studiengänge AdminUserHeading: Benutzeradministration AccessRightsFor: Berechtigungen für AdminFor: Administrator @@ -408,6 +407,8 @@ SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahr SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. +AdminFeaturesHeading: Studiengänge +StudyFeatureInference: Studiengangschlüssel-Inferenz StudyFeatureAge: Fachsemester StudyFeatureDegree: Abschluss FieldPrimary: Hauptfach @@ -423,6 +424,11 @@ StudyTermsShort: Studiengangkürzel StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert StudyDegreeChangeSuccess: Zuordnung Studiengänge aktualisiert StudyCandidateIncidence: Anmeldevorgang +AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt +RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt +CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert +NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert +StudyTermIsNew: Neu MailTestFormEmail: Email-Addresse MailTestFormLanguages: Spracheinstellungen diff --git a/models/users b/models/users index adc672252..80e5ff43c 100644 --- a/models/users +++ b/models/users @@ -49,17 +49,20 @@ StudyDegree -- Studienabschluss shorthand Text Maybe -- admin determined shorthand name Text Maybe -- description given by LDAP Primary key -- column key is used as actual DB row key + -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } + deriving Show StudyTerms -- Studiengang key Int -- LMU-internal key shorthand Text Maybe -- admin determined shorthand name Text Maybe -- description given by LDAP Primary key -- column key is used as actual DB row key - -- newtype Key StudyTerms = StudyTermsKey { unStudyTermsKey :: Int } + -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } + deriving Show StudyTermCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. -- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations - incidence UUID -- random id, generated once per login to associate matching pairs + incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs key Int -- a possible key for the studyTermName name Text -- studyTermName as plain text from LDAP deriving Show Eq Ord diff --git a/src/Foundation.hs b/src/Foundation.hs index adc685fa0..282b0111e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2097,11 +2097,11 @@ instance YesodAuth UniWorX where fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures let - studyTermCandidates = Set.fromList $ do + studyTermCandidates = do studyTermCandidateName <- termNames StudyFeatures{ studyFeaturesField = StudyTermsKey' studyTermCandidateKey } <- fs return StudyTermCandidate{..} - lift . insertMany_ $ Set.toList studyTermCandidates + lift $ insertMany_ studyTermCandidates lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] forM_ fs $ \f@StudyFeatures{..} -> do diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a9d5afa59..bf5a29f6d 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -15,7 +15,7 @@ import Utils.Lens -- import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 --- import qualified Data.Set as Set +import qualified Data.Set as Set import qualified Data.Map as Map import Database.Persist.Sql (fromSqlKey) @@ -56,7 +56,7 @@ instance Button UniWorX ButtonCreate where btnClasses CreateMath = [BCIsButton, BCInfo] btnClasses CreateInf = [BCIsButton, BCPrimary] --- END Button needed here +-- END Button needed only here emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) emailTestForm = (,) @@ -176,17 +176,40 @@ postAdminErrMsgR = do |] +-- BEGIN - Buttons needed only for StudyTermCandidateManagement +data ButtonInferStudyTerms = ButtonInferStudyTerms + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonInferStudyTerms +instance Finite ButtonInferStudyTerms + +nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece + +instance Button UniWorX ButtonInferStudyTerms where + btnLabel ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen" + btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary] +-- END Button needed only here getAdminFeaturesR, postAdminFeaturesR :: Handler Html getAdminFeaturesR = postAdminFeaturesR postAdminFeaturesR = do + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonInferStudyTerms) + (infConflicts,infAccepted) <- case btnResult of + (FormSuccess ButtonInferStudyTerms) -> do + (infConflicts,infAmbiguous,infRedundant,infAccepted) <- Candidates.inferHandler + unless (null infAmbiguous) $ addMessageI Info $ MsgAmbiguousCandidatesRemoved $ length infAmbiguous + unless (null infRedundant) $ addMessageI Info $ MsgRedundantCandidatesRemoved $ length infRedundant + if (null infAccepted) + then addMessageI Info $ MsgNoCandidatesInferred + else addMessageI Success $ MsgCandidatesInferred $ length infAccepted + return (infConflicts,infAccepted) + _other -> (,[]) <$> runDB Candidates.conflicts + unless (null infConflicts) $ addMessage Warning "KONFLIKTE vorhanden" --TODO i18n + ( (degreeResult,degreeTable) , (studyTermsResult,studytermsTable) - , conflicted - , ((),candidateTable)) <- runDB $ (,,,) + , ((),candidateTable)) <- runDB $ (,,) <$> mkDegreeTable - <*> mkStudytermsTable - <*> Candidates.conflicts + <*> mkStudytermsTable (Set.fromList $ map (StudyTermsKey' . fst) infAccepted) <*> mkCandidateTable let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text)) @@ -211,25 +234,7 @@ postAdminFeaturesR = do siteLayoutMsg MsgAdminFeaturesHeading $ do setTitleI MsgAdminFeaturesHeading - [whamlet| -
-
- ^{degreeTable} -
-
- ^{studytermsTable} -
-
- $if null conflicted - Kein Konflikte beobachtet. - $else -

Studiengangseingträge mit beobachteten Konflikten: -
    - $forall (Entity _ (StudyTerms ky _ nm)) <- conflicted -
  • #{show ky} - #{foldMap id nm} -
    - ^{candidateTable} - |] + $(widgetFile "adminFeatures") where textInputCell lensRes lensDefault = formCell id (return . view (_dbrOutput . _entityKey)) (\row _mkUnique -> (\(res,fieldView) -> (set lensRes <$> res, fvInput fieldView)) @@ -246,23 +251,24 @@ postAdminFeaturesR = do dbtRowKey = (E.^. StudyDegreeKey) dbtProj = return dbtColonnade = formColonnade $ mconcat - [ sortable (Just "degree-key") (i18nCell MsgDegreeKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey)) - , sortable (Just "degree-name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName)) - , sortable (Just "degree-short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand)) + [ sortable (Just "key") (i18nCell MsgDegreeKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey)) + , sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName)) + , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand)) + , dbRow ] dbtSorting = Map.fromList - [ ("degree-key" , SortColumn (E.^. StudyDegreeKey)) - , ("degree-name" , SortColumn (E.^. StudyDegreeName)) - , ("degree-short", SortColumn (E.^. StudyDegreeShorthand)) + [ ("key" , SortColumn (E.^. StudyDegreeKey)) + , ("name" , SortColumn (E.^. StudyDegreeName)) + , ("short", SortColumn (E.^. StudyDegreeShorthand)) ] dbtFilter = mempty dbtFilterUI = mempty dbtParams = def { dbParamsFormAddSubmit = True } -- dbParamsFormEvaluate = liftHandlerT . (runFormPost . identifyForm "degree-table" - (identForm FIDdegree))} - psValidator = def & defaultSorting [SortAscBy "degree-name", SortAscBy "degree-short", SortAscBy "degree-key"] + psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"] in dbTable psValidator DBTable{..} - mkStudytermsTable :: DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget) - mkStudytermsTable = + mkStudytermsTable :: Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget) + mkStudytermsTable newKeys = let dbtIdent = "admin-studyterms" :: Text dbtStyle = def dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms)) @@ -270,19 +276,22 @@ postAdminFeaturesR = do dbtRowKey = (E.^. StudyTermsKey) dbtProj = return dbtColonnade = formColonnade $ mconcat - [ sortable (Just "studyterms-key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey)) - , sortable (Just "studyterms-name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName)) - , sortable (Just "studyterms-short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand)) + [ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey)) + , sortable (Just "isnew") (i18nCell MsgStudyTermIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey)) + , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName)) + , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand)) + , dbRow ] dbtSorting = Map.fromList - [ ("studyterms-key" , SortColumn (E.^. StudyTermsKey)) - , ("studyterms-name" , SortColumn (E.^. StudyTermsName)) - , ("studyterms-short", SortColumn (E.^. StudyTermsShorthand)) + [ ("key" , SortColumn (E.^. StudyTermsKey)) + , ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList newKeys))) + , ("name" , SortColumn (E.^. StudyTermsName)) + , ("short" , SortColumn (E.^. StudyTermsShorthand)) ] dbtFilter = mempty dbtFilterUI = mempty dbtParams = def { dbParamsFormAddSubmit = True } -- , dbParamsFormEvaluate = liftHandlerT . runFormPost } - psValidator = def & defaultSorting [SortAscBy "studyterms-name", SortAscBy "studyterms-short", SortAscBy "studyterms-key"] + psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"] in dbTable psValidator DBTable{..} mkCandidateTable = @@ -293,14 +302,15 @@ postAdminFeaturesR = do dbtRowKey = (E.^. StudyTermCandidateId) dbtProj = return dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "termcandidate-key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermCandidateKey)) - , sortable (Just "termcandidate-name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermCandidateName)) - , sortable (Just "termcandidate-incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermCandidateIncidence)) + [ dbRow + , sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermCandidateKey)) + , sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermCandidateName)) + , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermCandidateIncidence)) ] dbtSorting = Map.fromList - [ ("termcandidate-key" , SortColumn (E.^. StudyTermCandidateKey)) - , ("termcandidate-name" , SortColumn (E.^. StudyTermCandidateName)) - , ("termcandidate-incidence", SortColumn (E.^. StudyTermCandidateIncidence)) + [ ("key" , SortColumn (E.^. StudyTermCandidateKey)) + , ("name" , SortColumn (E.^. StudyTermCandidateName)) + , ("incidence", SortColumn (E.^. StudyTermCandidateIncidence)) ] dbtFilter = Map.fromList [ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermCandidateKey)) @@ -314,6 +324,6 @@ postAdminFeaturesR = do , prismAForm (singletonFilter "incidence") mPrev $ aopt (searchField False) (fslI MsgStudyCandidateIncidence) ] dbtParams = def - psValidator = def & defaultSorting [SortAscBy "termcandidate-key", SortAscBy "termcandidate-name"] + psValidator = def & defaultSorting [SortAscBy "key", SortAscBy "name"] in dbTable psValidator DBTable{..} diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index d4b9e5249..7abd6b4d7 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -57,6 +57,10 @@ sqlCell act = mempty & cellContents .~ lift act tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a tickmarkCell = cell . toWidget . hasTickmark +-- | Maybe display a exclamation icon +isNewCell :: (IsDBTable m a) => Bool -> DBCell m a +isNewCell = cell . toWidget . isNew + -- | Maybe display comment icon linking a given URL or show nothing at all commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a commentCell Nothing = mempty diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index def3fff41..48fdec8cb 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/src/Handler/Utils/TermCandidates.hs @@ -28,13 +28,10 @@ import qualified Database.Esqueleto as E -- import Database.Esqueleto.Utils as E -type STKey = Int -- Key StudyTerms -- for convenience, assmued identical to field StudyTermCandidateKey +type STKey = Int -- for convenience, assmued identical to field StudyTermCandidateKey data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms] - deriving (Typeable) - -instance Show FailedCandidateInference where - show (FailedCandidateInference _) = "Failed Candidate Inference" -- TODO + deriving (Typeable, Show) instance Exception FailedCandidateInference -- Default Instance @@ -43,54 +40,30 @@ instance Exception FailedCandidateInference shortenStudyTerm :: Text -> Text shortenStudyTerm = concatMap (take 4) . splitCamel --- | Attempt to identify new StudyTerms based on observations -inferHandler :: Handler ([UUID],([Entity StudyTerms],[Entity StudyTermCandidate],[(STKey,Text)])) -inferHandler = do - (ambiguous, problems) <- runDB $ (,) <$> removeAmbiguous <*> conflicts - if (null problems) - then do - infRes <- inferAcc ([],[]) - return (ambiguous, infRes) - else - return (ambiguous,(problems,[],[])) - +-- | Attempt to identify new StudyTerms based on observations, returning: +-- * list of ambiguous instances that were discarded outright (identical names for differents keys observed in single incidences) +-- * list of problems, ie. StudyTerms that contradict observed incidences +-- * list of redundants, i.e. redundant observed incidences +-- * list of accepted, i.e. newly accepted key/name pairs +inferHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermCandidate],[(STKey,Text)]) +inferHandler = runDB $ inferAcc ([],[],[]) where - inferAcc (accRedundants, accAccepted) = - handle (\(FailedCandidateInference fails) -> return (fails,accRedundants,accAccepted)) $ do - (infReds,infAccs) <- runDB inferStep + inferAcc (accAmbiguous, accRedundants, accAccepted) = + handle (\(FailedCandidateInference fails) -> (fails,accAmbiguous,accRedundants,accAccepted) <$ E.transactionUndo) $ do + (infAmbis, infReds,infAccs) <- inferStep if null infAccs - then return ([], infReds ++ accRedundants, accAccepted) - else inferAcc (infReds ++ accRedundants, infAccs ++ accAccepted) + then return ([], accAmbiguous, infReds ++ accRedundants, accAccepted) + else do + E.transactionSave -- commit transaction if there are no problems + inferAcc (infAmbis ++ accAmbiguous, infReds ++ accRedundants, infAccs ++ accAccepted) inferStep = do + ambiguous <- removeAmbiguous redundants <- removeRedundant accepted <- acceptSingletons problems <- conflicts - when (not $ null problems) $ throw $ FailedCandidateInference problems - return (redundants, accepted) - - --- | Attempt to identify new StudyTerms based on observations --- infer :: MonadHandler m => m ([Entity StudyTerms],[Entity StudyTerms]) -infer :: DB ([Entity StudyTerms],[(STKey, Text)]) -infer = do - void removeAmbiguous -- TODO: show result - inferAcc [] - where - inferAcc prevSet = do - problems <- conflicts - if null problems - then do - void removeRedundant -- TODO: show result - newSet <- acceptSingletons - if null newSet - then -- inference complete - return ([],prevSet) - else - inferAcc (newSet ++ prevSet) - else --abort - return (problems,prevSet) - + when (not $ null problems) $ throwM $ FailedCandidateInference problems + return (ambiguous, redundants, accepted) {- Candidate 1 11 "A" @@ -113,7 +86,7 @@ as a fix we simply eliminate all observations that have the same name twice, see -- | remove candidates with ambiguous observations, -- ie. candidates that have duplicated term names with differing keys -- which may happen in rare cases -removeAmbiguous :: DB [UUID] +removeAmbiguous :: DB [TermCandidateIncidence] removeAmbiguous = do ambiList <- E.select $ E.from $ \(candA `E.InnerJoin` candB) -> do -- Either an innerJoin with itself or an exists-sub-select @@ -165,7 +138,7 @@ acceptSingletons = do groupedCandidates = foldl' groupFun mempty incidences -- given a key, map each incidence to set of possible names for this key - groupFun :: Map STKey (Map UUID (Set Text)) -> StudyTermCandidate -> Map STKey (Map UUID (Set Text)) + groupFun :: Map STKey (Map TermCandidateIncidence (Set Text)) -> StudyTermCandidate -> Map STKey (Map TermCandidateIncidence (Set Text)) groupFun m StudyTermCandidate{..} = insertWith (Map.unionWith Set.union) studyTermCandidateKey @@ -192,37 +165,11 @@ acceptSingletons = do -- insertKey (StudyTermsKey key) $ StudyTerms key (Just $ shortenStudyTerm name) (Just name) -- name clash! void . insert $ StudyTerms key (Just $ shortenStudyTerm name) (Just name) - -- register newly fixed candidates forM_ fixedKeys registerFixed return fixedKeys - -- SOME EARLIER ATTEMPTS FOLLOW: - -- - -- unknownKeys <- E.select $ E.distinct $ E.from $ \candidate -> do - -- E.where_ $ E.notExists $ E.from $ \sterm -> - -- E.where_ $ candidate E.^. StudyTermCandidateKey E.==. sterm E.^. StudyTermKey - -- return $ candidate E.^. StudyTermCandidateKey - -- forM unknownKeys $ \(E.Value key) -> do - -- incidences <- E.select $ E.from $ \candidate -> do - -- E.where_ $ - -- - -- -- DON'T KNOW HOW TO DO IN SQL :( BUT WE NEED THE ENTIRE TABLE ANYHOW - -- candidates <- entityVal <$> selectList [] [] -- load entire candidate table - -- -- create map from UUID to set of candidates for efficiency - -- let collectCandidates m stc@StudyTermCandidate{studyTermCandidateIncidence=inci} - -- = insertWith Set.union inci stc - -- incidences = foldl collectCandidates Map.empty candidates - -- - -- collectKeys m - -- keySets = foldl collectKeys Map.empty candidates - -- - -- -- StudyTermCandidateKey -> Set StudyTermCandidateName - - - - -- | all existing StudyTerms that are contradiced by current observations conflicts :: DB [Entity StudyTerms] conflicts = E.select $ E.from $ \studyTerms -> do diff --git a/src/Model/Types.hs b/src/Model/Types.hs index d9cd98342..52fd5ed32 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -785,3 +785,4 @@ type UserEmail = CI Email type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type InstanceId = UUID +type TermCandidateIncidence = UUID diff --git a/src/Utils.hs b/src/Utils.hs index 965a32f66..25142c944 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -161,6 +161,11 @@ hasTickmark :: Bool -> Markup hasTickmark True = [shamlet||] hasTickmark False = mempty +isNew :: Bool -> Markup +isNew True = [shamlet||] +isNew False = mempty + + --------------------- -- Text and String -- --------------------- diff --git a/templates/adminFeatures.hamlet b/templates/adminFeatures.hamlet new file mode 100644 index 000000000..bda21478b --- /dev/null +++ b/templates/adminFeatures.hamlet @@ -0,0 +1,19 @@ +
    + ^{degreeTable} +
    + ^{studytermsTable} +
    +

    _{MsgStudyFeatureInference} +

    + $if null infConflicts + Kein Konflikte beobachtet. + $else +

    Studiengangseingträge mit beobachteten Konflikten: +
      + $forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts +
    • #{show ky} - #{foldMap id nm} +
      + ^{btnWdgt} + +
      + ^{candidateTable}