From 2621d36b7d020e67b66e0371004634decc5208fd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 31 Oct 2019 08:59:49 +0100 Subject: [PATCH 1/5] feat(features-of-study): record parent & standalone candidates --- messages/uniworx/de.msg | 4 + models/users.model | 26 +- src/Auth/LDAP.hs | 7 +- src/Database/Esqueleto/Utils/TH.hs | 5 +- src/Foundation.hs | 85 ++++- src/Handler/Admin.hs | 503 +--------------------------- src/Handler/Admin/ErrorMessage.hs | 32 ++ src/Handler/Admin/StudyFeatures.hs | 315 +++++++++++++++++ src/Handler/Admin/Test.hs | 231 +++++++++++++ src/Handler/Utils/StudyFeatures.hs | 27 +- src/Handler/Utils/TermCandidates.hs | 95 ++++-- src/Model/Types/Common.hs | 1 + src/Model/Types/Misc.hs | 1 + src/Utils.hs | 4 - src/Utils/Lens.hs | 10 +- templates/adminFeatures.cassius | 3 + templates/adminFeatures.hamlet | 10 +- templates/course-user.hamlet | 7 +- templates/profileData.hamlet | 7 +- 19 files changed, 805 insertions(+), 568 deletions(-) create mode 100644 src/Handler/Admin/ErrorMessage.hs create mode 100644 src/Handler/Admin/StudyFeatures.hs create mode 100644 src/Handler/Admin/Test.hs create mode 100644 templates/adminFeatures.cassius diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7733ef300..ac10303ba 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1987,3 +1987,7 @@ ShortSexNotApplicable: k.A. ShowSex: Geschlechter anderer Nutzer anzeigen ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden? + +StudySubTermsParentKey: Elter +StudyTermsDefaultDegree: Abschluss +StudyTermsDefaultFieldType: Typ \ No newline at end of file diff --git a/models/users.model b/models/users.model index 216f9ecb8..93453ac1b 100644 --- a/models/users.model +++ b/models/users.model @@ -55,11 +55,13 @@ StudyFeatures -- multiple entries possible for students pursuing several degree user UserId degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. + subField StudySubTermsId Maybe type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach semester Int updated UTCTime default=now() -- last update from LDAP valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets) UniqueStudyFeatures user degree field type semester + deriving Eq -- UniqueUserSubject ubuser degree field -- There exists a counterexample StudyDegree -- Studienabschluss key Int -- LMU-internal key @@ -69,17 +71,35 @@ StudyDegree -- Studienabschluss -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } deriving Show StudyTerms -- Studiengang - key Int -- LMU-internal key + key Int -- standardised key shorthand Text Maybe -- admin determined shorthand name Text Maybe -- description given by LDAP + defaultDegree StudyDegreeId Maybe + defaultType StudyFieldType Maybe Primary key -- column key is used as actual DB row key -- 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. +StudySubTerms + key Int + parent StudyTermsId Maybe + shorthand Text Maybe + name Text Maybe + Primary key + deriving Show +StudyTermNameCandidate -- 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 TermCandidateIncidence -- random id, generated once per login to associate matching pairs - key Int -- a possible key for the studyTermName + key Int -- a possible key for the studyTermName or studySubTermName name Text -- studyTermName as plain text from LDAP deriving Show Eq Ord +StudySubTermParentCandidate + incidence TermCandidateIncidence + key Int + parent Int + deriving Show Eq Ord +StudyTermStandaloneCandidate + incidence TermCandidateIncidence + key Int + deriving Show Eq Ord \ No newline at end of file diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 7863ec34a..bc6a3b686 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -7,7 +7,7 @@ module Auth.LDAP , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName - , ldapUserSchoolAssociation, ldapSex + , ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex ) where import Import.NoFoundation @@ -61,7 +61,7 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not , Ldap.derefAliases Ldap.DerefAlways ] -ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex :: Ldap.Attr +ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester :: Ldap.Attr ldapUserPrincipalName = Ldap.Attr "userPrincipalName" ldapUserDisplayName = Ldap.Attr "displayName" ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer" @@ -69,9 +69,10 @@ ldapUserFirstName = Ldap.Attr "givenName" ldapUserSurname = Ldap.Attr "sn" ldapUserTitle = Ldap.Attr "title" ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" -ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString" +ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach" ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" ldapSex = Ldap.Attr "schacGender" +ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS" ldapUserEmail :: NonEmpty Ldap.Attr ldapUserEmail = Ldap.Attr "mail" :| diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 52cd68cdc..4d0f5b536 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -2,7 +2,7 @@ module Database.Esqueleto.Utils.TH ( SqlIn(..) , sqlInTuple, sqlInTuples , unValueN, unValueNIs - , sqlIJproj, sqlLOJproj + , sqlIJproj, sqlLOJproj, sqlFOJproj ) where import ClassyPrelude @@ -84,3 +84,6 @@ sqlIJproj = leftAssociativePairProjection 'E.InnerJoin sqlLOJproj :: Int -> Int -> ExpQ sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin + +sqlFOJproj :: Int -> Int -> ExpQ +sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin diff --git a/src/Foundation.hs b/src/Foundation.hs index 4b54a9fd1..8fce558c2 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -44,6 +44,7 @@ import qualified Data.Map as Map import qualified Data.HashSet as HashSet import Data.List (nubBy, (!!), findIndex) +import qualified Data.List as List import Data.Monoid (Any(..)) @@ -3504,36 +3505,98 @@ upsertCampusUser ldapData Creds{..} = do Right str <- return $ Text.decodeUtf8' v' return str - fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures + 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 - name <- termNames - StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs - return (key, name) + let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs' + subTermsKeys = unStudySubTermsKey . fst <$> sts + + (,) <$> sfKeys ++ subTermsKeys <*> termNames + + let + assimilateSubTerms :: [(StudySubTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudySubTermsKey, Maybe StudyTermsId)) DB [StudyFeatures] + assimilateSubTerms [] xs = return xs + assimilateSubTerms ((subterm'@(StudySubTermsKey' subterm), subSemester) : subterms) unusedFeats = do + standalone <- lift . get $ StudyTermsKey' subterm + case standalone of + _other + | (_ : matches, unusedFeats') <- partition (\StudyFeatures{..} -> subterm == unStudyTermsKey studyFeaturesField + && subSemester == studyFeaturesSemester + ) unusedFeats + -> assimilateSubTerms subterms $ unusedFeats' ++ matches + | any ((== subterm) . unStudyTermsKey . studyFeaturesField) unusedFeats + -> assimilateSubTerms subterms unusedFeats + Just StudyTerms{..} + | Just defDegree <- studyTermsDefaultDegree + , Just defType <- studyTermsDefaultType + -> (:) (StudyFeatures userId defDegree (StudyTermsKey' subterm) Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats + Nothing + | [] <- unusedFeats -> do + tell $ Set.singleton (subterm, Nothing) + assimilateSubTerms subterms unusedFeats + _other -> do + knownParent <- lift $ (>>= studySubTermsParent) <$> get subterm' + let matchingFeatures = case knownParent of + Just p -> filter ((== p) . studyFeaturesField) unusedFeats + Nothing -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats + unless (is _Just knownParent) . forM_ matchingFeatures $ \StudyFeatures{..} -> + tell $ Set.singleton (subterm, Just studyFeaturesField) + if + | is _Just knownParent + -> (++) (matchingFeatures & traverse . _studyFeaturesSubField %~ (<|> Just subterm')) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures) + | otherwise + -> assimilateSubTerms subterms unusedFeats + (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 - $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) .| sinkHash + $ sourceList ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash - candidatesRecorded <- E.selectExists . E.from $ \candidate -> - E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence + candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate) -> do + 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) unless candidatesRecorded $ do let studyTermCandidates' = do - (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates - return StudyTermCandidate{..} + (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates + let studyTermNameCandidateIncidence = studyTermCandidateIncidence + return StudyTermNameCandidate{..} insertMany_ studyTermCandidates' + let + studySubTermParentCandidates' = do + (studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates + let studySubTermParentCandidateIncidence = studyTermCandidateIncidence + return StudySubTermParentCandidate{..} + studyTermStandaloneCandidates' = do + (studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates + let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence + return StudyTermStandaloneCandidate{..} + insertMany_ studySubTermParentCandidates' + 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 - void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] + insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing + void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True, StudyFeaturesSubField =. studyFeaturesSubField] associateUserSchoolsByTerms userId let diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 3b921bca3..ae605e860 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,36 +1,16 @@ -module Handler.Admin where +module Handler.Admin + ( module Handler.Admin + ) where import Import -import Handler.Utils -import Jobs -import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) -import Control.Monad.Trans.Except -import Control.Monad.Trans.Writer (mapWriterT) - --- import Data.Time -import Data.Char (isDigit) -import qualified Data.Text as Text --- import Data.Function ((&)) --- import Yesod.Form.Bootstrap3 - -import qualified Data.Set as Set -import qualified Data.Map as Map - -import Database.Persist.Sql (fromSqlKey) -import qualified Database.Esqueleto as E -import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter) - -import qualified Handler.Utils.TermCandidates as Candidates - --- import Colonnade hiding (fromMaybe) --- import Yesod.Colonnade - --- import qualified Data.UUID.Cryptographic as UUID +import Handler.Admin.Test as Handler.Admin +import Handler.Admin.ErrorMessage as Handler.Admin +import Handler.Admin.StudyFeatures as Handler.Admin getAdminR :: Handler Html -getAdminR = -- do +getAdminR = siteLayoutMsg MsgAdminHeading $ do setTitleI MsgAdminHeading [whamlet| @@ -38,472 +18,3 @@ getAdminR = -- do Its current purpose is to provide links to some important admin functions |] --- BEGIN - Buttons needed only here -data ButtonCreate = CreateMath | CreateInf -- Dummy for Example - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonCreate -instance Finite ButtonCreate - -nullaryPathPiece ''ButtonCreate camelToPathPiece - -instance Button UniWorX ButtonCreate where - btnLabel CreateMath = [whamlet|Mathematik|] - btnLabel CreateInf = "Informatik" - - btnClasses CreateMath = [BCIsButton, BCInfo] - btnClasses CreateInf = [BCIsButton, BCPrimary] --- END Button needed only here - -emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext) -emailTestForm = (,) - <$> areq emailField (fslI MsgMailTestFormEmail) Nothing - <*> ( MailContext - <$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing) - <*> (toMailDateTimeFormat - <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing - <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing - <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing - ) - ) - where - toMailDateTimeFormat dt d t = \case - SelFormatDateTime -> dt - SelFormatDate -> d - SelFormatTime -> t - -makeDemoForm :: Int -> Form (Int,Bool,Double) -makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do - (result, widget) <- flip (renderAForm FormStandard) html $ (,,) - <$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing - <* aformSection MsgFormBehaviour - <*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True) - <*> areq doubleField "Fliesskommazahl" Nothing - -- NO LONGER DESIRED IN AFORMS: - -- <* submitButton - return $ case result of - FormSuccess fsres - | errorMsgs <- validateResult fsres - , not $ null errorMsgs -> (FormFailure errorMsgs, widget) - _otherwise -> (result, widget) - where - validateResult :: (Int,Bool,Double) -> [Text] - validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"] - validateResult _other = [] - - -getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! -getAdminTestR = postAdminTestR -postAdminTestR = do - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate) - let btnForm = wrapForm btnWdgt def - { formAction = Just $ SomeRoute AdminTestR - , formEncoding = btnEnctype - , formSubmit = FormNoSubmit - } - case btnResult of - (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" - (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" - FormMissing -> return () - _other -> addMessage Warning "KEIN Knopf erkannt" - - ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm - formResultModal emailResult AdminTestR $ \(email, ls) -> do - jId <- mapWriterT runDB $ do - jId <- queueJob $ JobSendTestEmail email ls - tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail) - return jId - runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod - addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal` - - let emailWidget' = wrapForm emailWidget def - { formAction = Just . SomeRoute $ AdminTestR - , formEncoding = emailEnctype - , formAttrs = [("uw-async-form", "")] - } - - - let demoFormAction (_i,_b,_d) = addMessage Info "All ok." - ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7 - formResult demoResult demoFormAction - let showDemoResult = [whamlet| - $maybe (i,b,d) <- formResult' demoResult - Received values: -