From fa0caba55d05f080f5ed98b0b83dde3c6cebe7b7 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 12 Dec 2022 03:15:46 +0100 Subject: [PATCH] feat(tutorial-users): table action for granting qualifications --- .../courses/tutorial/de-de-formal.msg | 2 + .../categories/courses/tutorial/en-eu.msg | 2 + src/CryptoID.hs | 1 + src/Handler/Tutorial/Users.hs | 62 +++++++++++++++++-- 4 files changed, 62 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 586b2d546..d9a9b7493 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -44,4 +44,6 @@ TutorCorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor:in für TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium-Teilnehmer:in" "Tutorium-Teilnehmer:innen" } abgemeldet TutorialUserDeregister: Vom Tutorium Abmelden TutorialUserSendMail: Mitteilung verschicken +TutorialUserGrantQualification: Qualifikation vergeben +TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben CommTutorial: Tutorium-Mitteilung \ No newline at end of file diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index cdd7e664a..0c889b3f1 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -45,4 +45,6 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici TutorialUserDeregister: Deregister from tutorial TutorialUserSendMail: Send mail +TutorialUserGrantQualification: Grant Qualification +TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"} CommTutorial: Tutorial message diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 31e3a3e7c..dec7b906d 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -61,6 +61,7 @@ decCryptoIDs [ ''SubmissionId , ''MaterialFileId , ''AllocationMatchingId , ''PrintJobId + , ''QualificationId ] decCryptoIDKeySize diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index df104752f..acc1ca823 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -19,19 +19,33 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Time.Zones as TZ + import qualified Database.Esqueleto.Legacy as E import Handler.Course.Users -data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +data TutorialUserAction + = TutorialUserGrantQualification + | TutorialUserSendMail + | TutorialUserDeregister + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe TutorialUserAction instance Finite TutorialUserAction nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''TutorialUserAction id +data TutorialUserActionData + = TutorialUserGrantQualificationData + { tuQualification :: QualificationId + , tuValidUntil :: Day + } + | TutorialUserSendMailData + | TutorialUserDeregisterData{} + deriving (Eq, Ord, Read, Show, Generic, Typeable) + getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html getTUsersR = postTUsersR @@ -57,14 +71,52 @@ postTUsersR tid ssh csh tutn = do csvColChoices = flip elem ["name", "matriculation", "email", "study-features"] cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator (Just csvColChoices) + availableQualifications <- selectList [QualificationSchool ==. ssh] [] + 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 + } + acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) + acts = Map.fromList + [ ( TutorialUserGrantQualification + , TutorialUserGrantQualificationData + <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt availableQualifications) (fslI MsgQualificationName) Nothing + <*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing + ) + , ( TutorialUserSendMail, pure TutorialUserSendMailData ) + , ( TutorialUserDeregister, pure TutorialUserDeregisterData ) + ] + table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) return (tut, table) formResult participantRes $ \case - (TutorialUserSendMail, selectedUsers) -> do + (TutorialUserGrantQualificationData{..}, selectedUsers) -> do + today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + runDB . forM_ selectedUsers $ \qualificationUserUser -> void $ + upsert + QualificationUser + { qualificationUserQualification = tuQualification + , qualificationUserValidUntil = tuValidUntil + , qualificationUserLastRefresh = today + , qualificationUserFirstHeld = today + , qualificationUserBlockedDue = Nothing + , .. + } + [ QualificationUserValidUntil =. tuValidUntil + , QualificationUserLastRefresh =. today + , QualificationUserBlockedDue =. Nothing + ] + addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers + redirect $ CTutorialR tid ssh csh tutn TUsersR + (TutorialUserSendMailData{}, selectedUsers) -> do cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) - (TutorialUserDeregister,selectedUsers) -> do + (TutorialUserDeregisterData{},selectedUsers) -> do nrDel <- runDB $ deleteWhereCount [ TutorialParticipantTutorial ==. tutid , TutorialParticipantUser <-. Set.toList selectedUsers