diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index b31708c48..e633cd1b1 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -26,6 +26,7 @@ module Database.Esqueleto.Utils , fromSqlKey , selectCountRows , selectMaybe + , day , module Database.Esqueleto.Utils.TH ) where @@ -325,3 +326,7 @@ selectCountRows q = do selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) + + +day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) +day = E.unsafeSqlCastAs "date" diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 6ec813d2a..211b9b524 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -22,6 +22,8 @@ import Jobs.Queue import Handler.Submission.List +import Handler.Utils.StudyFeatures + import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI @@ -93,10 +95,12 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = (mRegistration, studies) <- lift . runDB $ do registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid - studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do - E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid + studies <- E.select $ E.from $ \(course `E.InnerJoin` studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do + E.on $ isCourseStudyFeature course studyfeat E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid + E.where_ $ course E.^. CourseId E.==. E.val cid return (studyfeat, studydegree, studyterms) return (registration, studies) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 0df3cf49b..a948e0bef 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -16,6 +16,7 @@ import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Handler.Course.Register (deregisterParticipant) +import Handler.Utils.StudyFeatures import qualified Data.Set as Set import qualified Data.Map as Map @@ -85,6 +86,7 @@ type UserTableData = DBRow ( Entity User , [Entity Exam] , Maybe (Entity SubmissionGroup) , Map SheetName (SheetType, Maybe Points) + , UserTableStudyFeatures ) instance HasEntity UserTableData User where @@ -114,6 +116,9 @@ _userSubmissionGroup = _dbrOutput . _6 . _Just _userSheets :: Lens' UserTableData (Map SheetName (SheetType, Maybe Points)) _userSheets = _dbrOutput . _7 +_userStudyFeatures :: Lens' UserTableData UserTableStudyFeatures +_userStudyFeatures = _dbrOutput . _8 + colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment tid ssh csh = @@ -161,20 +166,12 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns _other -> mempty -data UserTableCsvStudyFeature = UserTableCsvStudyFeature - { csvUserField :: Text - , csvUserDegree :: Text - , csvUserSemester :: Int - , csvUserType :: StudyFieldType - } deriving (Eq, Ord, Read, Show, Generic, Typeable) -makeLenses_ ''UserTableCsvStudyFeature - data UserTableCsv = UserTableCsv { csvUserName :: Text , csvUserSex :: Maybe Sex , csvUserMatriculation :: Maybe Text , csvUserEmail :: CI Email - , csvUserStudyFeatures :: Set UserTableCsvStudyFeature + , csvUserStudyFeatures :: UserTableStudyFeatures , csvUserSubmissionGroup :: Maybe SubmissionGroupName , csvUserRegistration :: UTCTime , csvUserNote :: Maybe Html @@ -190,13 +187,8 @@ instance Csv.ToNamedRecord UserTableCsv where , "sex" Csv..= csvUserSex , "matriculation" Csv..= csvUserMatriculation , "email" Csv..= csvUserEmail - ] ++ let featsStr = Text.intercalate "; " . flip map (Set.toList csvUserStudyFeatures) $ \UserTableCsvStudyFeature{..} - -> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType - in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|] - in [ "study-features" Csv..= featsStr - ] - ++ - [ "submission-group" Csv..= csvUserSubmissionGroup + , "study-features" Csv..= csvUserStudyFeatures + , "submission-group" Csv..= csvUserSubmissionGroup ] ++ [ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1 in "tutorial" Csv..= tutsStr @@ -241,9 +233,7 @@ userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExpo userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ [ "name" ] ++ [ "sex" | showSex ] ++ - [ "matriculation", "email" - ] ++ - ["study-features"] ++ + [ "matriculation", "email", "study-features"] ++ [ "tutorial" | hasEmptyRegGroup ] ++ map (encodeUtf8 . CI.foldedCase) regGroups ++ [ "exams", "registration" ] ++ @@ -337,13 +327,14 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , submission ) ) + feats <- courseUserStudyFeatures (participant ^. _entityVal . _courseParticipantCourse) (participant ^. _entityVal . _courseParticipantUser) let regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts' exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs' - return (user, participant, userNoteId, tuts, exs, subGroup, subs) + return (user, participant, userNoteId, tuts, exs, subGroup, subs, feats) dbtColonnade = colChoices dbtSorting = mconcat [ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header @@ -451,27 +442,13 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do return $ DBTCsvEncode { dbtCsvExportForm = UserCsvExportData <$> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def) - , dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ + , dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(_, row) -> flip runReaderT row $ UserTableCsv <$> view (hasUser . _userDisplayName) <*> view (hasUser . _userSex) <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userEmail) - <*> (do - feats <- lift . E.select . E.from $ \(feat `E.InnerJoin` terms `E.InnerJoin` degree) -> do - E.on $ degree E.^. StudyDegreeId E.==. feat E.^. StudyFeaturesDegree - E.on $ terms E.^. StudyTermsId E.==. feat E.^. StudyFeaturesField - E.where_ $ feat E.^. StudyFeaturesValid - E.where_ $ feat E.^. StudyFeaturesUser E.==. E.val uid - return (terms, degree, feat) - return . Set.fromList . flip map feats $ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> - UserTableCsvStudyFeature - { csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName - , csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName - , csvUserSemester = studyFeaturesSemester - , csvUserType = studyFeaturesType - } - ) + <*> view _userStudyFeatures <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> view _userTableRegistration <*> userNote diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index b59a39977..a833073f6 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -22,7 +22,6 @@ import Generics.Deriving.Monoid data AddRecipientsResult = AddRecipientsResult { aurAlreadyRegistered - , aurNoUniquePrimaryField , aurNoCourseRegistration , aurSuccess , aurSuccessCourse :: [UserEmail] @@ -101,11 +100,6 @@ postEAddUserR tid ssh csh examn = do unless (null aurSuccess) $ tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length aurSuccess - unless (null aurNoUniquePrimaryField) $ do - let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}|] - modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField") - tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) - unless (null aurNoCourseRegistration) $ do let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}|] modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse") @@ -137,11 +131,6 @@ postEAddUserR tid ssh csh examn = do guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True) - features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] - - let courseParticipantField - | [f] <- features = Just f - | otherwise = Nothing lift . lift . void $ upsert CourseParticipant @@ -160,8 +149,6 @@ postEAddUserR tid ssh csh examn = do lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid lift $ lift examRegister - return $ case courseParticipantField of - Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } - Just _ -> mempty { aurSuccessCourse = pure userEmail } + return $ mempty { aurSuccessCourse = pure userEmail } diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs index 2a21e24c7..272a9771f 100644 --- a/src/Handler/Utils/ExamOffice/Exam.hs +++ b/src/Handler/Utils/ExamOffice/Exam.hs @@ -5,6 +5,8 @@ module Handler.Utils.ExamOffice.Exam import Import.NoFoundation +import Handler.Utils.StudyFeatures + import qualified Database.Esqueleto as E resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office @@ -33,7 +35,9 @@ examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (E.Value Bool) examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. authBySchool where - authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do + authByField = E.exists . E.from $ \(course `E.InnerJoin` examOfficeField `E.InnerJoin` studyFeatures) -> do + E.on $ isCourseStudyFeature course studyFeatures + E.&&. course E.^. CourseId E.==. E.subSelectForeign examResult ExamResultExam (\exam -> E.subSelectForeign exam ExamCourse (E.^. CourseId)) E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. examResult E.^. ExamResultUser E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId @@ -42,12 +46,10 @@ examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. E.||. E.exists (E.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. authId E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice - E.&&. E.not_ (E.exists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` courseUserExamOfficeOptOut) -> do - E.on $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. course E.^. CourseId - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - E.where_ $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam - E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser - E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool + E.&&. E.not_ (E.exists . E.from $ \courseUserExamOfficeOptOut -> + E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. course E.^. CourseId + E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser + E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool ) ) diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs index 9dcac4d84..c509516a4 100644 --- a/src/Handler/Utils/ExamOffice/ExternalExam.hs +++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs @@ -4,6 +4,7 @@ module Handler.Utils.ExamOffice.ExternalExam ) where import Import.NoFoundation +import Handler.Utils.StudyFeatures import qualified Database.Esqueleto as E @@ -34,7 +35,9 @@ examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (E.Value Bool) examOfficeExternalExamResultAuth authId eexamResult = authByUser E.||. authByField E.||. authBySchool E.||. authByExtraSchool where - authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do + authByField = E.exists . E.from $ \(externalExam `E.InnerJoin` examOfficeField `E.InnerJoin` studyFeatures) -> do + E.on $ isExternalExamStudyFeature externalExam studyFeatures + E.&&. externalExam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. eexamResult E.^. ExternalExamResultUser E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 80d7d1681..10dffa21e 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -1,70 +1,112 @@ module Handler.Utils.StudyFeatures - ( parseStudyFeatures - , parseSubTermsSemester + ( module Handler.Utils.StudyFeatures.Parse + , UserTableStudyFeature(..) + , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType + , UserTableStudyFeatures(..) + , isCourseStudyFeature, courseUserStudyFeatures + , isExternalExamStudyFeature, externalExamUserStudyFeatures ) where -import Import.NoFoundation hiding (try, (<|>)) +import Import.NoFoundation +import Foundation.Type +import Foundation.I18n -import Text.Parsec -import Text.Parsec.Text +import Handler.Utils.StudyFeatures.Parse -import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures) -import qualified Ldap.Client as Ldap +import qualified Data.Csv as Csv + +import qualified Data.ByteString as ByteString + +import qualified Data.Set as Set + +import Data.RFC5051 (compareUnicode) + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E -parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures] -parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key) - where - Ldap.Attr key = ldapUserStudyFeatures +data UserTableStudyFeature = UserTableStudyFeature + { userTableField + , userTableDegree :: Text + , userTableSemester :: Int + , userTableFieldType :: StudyFieldType + } deriving (Eq, Ord, Read, Show, Generic, Typeable) +makeLenses_ ''UserTableStudyFeature -parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int) -parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key) - where - Ldap.Attr key = ldapUserSubTermsSemester +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + } ''UserTableStudyFeature +newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeature) + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (ToJSON, FromJSON) +makeWrapped ''UserTableStudyFeatures -pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures] -pStudyFeatures studyFeaturesUser now = do - studyFeaturesDegree <- StudyDegreeKey' <$> pKey - void $ string "$$" +instance Csv.ToField UserTableStudyFeature where + toField UserTableStudyFeature{..} = encodeUtf8 + [st|#{userTableField} #{userTableDegree} (#{userTableFieldType'} #{tshow userTableSemester})|] + where userTableFieldType' = renderMessage + (error "Foundation inspected during renderMessage" :: UniWorX) + [] $ ShortStudyFieldType userTableFieldType - let - pStudyFeature = do - _ <- pKey -- "Fächergruppe" - void $ char '!' - _ <- pKey -- "Studienbereich" - void $ char '!' - studyFeaturesField <- StudyTermsKey' <$> pKey - void $ char '!' - studyFeaturesType <- pType - void $ char '!' - studyFeaturesSemester <- decimal - let studyFeaturesValid = True - studyFeaturesSuperField = Nothing - studyFeaturesFirstObserved = Just now - studyFeaturesLastObserved = now - return StudyFeatures{..} +instance Csv.ToField UserTableStudyFeatures where + toField = ByteString.intercalate "; " . map Csv.toField . sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped - pStudyFeature `sepBy1` char '#' +userTableStudyFeatureSort :: UserTableStudyFeature + -> UserTableStudyFeature + -> Ordering +userTableStudyFeatureSort = mconcat + [ compareUnicode `on` userTableDegree + , comparing userTableSemester + , comparing userTableFieldType + , compareUnicode `on` userTableField + ] + -pKey :: Parser Int -pKey = decimal +isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) +isCourseStudyFeature course studyFeatures + = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved) + E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart + where termEnd = E.subSelectForeign course CourseTerm (E.^. TermEnd) + termStart = E.subSelectForeign course CourseTerm (E.^. TermStart) -pType :: Parser StudyFieldType -pType = FieldPrimary <$ try (string "HF") - <|> FieldSecondary <$ try (string "NF") +courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures +courseUserStudyFeatures cId uid = do + feats <- E.select . E.from $ \(course `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do + E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree + E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField + E.on $ isCourseStudyFeature course studyFeatures + E.where_ $ course E.^. CourseId E.==. E.val cId + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid + return (terms, degree, studyFeatures) + return . UserTableStudyFeatures . Set.fromList . flip map feats $ + \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature + { userTableField = fromMaybe (tshow studyTermsKey) studyTermsName + , userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName + , userTableSemester = studyFeaturesSemester + , userTableFieldType = studyFeaturesType + } -decimal :: Parser Int -decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit' - where - digit' = dVal <$> digit - dVal c = fromEnum c - fromEnum '0' +isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) +isExternalExamStudyFeature externalExam studyFeatures + = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved) + E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart + where termEnd = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermEnd) + termStart = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermStart) - -pLMUTermsSemester :: Parser (StudyTermsId, Int) -pLMUTermsSemester = do - subTermsKey <- StudyTermsKey' <$> pKey - void $ char '$' - semester <- decimal - - return (subTermsKey, semester) +externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures +externalExamUserStudyFeatures eeId uid = do + feats <- E.select . E.from $ \(externalExam `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do + E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree + E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField + E.on $ isExternalExamStudyFeature externalExam studyFeatures + E.where_ $ externalExam E.^. ExternalExamId E.==. E.val eeId + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid + return (terms, degree, studyFeatures) + return . UserTableStudyFeatures . Set.fromList . flip map feats $ + \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature + { userTableField = fromMaybe (tshow studyTermsKey) studyTermsName + , userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName + , userTableSemester = studyFeaturesSemester + , userTableFieldType = studyFeaturesType + } diff --git a/src/Handler/Utils/StudyFeatures/Parse.hs b/src/Handler/Utils/StudyFeatures/Parse.hs new file mode 100644 index 000000000..3001c258f --- /dev/null +++ b/src/Handler/Utils/StudyFeatures/Parse.hs @@ -0,0 +1,70 @@ +module Handler.Utils.StudyFeatures.Parse + ( parseStudyFeatures + , parseSubTermsSemester + ) where + +import Import.NoFoundation hiding (try, (<|>)) + +import Text.Parsec +import Text.Parsec.Text + +import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures) +import qualified Ldap.Client as Ldap + + +parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures] +parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key) + where + Ldap.Attr key = ldapUserStudyFeatures + +parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int) +parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key) + where + Ldap.Attr key = ldapUserSubTermsSemester + + +pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures] +pStudyFeatures studyFeaturesUser now = do + studyFeaturesDegree <- StudyDegreeKey' <$> pKey + void $ string "$$" + + let + pStudyFeature = do + _ <- pKey -- "Fächergruppe" + void $ char '!' + _ <- pKey -- "Studienbereich" + void $ char '!' + studyFeaturesField <- StudyTermsKey' <$> pKey + void $ char '!' + studyFeaturesType <- pType + void $ char '!' + studyFeaturesSemester <- decimal + let studyFeaturesValid = True + studyFeaturesSuperField = Nothing + studyFeaturesFirstObserved = Just now + studyFeaturesLastObserved = now + return StudyFeatures{..} + + pStudyFeature `sepBy1` char '#' + +pKey :: Parser Int +pKey = decimal + +pType :: Parser StudyFieldType +pType = FieldPrimary <$ try (string "HF") + <|> FieldSecondary <$ try (string "NF") + +decimal :: Parser Int +decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit' + where + digit' = dVal <$> digit + dVal c = fromEnum c - fromEnum '0' + + +pLMUTermsSemester :: Parser (StudyTermsId, Int) +pLMUTermsSemester = do + subTermsKey <- StudyTermsKey' <$> pKey + void $ char '$' + semester <- decimal + + return (subTermsKey, semester) diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index bc8e1c23d..916bd2df9 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -34,10 +34,13 @@ import Web.HttpApiData data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) + deriving anyclass (Universe, Finite) + derivePersistField "StudyFieldType" -instance Universe StudyFieldType -instance Finite StudyFieldType nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1 +pathPieceJSON ''StudyFieldType +pathPieceJSONKey ''StudyFieldType + data Theme