From cfd25348ad3b63ac6bc5031467a3c4ead2e07eed Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 1 Aug 2024 17:45:18 +0200 Subject: [PATCH] fix(course): fix #148 course qualification ordering some refactoring done along the way, fixing a bug in relation to #150 as well --- src/Handler/Course/Edit.hs | 17 +++++------ src/Handler/Tutorial/Users.hs | 49 +++++++++++++----------------- src/Handler/Utils/Course.hs | 10 +++--- src/Handler/Utils/Qualification.hs | 28 +++++++++++++++++ 4 files changed, 61 insertions(+), 43 deletions(-) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index d8519968b..007276923 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -92,16 +92,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools - q2opt :: Entity Qualification -> Option QualificationId - q2opt (Entity qid Qualification{..}) = - let qsh = CI.original $ unSchoolKey qualificationSchool - in Option{ optionDisplay = CI.original qualificationName <> " (" <> qsh <> ")" - , optionExternalValue = "(" <> CI.original qualificationShorthand <> "___" <> qsh <> ")" - , optionInternalValue = qid - } elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool] - return (userSchools, mkOptionList (map q2opt elegibleQualifications)) - + return (userSchools, qualificationsOptionList elegibleQualifications) (termsField, userTerms) <- liftHandler $ case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin @@ -469,10 +461,15 @@ upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> upsertCourseQualifications uid cid qualis = do let newQualis = Map.fromList qualis oldQualis <- Map.fromDistinctAscList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder))) - <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationSortOrder] + <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification] -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150 okSchools <- Set.fromDistinctAscList . fmap (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool] + {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition: + $logErrorS "CourseQuali" $ "OLD Course Qualifications:" <> tshow oldQualis + $logErrorS "CourseQuali" $ "NEW Course Qualifications:" <> tshow newQualis + $logErrorS "CourseQuali" $ "DIFF Course Qualifications:" <> tshow (newQualis Map.\\ oldQualis) + -} foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of Just so_new | so_new /= so_old -> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 973366f0a..1f068722e 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -50,7 +50,7 @@ data TutorialUserActionData | TutorialUserGrantQualificationData { tuQualification :: QualificationId , tuValidUntil :: Day - } + } | TutorialUserSendMailData | TutorialUserDeregisterData{} deriving (Eq, Ord, Read, Show, Generic) @@ -62,7 +62,7 @@ postTUsersR tid ssh csh tutn = do isAdmin <- hasReadAccessTo AdminR (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn + tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid now <- liftIO getCurrentTime let nowaday = utctDay now @@ -70,7 +70,7 @@ postTUsersR tid ssh csh tutn = do dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) - , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR + , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , pure colUserEmail , pure $ colUserMatriclenr isAdmin , pure $ colUserQualifications nowaday @@ -80,34 +80,27 @@ postTUsersR tid ssh csh tutn = do & defaultSortingByName & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"]) - isInTut q = E.exists $ do + isInTut q = E.exists $ do tutorialParticipant <- E.from $ E.table @TutorialParticipant E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] - - let - qualOpt :: Entity Qualification -> Handler (Option QualificationId) - qualOpt (Entity qualId qual) = do - cQualId :: CryptoUUIDQualification <- encrypt qualId - return $ Option - { optionDisplay = CI.original $ qualificationName qual - , optionInternalValue = qualId - , optionExternalValue = tshow cQualId - } + + qualOptions = qualificationsOptionList qualifications + let acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) acts = Map.fromList $ (if null qualifications then mempty else [ ( TutorialUserRenewQualification , TutorialUserRenewQualificationData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing + <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing ) , ( TutorialUserGrantQualification , TutorialUserGrantQualificationData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing + <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry - ) - ] + ) + ] ) ++ [ ( TutorialUserSendMail , pure TutorialUserSendMailData ) , ( TutorialUserDeregister , pure TutorialUserDeregisterData ) @@ -122,20 +115,20 @@ postTUsersR tid ssh csh tutn = do rcvr <- requireAuth encRcvr <- encrypt $ entityKey rcvr letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers - let mbAletter = anyone letters - case mbAletter of + let mbAletter = anyone letters + case mbAletter of Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message - Just aletter -> do + Just aletter -> do now <- liftIO getCurrentTime - apcIdent <- letterApcIdent aletter encRcvr now + apcIdent <- letterApcIdent aletter encRcvr now let fName = letterFileName aletter renderLetters rcvr letters apcIdent >>= \case - Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err + Left err -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now) -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf) - -- let typePDF :: ContentType + -- let typePDF :: ContentType -- typePDF = "application/pdf" - -- sendResponse (typePDF, toContent pdf) + -- sendResponse (typePDF, toContent pdf) (TutorialUserGrantQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime @@ -146,7 +139,7 @@ postTUsersR tid ssh csh tutn = do redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserRenewQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do - noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers + noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserSendMailData{}, selectedUsers) -> do @@ -160,8 +153,8 @@ postTUsersR tid ssh csh tutn = do addMessageI Success $ MsgTutorialUsersDeregistered nrDel redirect $ CTutorialR tid ssh csh tutn TUsersR _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing - - case tcontent of + + case tcontent of Just act -> act -- abort and return produced content Nothing -> do tutors <- runDB $ E.select $ do diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs index c0d31a0d5..93d0c2692 100644 --- a/src/Handler/Utils/Course.hs +++ b/src/Handler/Utils/Course.hs @@ -109,14 +109,14 @@ showCourseEventRoom uid courseEvent = E.or ] getCourseQualifications :: ( MonadHandler m - , backend ~ SqlBackend - ) + , backend ~ SqlBackend + ) => CourseId -> ReaderT backend m [Entity Qualification] -getCourseQualifications cid = Ex.select $ do +getCourseQualifications cid = Ex.select $ do (qual :& courseQual) <- Ex.from $ Ex.table @Qualification `Ex.innerJoin` Ex.table @CourseQualification - `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification) + `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification) Ex.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid - Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder] + Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder, E.asc $ qual E.^. QualificationName] pure qual \ No newline at end of file diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index ab135e847..a2074d5da 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -289,3 +289,31 @@ qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReas E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason)) return $ quser E.^. QualificationUserUser qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify + + +----------- +-- Forms -- +----------- + + +qualificationOption :: Entity Qualification -> Option QualificationId +qualificationOption (Entity qid Qualification{..}) = + let qsh = ciOriginal $ unSchoolKey qualificationSchool + in Option{ optionDisplay = ciOriginal qualificationName <> " (" <> qsh <> ")" + , optionExternalValue = "(" <> ciOriginal qualificationShorthand <> "___" <> qsh <> ")" + , optionInternalValue = qid + } + +qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId +qualificationsOptionList = mkOptionList . map qualificationOption + +{- Should we encrypt the external value or simply rely on uniqueness? +qualOpt :: Entity Qualification -> Handler (Option QualificationId) +qualOpt (Entity qualId qual) = do + cQualId :: CryptoUUIDQualification <- encrypt qualId + return $ Option + { optionDisplay = ciOriginal $ qualificationName qual + , optionInternalValue = qualId + , optionExternalValue = tshow cQualId + } +-}