feat(tutorial-users): table action for granting qualifications

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

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

src/CryptoID.hs

@@ -61,6 +61,7 @@ decCryptoIDs [ ''SubmissionId
              , ''MaterialFileId
              , ''AllocationMatchingId
              , ''PrintJobId
+             , ''QualificationId
              ]
 
 decCryptoIDKeySize

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