fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(study-features): further restriction by course

Browse Source
This commit is contained in:
Gregor Kleen 2020-08-26 20:54:21 +02:00
parent 32c18038b6
commit f7a9bc831a
9 changed files with 209 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/Database/Esqueleto/Utils.hs
View File

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

8
src/Handler/Course/User.hs
View File

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

49
src/Handler/Course/Users.hs
View File

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

15
src/Handler/Exam/AddUser.hs
View File

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

16
src/Handler/Utils/ExamOffice/Exam.hs
View File

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

5
src/Handler/Utils/ExamOffice/ExternalExam.hs
View File

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

150
src/Handler/Utils/StudyFeatures.hs
View File

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

70
src/Handler/Utils/StudyFeatures/Parse.hs Normal file
View File

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

7
src/Model/Types/Misc.hs
View File

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