feat(study-features): further restriction by course

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"

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
+    studies <- E.select $ E.from $ \(course `E.InnerJoin` studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
-      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
+      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)
 

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{..}
+    , "study-features" Csv..= csvUserStudyFeatures
-               -> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType
+    , "submission-group" Csv..= csvUserSubmissionGroup
-                   in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|]
-          in [ "study-features" Csv..= featsStr
-             ]
-      ++
-    [ "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"
+  [ "matriculation", "email", "study-features"] ++
-  ] ++
-  ["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
+                  <*> view _userStudyFeatures
-                          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
-                              }
-                      )
                   <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
                   <*> view _userTableRegistration
                   <*> userNote

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
+      return $ mempty { aurSuccessCourse = pure userEmail }
-        Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
-        Just _  -> mempty { aurSuccessCourse        = pure userEmail }
 
 

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.&&. E.not_ (E.exists . E.from $ \courseUserExamOfficeOptOut ->
-                                                  E.on $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. course E.^. CourseId
+                                                  E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. course E.^. CourseId
-                                                  E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
+                                                       E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser
-                                                  E.where_ $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
+                                                       E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool
-                                                  E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser
-                                                    E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool
                                                )
                           )
 

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

src/Handler/Utils/StudyFeatures.hs

@@ -1,70 +1,112 @@
 module Handler.Utils.StudyFeatures
-  ( parseStudyFeatures
+  ( module Handler.Utils.StudyFeatures.Parse
-  , parseSubTermsSemester
+  , 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 Handler.Utils.StudyFeatures.Parse
-import Text.Parsec.Text
 
-import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures)
+import qualified Data.Csv as Csv
-import qualified Ldap.Client as Ldap
+
+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]
+data UserTableStudyFeature = UserTableStudyFeature
-parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key)
+  { userTableField
-  where
+  , userTableDegree    :: Text
-    Ldap.Attr key = ldapUserStudyFeatures
+  , userTableSemester  :: Int
+  , userTableFieldType :: StudyFieldType
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+makeLenses_ ''UserTableStudyFeature
 
-parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int)
+deriveJSON defaultOptions
-parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key)
+  { fieldLabelModifier = camelToPathPiece' 2
-  where
+  } ''UserTableStudyFeature
-    Ldap.Attr key = ldapUserSubTermsSemester
 
+newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeature)
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (ToJSON, FromJSON)
+makeWrapped ''UserTableStudyFeatures
 
-pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
+instance Csv.ToField UserTableStudyFeature where
-pStudyFeatures studyFeaturesUser now = do
+  toField UserTableStudyFeature{..} = encodeUtf8
-  studyFeaturesDegree <- StudyDegreeKey' <$> pKey
+    [st|#{userTableField} #{userTableDegree} (#{userTableFieldType'} #{tshow userTableSemester})|]
-  void $ string "$$"
+    where userTableFieldType' = renderMessage
+            (error "Foundation inspected during renderMessage" :: UniWorX)
+            [] $ ShortStudyFieldType userTableFieldType
 
-  let
+instance Csv.ToField UserTableStudyFeatures where
-    pStudyFeature = do
+  toField = ByteString.intercalate "; " . map Csv.toField . sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped
-      _ <- 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 '#'
+userTableStudyFeatureSort :: UserTableStudyFeature
+                          -> UserTableStudyFeature
+                          -> Ordering
+userTableStudyFeatureSort = mconcat
+  [ compareUnicode `on` userTableDegree
+  , comparing userTableSemester
+  , comparing userTableFieldType
+  , compareUnicode `on` userTableField
+  ]
+  
 
-pKey :: Parser Int
+isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
-pKey = decimal
+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
+courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures
-pType = FieldPrimary   <$ try (string "HF")
+courseUserStudyFeatures cId uid = do
-    <|> FieldSecondary <$ try (string "NF")
+  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
+isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
-decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'
+isExternalExamStudyFeature externalExam studyFeatures
-  where
+      = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved)
-    digit' = dVal <$> digit
+  E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart
-    dVal c = fromEnum c - fromEnum '0'
+  where termEnd = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermEnd)
+        termStart = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermStart)
 
-
+externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures
-pLMUTermsSemester :: Parser (StudyTermsId, Int)
+externalExamUserStudyFeatures eeId uid = do
-pLMUTermsSemester = do
+  feats <- E.select . E.from $ \(externalExam `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do
-  subTermsKey <- StudyTermsKey' <$> pKey
+    E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
-  void $ char '$'
+    E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
-  semester <- decimal
+    E.on $ isExternalExamStudyFeature externalExam studyFeatures
-
+    E.where_ $ externalExam E.^. ExternalExamId E.==. E.val eeId
-  return (subTermsKey, semester)
+    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
+      }

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)

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