-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications, BlockArguments #-} module Handler.Tutorial.Users ( getTUsersR, postTUsersR , getTExamR, postTExamR ) 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, copyExamOccurrences) 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 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) -- non-table form for general tutorial actions data GenTutAction = GenTutActOccCopyWeek | GenTutActOccCopyLast | GenTutActOccEdit deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) nullaryPathPiece ''GenTutAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''GenTutAction id data GenTutActionData = GenTutActOccCopyWeekData { gtaExam :: ExamId } | GenTutActOccCopyLastData { gtaExam :: ExamId } | GenTutActOccEditData { gtaExam :: ExamId } deriving (Eq, Ord, Show, Generic) gta2gtad :: GenTutAction -> ExamId -> GenTutActionData gta2gtad GenTutActOccCopyWeek = GenTutActOccCopyWeekData gta2gtad GenTutActOccCopyLast = GenTutActOccCopyLastData gta2gtad GenTutActOccEdit = GenTutActOccEditData -- mkGenTutForm :: [Filter Exam] -> Form GenTutActionData -- mkGenTutForm fltr = renderAForm FormStandard maa -- where -- maa = multiActionA acts (fslI MsgCourseExam) Nothing -- acts :: Map GenTutAction (AForm Handler GenTutActionData) -- acts = Map.fromList -- [ (GenTutActOccCopy, GenTutActOccCopyData <$> areq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing) -- , (GenTutActOccEdit, GenTutActOccEditData <$> aopt (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing) -- ] mkGenTutForm :: [Filter Exam] -> Form GenTutActionData mkGenTutForm fltr html = do (actRes, actView) <- mreq (selectFieldList ((\a->(a,a)) <$> universeF)) (fslI MsgCourseExam) Nothing (exmRes, exmView) <- mreq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing let res :: FormResult GenTutAction -> FormResult ExamId -> FormResult GenTutActionData res (FormSuccess gtao) (FormSuccess eid) = FormSuccess $ gta2gtad gtao eid res (FormFailure e1) (FormFailure e2) = FormFailure $ e1 <> e2 res (FormFailure e) _ = FormFailure e res _ (FormFailure e) = FormFailure e res _ _ = FormMissing viw = [whamlet|

#{html}^{fvInput actView} _{MsgFor} ^{fvInput exmView} |] return (res actRes exmRes, viw) 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 (i.e. pdf) Nothing -> do -- no table action content to return, continue normally let mkExamCreateBtn = linkButton mempty (msg2widget MsgMenuExamNew) [BCIsButton, BCPrimary] $ SomeRoute $ CourseR tid ssh csh CExamNewR (dbegin, dend) = munzip timespan tbegin = toMidnight . succ <$> dbegin tend = toMidnight <$> dend exmFltr = ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing]) ++ [ExamCourse ==. cid, ExamStart <=. tend] $logInfoS "ExamOccurrenceForm" [st|Exams from #{tshow tbegin} until #{tshow tend}.|] ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm ("FIDGeneralTutorialAction"::Text) $ mkGenTutForm exmFltr let gtaAnchor = "general-tutorial-action-form" :: Text gtaRoute = croute :#: gtaAnchor gtaForm = wrapForm' BtnPerform gtaWgt FormSettings { formMethod = POST , formAction = Just . SomeRoute $ gtaRoute , formEncoding = gtaEnctype , formAttrs = [] , formSubmit = FormSubmit , formAnchor = Just gtaAnchor } formResult gtaRes $ \case GenTutActOccEditData { gtaExam=eId } -> do Exam{examName=ename} <- runDBRead $ get404 eId redirect $ CTutorialR tid ssh csh tutn $ TExamR ename copyAction -> case dbegin of Nothing -> addMessageI Error MsgExamOccurrenceCopyNoStartDate (Just dto) -> let cfailure = addMessageI Error MsgExamOccurrenceCopyFail csuccess n = addMessageI Success (MsgExamOccurrencesCopied n) >> reloadKeepGetParams croute copyFrom dfrom = copyExamOccurrences (gtaExam copyAction) dfrom dto <&> (toMaybe =<< (> 0)) step_dto = case copyAction of GenTutActOccCopyWeekData{} -> addDays (-7) dto _ -> pred dto in maybeM cfailure csuccess $ runDB $ firstJustM $ map copyFrom $ take 69 $ drop 1 [dto, step_dto..] -- search for up to 2 months / 1 year backwards tutors <- runDBRead $ 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 -- $(i18nWidgetFile "exam-missing") let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName html <- siteLayoutMsg heading do setTitleI heading $(widgetFile "tutorial-participants") return $ toTypedContent html getTExamR, postTExamR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> ExamName -> Handler Html getTExamR = postTExamR postTExamR tid ssh csh tutn exmName = do let baseroute = CTutorialR tid ssh csh tutn (Entity{entityKey=eId,entityVal=exm},exOccs) <- runDB do trm <- get404 tid (cid, tutEnt) <- fetchCourseIdTutorial tid ssh csh tutn exm <- getBy404 $ UniqueExam cid exmName let lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped' timespan = lessonTimesSpan lessons -- (fmap (toMidnight . succ) -> tbegin, fmap toMidnight -> tend) = munzip timespan -- exms <- selectList ([ExamCourse ==. cid, ExamStart <=. tend] ++ ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing])) [Asc ExamName] exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid return (exm,exOccs) cueId :: CryptoUUIDExam <- encrypt eId let eid2eos = convertExamOccurrenceMap exOccs (cuEoIds, eos) = munzip $ Map.lookup eId eid2eos exOcForm = (,,) <$> areq hiddenField "" (Just cueId) <*> areq (mkSetField hiddenField) "" cuEoIds <*> examOccurrenceMultiForm eos ((eofRes, eofWgt), eofEnctype) <- runFormPost $ identifyForm FIDTutorialExamOccurrences $ renderAForm FormStandard exOcForm let eofForm = wrapForm eofWgt def{formEncoding = eofEnctype} formResult eofRes $ \(edCEId, edCEOIds, edOccs) -> do let ceoidsDelete = edCEOIds `Set.difference` setMapMaybe eofId edOccs $logInfoS "ExamOccurrenceEdit" [st|Exam-Edit: #{length edCEOIds} old occurrences, #{length ceoidsDelete} to delete, #{length $ Set.filter (isNothing . eofId) edOccs} to insert, #{length $ Set.filter (isJust . eofId) edOccs} to edit|] reId <- decrypt edCEId eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete when (reId == eId) $ do (fromIntegral -> nrDel, nrUps) <- runDB $ (,) <$> deleteWhereCount [ExamOccurrenceExam ==. reId, ExamOccurrenceId <-. eoIdsDelete] <*> upsertExamOccurrences eId (Set.toList edOccs) let nr = nrUps + nrDel mstat = if nr > 0 then Success else Warning addMessageI mstat $ MsgExamOccurrencesEdited nrUps nrDel reload $ baseroute $ TExamR exmName let csh_tutn = csh <> "-" <> tutn -- hack to reuse prependCourseTitle heading = prependCourseTitle tid ssh csh_tutn $ MsgMenuTutorialExam exmName siteLayoutMsg heading do -- setTitle $ citext2Html exmName setTitleI heading [whamlet|

#{CI.original exmName}

#{examDescription exm}

^{eofForm} |]