-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications, BlockArguments #-} module Handler.Tutorial.Users ( getTUsersR, postTUsersR ) where import Import import Control.Monad.Zip (munzip) import Utils.Form import Utils.Print import Handler.Utils import Handler.Utils.Course import Handler.Utils.Course.Cache import Handler.Utils.Tutorial import Handler.Exam.Form (ExamOccurrenceForm(..), examOccurrenceMultiForm, upsertExamOccurrences) import Database.Persist.Sql (deleteWhereCount) import qualified Data.CaseInsensitive as CI -- import qualified Data.Text as Text import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.ByteString.Lazy as LBS -- import qualified Data.Time.Zones as TZ import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import Handler.Course.Users -- TODO: Idee: MultiAction für jedes Exam, um so die einzelnen Occurrences zu markieren! -- Default muss auch entsprechend generiert werden, wenn keine Occurrences für den Tag existieren -- Im Form sollten die neuen markiert werden als ungespeichert! Generell wünschenswert für MassInput! -- | Generate multiForm with one entry for each course exam showing only day-relevant exam occurrences mkExamOccurrenceForm :: [(Entity Exam, CryptoUUIDExam, Widget)] -> ExamOccurrenceMap -> Form (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm) mkExamOccurrenceForm exs eom = renderAForm FormStandard maa where maa = multiActionA acts (fslI MsgCourseExam) Nothing eid2eos = convertExamOccurrenceMap eom acts :: Map Text (AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)) acts = Map.fromList $ map mkAct exs mkAct :: (Entity Exam, CryptoUUIDExam, Widget) -> (Text, AForm Handler (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)) mkAct (Entity{entityKey=eId, entityVal=Exam{examName=eName, examDescription=eDescr}}, cueId, ewgt) = (ciOriginal eName, let (cuEoIds, eos) = munzip $ Map.lookup eId eid2eos in (,,) <$ for_ eDescr (aformInfoWidget . toWgt) <*> apreq hiddenField "" (Just cueId) <*> apreq (mkSetField hiddenField) "" cuEoIds <* aformInfoWidget ewgt <*> examOccurrenceMultiForm eos -- TODO filter occurrences to cuEoIds ) data TutorialUserAction = TutorialUserAssignExam | TutorialUserPrintQualification | TutorialUserRenewQualification | TutorialUserGrantQualification | TutorialUserSendMail | TutorialUserDeregister deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe TutorialUserAction instance Finite TutorialUserAction nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''TutorialUserAction id data TutorialUserActionData = TutorialUserPrintQualificationData | TutorialUserRenewQualificationData { tuQualification :: QualificationId } | TutorialUserGrantQualificationData { tuQualification :: QualificationId , tuValidUntil :: Day } | TutorialUserSendMailData | TutorialUserDeregisterData | TutorialUserAssignExamData { tuOccurrenceId :: ExamOccurrenceId , tuReassign :: Bool } deriving (Eq, Ord, Read, Show, Generic) getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent getTUsersR = postTUsersR postTUsersR tid ssh csh tutn = do let croute = CTutorialR tid ssh csh tutn TUsersR now <- liftIO getCurrentTime isAdmin <- hasReadAccessTo AdminR (cid, Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, timespan, exOccs) <- runDB do trm <- get404 tid -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh -- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn (cid, tutEnt@(Entity tutid _)) <- fetchCourseIdTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid let nowaday = utctDay now minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , pure colUserEmail , pure $ colUserMatriclenr isAdmin , pure $ colUserQualifications nowaday , pure $ colUserQualificationBlocked isAdmin nowaday , pure $ colUserExamOccurrences tid ssh csh , pure $ colUserExams tid ssh csh ] psValidator = def & 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 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"] qualOptions = qualificationsOptionList qualifications lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped' timespan = lessonTimesSpan lessons exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid let acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) acts = Map.fromList $ bcons (not $ null exOccs) ( TutorialUserAssignExam , TutorialUserAssignExamData <$> apopt (selectField $ pure $ mkExamOccurrenceOptions exOccs) (fslI MsgCourseUserExamOccurrences) Nothing <*> apopt checkBoxField (fslI MsgCourseUserExamOccurrenceOverride) (Just False) ) $ (if null qualifications then mempty else [ ( TutorialUserRenewQualification , TutorialUserRenewQualificationData <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing ) , ( TutorialUserGrantQualification , TutorialUserGrantQualificationData <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry ) ] ) ++ [ ( TutorialUserSendMail , pure TutorialUserSendMailData ) , ( TutorialUserDeregister , pure TutorialUserDeregisterData ) , ( TutorialUserPrintQualification, pure TutorialUserPrintQualificationData ) ] table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) return (cid, tutEnt, table, qualifications, timespan, exOccs) let courseQids = Set.fromList (entityKey <$> qualifications) tcontent <- formResultMaybe participantRes $ \case (TutorialUserPrintQualificationData, selectedUsers) -> do rcvr <- requireAuth encRcvr <- encrypt $ entityKey rcvr letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers let mbAletter = anyone letters case mbAletter of Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- cannot really happen Just aletter -> do apcIdent <- letterApcIdent aletter encRcvr now let fName = letterFileName aletter renderLetters rcvr letters apcIdent >>= \case 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 -- typePDF = "application/pdf" -- sendResponse (typePDF, toContent pdf) (TutorialUserGrantQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime today <- liftIO getCurrentTime let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers reloadKeepGetParams croute (TutorialUserRenewQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks reloadKeepGetParams croute (TutorialUserSendMailData, selectedUsers) -> do cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) (TutorialUserDeregisterData, selectedUsers) -> do nrDel <- runDB $ deleteWhereCount [ TutorialParticipantTutorial ==. tutid , TutorialParticipantUser <-. Set.toList selectedUsers ] addMessageI Success $ MsgTutorialUsersDeregistered nrDel reloadKeepGetParams croute (TutorialUserAssignExamData{..}, selectedUsers) | (Just (ExamOccurrence{..}, _, (eid,_))) <- Map.lookup tuOccurrenceId exOccs -> do let n = Set.size selectedUsers capOk <- ifNothing examOccurrenceCapacity (pure True) $ \(fromIntegral -> totalCap) -> do usedCap <- runDBRead $ count [ExamRegistrationOccurrence ==. Just tuOccurrenceId, ExamRegistrationUser /<-. Set.toList selectedUsers] let ok = totalCap - usedCap >= n unless ok $ addMessageI Error $ MsgExamRommCapacityInsufficient $ totalCap - usedCap pure ok when capOk do let regTemplate uid = ExamRegistration eid uid (Just tuOccurrenceId) now nrOk <- runDB $ if tuReassign then putMany [regTemplate uid | uid <- Set.toList selectedUsers] >> pure n else forM (Set.toList selectedUsers) (insertUnique . regTemplate) <&> (length . catMaybes) let allok = bool Warning Success $ nrOk == n addMessageI allok $ MsgTutorialUserExamAssignedFor nrOk n $ ciOriginal examOccurrenceName reloadKeepGetParams croute return Nothing _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing case tcontent of Just act -> act -- execute action and return produced content Nothing -> do -- no table action, continue normally let (fmap (toMidnight . succ) -> tbegin, fmap toMidnight -> tend) = munzip timespan $logInfoS "ExamOccurrenceForm" [st|Exam from #{tshow tbegin} until #{tshow tend}.|] (openExams, tutors) <- runDBRead $ (,) <$> selectList ([ExamCourse ==. cid, ExamStart <=. tend] ++ ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing])) [Asc ExamName] <*> E.select (do (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId) E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid return user ) let mkExamCreateBtn = linkButton mempty (msg2widget MsgMenuExamNew) [BCIsButton, BCPrimary] $ SomeRoute $ CourseR tid ssh csh CExamNewR mkExamEditBtn ename = linkButton mempty (msg2widget MsgMenuExamEdit) [BCIsButton, BCDefault] $ SomeRoute $ CourseR tid ssh csh $ ExamR ename EEditR examOccWgt <- if null openExams then return $(i18nWidgetFile "exam-missing") else do openExamsUUIDs <- forM openExams $ \ent@Entity{entityKey=k, entityVal=Exam{examName}} -> (ent,,) <$> encrypt k <*> pure (mkExamEditBtn examName) ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm FIDGeneralTutorialAction $ mkExamOccurrenceForm openExamsUUIDs exOccs -- TODO also TODO: occurrence name auto generation let gtaAnchor = "general-tutorial-action-form" :: Text gtaRoute = croute :#: gtaAnchor gtaForm = wrapForm gtaWgt FormSettings { formMethod = POST , formAction = Just . SomeRoute $ gtaRoute , formEncoding = gtaEnctype , formAttrs = [] , formSubmit = FormSubmit , formAnchor = Just gtaAnchor } $logInfoS "ExamOccurrenceEdit" $ tshow (Set.map (eofName &&& eofId) . trd3 <$> gtaRes) formResult gtaRes $ \(cEId, cEOIds, occs) -> do -- (CryptoUUIDExam, Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm) let ceoidsDelete = cEOIds `Set.difference` setMapMaybe eofId occs eId <- decrypt cEId eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete $logInfoS "ExamOccurrenceEdit" [st|Exam-Edit: #{length cEOIds} old occurrences, #{length eoIdsDelete} to delete, #{length $ Set.filter (isNothing . eofId) occs} to insert, #{length $ Set.filter (isJust . eofId) occs} to edit|] runDB do deleteWhere [ExamOccurrenceExam ==. eId, ExamOccurrenceId <-. eoIdsDelete] upsertExamOccurrences eId $ Set.toList occs return gtaForm let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName html <- siteLayoutMsg heading do setTitleI heading $(widgetFile "tutorial-participants") return $ toTypedContent html