fix(course): fix #148 course qualification ordering
some refactoring done along the way, fixing a bug in relation to #150 as well
This commit is contained in:
parent
e1419766f3
commit
cfd25348ad
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
}
|
||||
-}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user