From cf0ec1aec4267b99cf549b8ae5a0cd1762c45884 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 26 Aug 2019 17:55:05 +0200 Subject: [PATCH] feat(course-applications): csv transport --- messages/uniworx/de.msg | 24 ++ src/Data/Bool/Instances.hs | 28 +++ src/Data/CryptoID/Instances.hs | 11 + src/Handler/Course/Application/List.hs | 329 ++++++++++++++++++++++++- src/Handler/Exam/Users.hs | 43 ++-- src/Handler/Utils.hs | 8 + src/Import/NoModel.hs | 6 + src/Utils/Csv.hs | 7 +- 8 files changed, 425 insertions(+), 31 deletions(-) create mode 100644 src/Data/Bool/Instances.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index abd555853..737f60890 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1411,6 +1411,18 @@ CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") CsvColumnExamUserCourseNote: Notizen zum Teilnehmer +CsvColumnApplicationsAllocation: Zentralanmeldung über die die Bewerbung eingegangen ist +CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien) +CsvColumnApplicationsName: Voller Name des Bewerbers +CsvColumnApplicationsMatriculation: Matrikelnummer des Bewerbers +CsvColumnApplicationsField: Studienfach, mit dem der Bewerber seine Bewerbung assoziiert hat +CsvColumnApplicationsDegree: Abschluss, den der Bewerber im assoziierten Studienfach anstrebt +CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studienfach +CsvColumnApplicationsText: Text-Bewerbung +CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)? +CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer +CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" +CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber Action: Aktion @@ -1433,6 +1445,15 @@ ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identi ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden +CourseApplicationsTableCsvSetField: Bewerbungs-assoziiertes Studienfach ändern +CourseApplicationsTableCsvSetVeto: Veto setzen/entfernen +CourseApplicationsTableCsvSetRating: Bewertung eintragen +CourseApplicationsTableCsvSetComment: Bewertungskommentar eintragen + +CourseApplicationsTableCsvExceptionNoMatchingUser: Bewerber konnte nicht eindeutig identifiziert werden +CourseApplicationsTableCsvExceptionNoMatchingAllocation: Zentralanmeldung konnte nicht eindeutig identifiziert werden +CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden + TableHeadingFilter: Filter TableHeadingCsvImport: CSV-Import TableHeadingCsvExport: CSV-Export @@ -1536,6 +1557,9 @@ CourseApplicationsListTitle: Bewerbungen CourseApplicationId: Bewerbungsnummer CourseApplicationRatingPoints: Bewertung CourseApplicationVeto: Veto +CourseApplicationNoVeto: Kein Veto +CourseApplicationNoRatingPoints: Keine Bewertung +CourseApplicationNoRatingComment: Kein Kommentar UserDisplayName: Voller Name UserMatriculation: Matrikelnummer \ No newline at end of file diff --git a/src/Data/Bool/Instances.hs b/src/Data/Bool/Instances.hs new file mode 100644 index 000000000..699ad1b38 --- /dev/null +++ b/src/Data/Bool/Instances.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Bool.Instances + () where + +import ClassyPrelude + +import qualified Data.Csv as Csv +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () + +import qualified Data.Text as Text + + +instance Csv.ToField Bool where + toField True = "t" + toField False = "f" + +instance Csv.FromField Bool where + parseField f = do + (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f + (True <$ guard (isTrue t)) <|> (False <$ guard (isFalse t)) <|> fail "Could not decode Bool" + where + isTrue f' = any (== f') + [ "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ] + isFalse f' = any (== f') + [ "no", "n", "nein", "falsch", "f", "false", "0" ] diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index bc66cb874..0867f60b5 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/src/Data/CryptoID/Instances.hs @@ -16,6 +16,8 @@ import qualified Data.CaseInsensitive as CI import Web.PathPieces import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..)) +import qualified Data.Csv as Csv + instance ToMarkup s => ToMarkup (CID.CryptoID c s) where toMarkup = toMarkup . CID.ciphertext @@ -34,3 +36,12 @@ instance {-# OVERLAPS #-} (ToJSON s, ToJSONKey s) => ToJSONKey (CID.CryptoID c ( instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece + +instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where + parseField = fmap CID.CryptoID . Csv.parseField + +instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where + toField = Csv.toField . CID.ciphertext + +instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where + toField = Csv.toField . CI.foldedCase . CID.ciphertext diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 84867c817..bd33a3b88 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Handler.Course.Application.List ( getCApplicationsR, postCApplicationsR ) where @@ -8,8 +10,21 @@ import Handler.Utils import Handler.Utils.Table.Columns import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH +import qualified Data.Csv as Csv + +import qualified Data.Text as Text +import qualified Data.Text.Lens as Text + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import qualified Data.Map as Map + +import qualified Data.Conduit.List as C + type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication) `E.InnerJoin` E.SqlExpr (Entity User) @@ -76,6 +91,122 @@ resultStudyTerms = _dbrOutput . _6 . _Just resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree) resultStudyDegree = _dbrOutput . _7 . _Just + +newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Enum, Bounded) +makePrisms ''CourseApplicationsTableVeto + +instance Csv.ToField CourseApplicationsTableVeto where + toField (CourseApplicationsTableVeto True) = "veto" + toField (CourseApplicationsTableVeto False) = "" + +instance Csv.FromField CourseApplicationsTableVeto where + parseField f = do + (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f + return . CourseApplicationsTableVeto $ any (== t) + [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ] + +data CourseApplicationsTableCsv = CourseApplicationsTableCsv + { csvCAAllocation :: Maybe AllocationShorthand + , csvCAApplication :: Maybe CryptoFileNameCourseApplication + , csvCAName :: Maybe Text + , csvCAMatriculation :: Maybe Text + , csvCAField :: Maybe Text + , csvCADegree :: Maybe Text + , csvCASemester :: Maybe Int + , csvCAText :: Maybe Text + , csvCAHasFiles :: Maybe Bool + , csvCAVeto :: Maybe CourseApplicationsTableVeto + , csvCARating :: Maybe ExamGrade + , csvCAComment :: Maybe Text + } deriving (Generic) +makeLenses_ ''CourseApplicationsTableCsv + +courseApplicationsTableCsvOptions :: Csv.Options +courseApplicationsTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 } + +instance Csv.ToNamedRecord CourseApplicationsTableCsv where + toNamedRecord = Csv.genericToNamedRecord courseApplicationsTableCsvOptions + +instance Csv.FromNamedRecord CourseApplicationsTableCsv where + parseNamedRecord csv + = CourseApplicationsTableCsv + <$> csv .:?? "allocation" + <*> csv .:?? "application" + <*> csv .:?? "name" + <*> csv .:?? "matriculation" + <*> csv .:?? "field" + <*> csv .:?? "degree" + <*> csv .:?? "semester" + <*> csv .:?? "text" + <*> csv .:?? "has-files" + <*> csv .:?? "veto" + <*> csv .:?? "rating" + <*> csv .:?? "comment" + +instance Csv.DefaultOrdered CourseApplicationsTableCsv where + headerOrder = Csv.genericHeaderOrder courseApplicationsTableCsvOptions + +instance CsvColumnsExplained CourseApplicationsTableCsv where + csvColumnsExplanations = genericCsvColumnsExplanations courseApplicationsTableCsvOptions $ Map.fromList + [ ('csvCAAllocation , MsgCsvColumnApplicationsAllocation ) + , ('csvCAApplication , MsgCsvColumnApplicationsApplication ) + , ('csvCAName , MsgCsvColumnApplicationsName ) + , ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation) + , ('csvCAField , MsgCsvColumnApplicationsField ) + , ('csvCADegree , MsgCsvColumnApplicationsDegree ) + , ('csvCASemester , MsgCsvColumnApplicationsSemester ) + , ('csvCAText , MsgCsvColumnApplicationsText ) + , ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles ) + , ('csvCAVeto , MsgCsvColumnApplicationsVeto ) + , ('csvCARating , MsgCsvColumnApplicationsRating ) + , ('csvCAComment , MsgCsvColumnApplicationsComment ) + ] + +data CourseApplicationsTableCsvActionClass + = CourseApplicationsTableCsvSetField + | CourseApplicationsTableCsvSetVeto + | CourseApplicationsTableCsvSetRating + | CourseApplicationsTableCsvSetComment + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id + +data CourseApplicationsTableCsvAction + = CourseApplicationsTableCsvSetFieldData + { caCsvActApplication :: CourseApplicationId + , caCsvActField :: Maybe StudyFeaturesId + } + | CourseApplicationsTableCsvSetVetoData + { caCsvActApplication :: CourseApplicationId + , caCsvActVeto :: Bool + } + | CourseApplicationsTableCsvSetRatingData + { caCsvActApplication :: CourseApplicationId + , caCsvActRating :: Maybe ExamGrade + } + | CourseApplicationsTableCsvSetCommentData + { caCsvActApplication :: CourseApplicationId + , caCsvActComment :: Maybe Text + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 4 . dropEnd 1 . splitCamel + , fieldLabelModifier = camelToPathPiece' 3 + , sumEncoding = TaggedObject "action" "data" + } ''CourseApplicationsTableCsvAction + +data CourseApplicationsTableCsvException + = CourseApplicationsTableCsvExceptionNoMatchingUser + | CourseApplicationsTableCsvExceptionNoMatchingAllocation + | CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures + deriving (Show, Generic, Typeable) + +instance Exception CourseApplicationsTableCsvException + +embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id + + getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCApplicationsR = postCApplicationsR postCApplicationsR tid ssh csh = do @@ -184,8 +315,202 @@ postCApplicationsR tid ssh csh = do } dbtParams = def - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing + dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv + dbtCsvEncode = DictJust . C.mapM . runReaderT $ CourseApplicationsTableCsv + <$> preview (resultAllocation . _entityVal . _allocationShorthand) + <*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt) + <*> preview (resultUser . _entityVal . _userDisplayName) + <*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just) + <*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey))) + <*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey))) + <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) + <*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just) + <*> preview resultHasFiles + <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto) + <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingPoints . _Just) + <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingComment . _Just) + dbtCsvDecode = Just DBTCsvDecode + { dbtCsvRowKey = \csv -> do + appRes <- lift $ guessUser csv + case appRes of + Right appId -> return $ E.Value appId + Left uid -> do + alloc <- lift $ guessAllocation csv + [appId] <- lift $ selectKeysList [CourseApplicationUser ==. uid, CourseApplicationAllocation ==. alloc] [LimitTo 2] + return $ E.Value appId + , dbtCsvComputeActions = \case + DBCsvDiffMissing{} + -> return () -- no deletion + DBCsvDiffNew{} + -> return () -- no addition + DBCsvDiffExisting{..} -> do + let appId = dbCsvOld ^. resultCourseApplication . _entityKey + + newFeatures <- lift $ lookupStudyFeatures dbCsvNew + when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ + yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures + + let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto + whenIsJust mVeto $ \veto -> + when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $ + yield $ CourseApplicationsTableCsvSetVetoData appId veto + + when (dbCsvNew ^. _csvCARating /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingPoints) $ + yield $ CourseApplicationsTableCsvSetRatingData appId (dbCsvNew ^. _csvCARating) + + when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $ + yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment) + , dbtCsvClassifyAction = \case + CourseApplicationsTableCsvSetFieldData{} -> CourseApplicationsTableCsvSetField + CourseApplicationsTableCsvSetVetoData{} -> CourseApplicationsTableCsvSetVeto + CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating + CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment + , dbtCsvCoarsenActionClass = const DBCsvActionExisting + , dbtCsvExecuteActions = do + C.mapM_ $ \case + CourseApplicationsTableCsvSetFieldData{..} -> do + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField ] + audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication + CourseApplicationsTableCsvSetVetoData{..} -> do + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto ] + audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication + CourseApplicationsTableCsvSetRatingData{..} -> do + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating ] + audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication + CourseApplicationsTableCsvSetCommentData{..} -> do + CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment ] + audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication + return $ CourseR tid ssh csh CApplicationsR + , dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case + CourseApplicationsTableCsvSetFieldData{..} -> + [whamlet| + $newline never + ^{existingApplicantName' caCsvActApplication} + $maybe features <- caCsvActField + , ^{studyFeaturesWidget features} + $nothing + , _{MsgCourseStudyFeatureNone} + |] + CourseApplicationsTableCsvSetVetoData{..} -> + [whamlet| + $newline never + ^{existingApplicantName' caCsvActApplication} + $if caCsvActVeto + , _{MsgCourseApplicationVeto} + $else + , _{MsgCourseApplicationNoVeto} + |] + CourseApplicationsTableCsvSetRatingData{..} -> + [whamlet| + $newline never + ^{existingApplicantName' caCsvActApplication} + $maybe newResult <- caCsvActRating + , _{newResult} + $nothing + , _{MsgCourseApplicationNoRatingPoints} + |] + CourseApplicationsTableCsvSetCommentData{..} -> + [whamlet| + $newline never + ^{existingApplicantName' caCsvActApplication} + $if is _Nothing caCsvActComment + , _{MsgCourseApplicationNoRatingComment} + |] + , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure + , dbtCsvRenderException = ap getMessageRender . pure :: CourseApplicationsTableCsvException -> DB Text + } + where + guessUser :: CourseApplicationsTableCsv -> DB (Either UserId CourseApplicationId) + guessUser csv = do + mApp <- runMaybeT $ do + appId <- squash . catchIfMaybeT (const True :: CryptoIDError -> Bool) . MaybeT . traverse decrypt $ csv ^? _csvCAApplication . _Just + CourseApplication{..} <- MaybeT $ get appId + guard $ courseApplicationCourse == cid + return appId + + maybe (Left <$> guessUser' csv) (return . Right) mApp + where + guessUser' :: CourseApplicationsTableCsv -> DB UserId + guessUser' CourseApplicationsTableCsv{..} = $cachedHereBinary (csvCAMatriculation, csvCAName) $ do + users <- E.select . E.from $ \user -> do + E.where_ . E.and $ catMaybes + [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvCAMatriculation + , (user E.^. UserDisplayName E.==.) . E.val <$> csvCAName + ] + return $ user E.^. UserId + case users of + [E.Value uid] + -> return uid + _other + -> throwM CourseApplicationsTableCsvExceptionNoMatchingUser + + guessAllocation :: CourseApplicationsTableCsv -> DB (Maybe AllocationId) + guessAllocation CourseApplicationsTableCsv{..} = $cachedHereBinary csvCAAllocation . for csvCAAllocation $ \ash -> do + mAlloc <- traverse (getJustEntity . allocationCourseAllocation . entityVal) <=< getBy $ UniqueAllocationCourse cid + case mAlloc of + Just (Entity allocId Allocation{..}) + | allocationShorthand == ash + -> return allocId + _other + -> throwM CourseApplicationsTableCsvExceptionNoMatchingAllocation + + existingApplicantName :: Map (E.Value CourseApplicationId) CourseApplicationsTableData -> CourseApplicationId -> Widget + existingApplicantName existing (E.Value -> appId) = nameWidget userDisplayName userSurname + where + Entity _ User{..} = existing ^. singular (ix appId . resultUser) + + lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId) + lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do + appRes <- guessUser csv + (uid, oldFeatures) <- case appRes of + Left uid -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] [] + Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId + studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> + E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField) + , E.asc (studyFeatures E.^. StudyFeaturesDegree) + , E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do + E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField + E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree + E.where_ . E.and $ catMaybes + [ do + field <- csvCAField + return . E.or $ catMaybes + [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field) + , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field) + , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field + ] + , do + degree <- csvCADegree + return . E.or $ catMaybes + [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree) + , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree) + , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree + ] + , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvCASemester + ] + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid + let isActiveOrPrevious = E.or + $ (studyFeatures E.^. StudyFeaturesValid) + : [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId + | Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures + ] + E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course + E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)] + return $ studyFeatures E.^. StudyFeaturesId + case studyFeatures of + [E.Value fid] -> return $ Just fid + _other + | is _Nothing csvCAField + , is _Nothing csvCADegree + , is _Nothing csvCASemester + -> return Nothing + _other + | [Entity _ CourseApplication{..}] <- oldFeatures + , Just sfid <- courseApplicationField + , E.Value sfid `elem` studyFeatures + -> return $ Just sfid + _other -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures + dbtIdent = courseApplicationsIdent diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 6bd06b1b5..692a69c3c 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -30,7 +30,6 @@ import qualified Data.Conduit.List as C import qualified Data.CaseInsensitive as CI import Numeric.Lens (integral) -import Control.Arrow (Kleisli(..)) import Database.Persist.Sql (deleteWhereCount, updateWhereCount) @@ -123,23 +122,20 @@ instance ToNamedRecord ExamUserTableCsv where instance FromNamedRecord ExamUserTableCsv where parseNamedRecord csv -- Manually defined awaiting issue #427 = ExamUserTableCsv - <$> csv .:? "surname" - <*> csv .:? "first-name" - <*> csv .:? "name" - <*> csv .:? "matriculation" - <*> csv .:? "field" - <*> csv .:? "degree" - <*> csv .:? "semester" - <*> csv .:? "occurrence" - <*> csv .:? "exercise-points" - <*> csv .:? "exercise-num-passes" - <*> csv .:? "exercise-points-max" - <*> csv .:? "exercise-num-passes-max" - <*> csv .:? "exam-result" - <*> csv .:? "course-note" - where - (.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a) - m .:? name = Csv.lookup m name <|> return Nothing + <$> csv .:?? "surname" + <*> csv .:?? "first-name" + <*> csv .:?? "name" + <*> csv .:?? "matriculation" + <*> csv .:?? "field" + <*> csv .:?? "degree" + <*> csv .:?? "semester" + <*> csv .:?? "occurrence" + <*> csv .:?? "exercise-points" + <*> csv .:?? "exercise-num-passes" + <*> csv .:?? "exercise-points-max" + <*> csv .:?? "exercise-num-passes-max" + <*> csv .:?? "exam-result" + <*> csv .:?? "course-note" instance DefaultOrdered ExamUserTableCsv where headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions @@ -567,14 +563,6 @@ postEUsersR tid ssh csh examn = do , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text } where - studyFeaturesWidget :: StudyFeaturesId -> Widget - studyFeaturesWidget featId = do - (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) - [whamlet| - $newline never - _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} - |] - registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname where @@ -644,7 +632,6 @@ postEUsersR tid ssh csh examn = do _ -> isActive E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)] - E.limit 2 -- we just need to know whether there is a unique one, none, or more than one return $ studyFeatures E.^. StudyFeaturesId case studyFeatures of [E.Value fid] -> return $ Just fid @@ -657,7 +644,7 @@ postEUsersR tid ssh csh examn = do | Just (Entity _ CourseParticipant{..}) <- oldFeatures , Just sfid <- courseParticipantField , E.Value sfid `elem` studyFeatures - -> return Nothing + -> return $ Just sfid _other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 21f140921..0d181cbbd 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -225,3 +225,11 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc f <- messageLoggerSource app <$> readTVarIO loggerTVar f loc src lvl str +studyFeaturesWidget :: StudyFeaturesId -> Widget +studyFeaturesWidget featId = do + (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) + [whamlet| + $newline never + _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} + |] + diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index ea3a99691..ae9092732 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -14,6 +14,7 @@ import ClassyPrelude.Yesod as Import , static , boolField, identifyForm , HasHttpManager(..) + , embed ) import Model.Types.TH.JSON as Import @@ -128,6 +129,7 @@ import Net.IP.Instances as Import () import Data.Void.Instances as Import () import Crypto.Hash.Instances as Import () import Colonnade.Instances as Import () +import Data.Bool.Instances as Import () import Control.Lens as Import hiding ( (<.>) @@ -138,6 +140,10 @@ import Control.Lens as Import import Control.Lens.Extras as Import (is) import Data.Set.Lens as Import +import Control.Arrow as Import (Kleisli(..)) + +import Control.Monad.Morph as Import + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index 0205eab4f..e864f9e04 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -1,8 +1,9 @@ module Utils.Csv ( pathPieceCsv + , (.:??) ) where -import ClassyPrelude +import ClassyPrelude hiding (lookup) import Data.Csv hiding (Name) import Language.Haskell.TH (Name) @@ -17,3 +18,7 @@ pathPieceCsv (conT -> t) = instance FromField $(t) where parseField = maybe (fail "Could not unmarshal from PathPiece") return . fromPathPiece <=< parseField |] + + +(.:??) :: FromField (Maybe a) => NamedRecord -> ByteString -> Parser (Maybe a) +m .:?? name = lookup m name <|> return Nothing