module Handler.Course.User ( getCUserR, postCUserR ) where import Import import Utils.Form import Handler.Utils import Handler.Utils.SheetType import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Persist.Sql (deleteWhereCount) import Text.Blaze.Html.Renderer.Text (renderHtml) import Handler.Course.Register import Jobs.Queue import Handler.Submission.List import Handler.Utils.StudyFeatures import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.Combinators as C import qualified Data.Text.Lazy as LT data ExamAction = ExamDeregister | ExamSetResult deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving anyclass (Universe, Finite) nullaryPathPiece ''ExamAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ExamAction $ Text.replace "Exam" "ExamUser" data ExamActionData = ExamDeregisterData | ExamSetResultData (Maybe ExamResultPassedGrade) data TutorialAction = TutorialDeregister deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving anyclass (Universe, Finite) nullaryPathPiece ''TutorialAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''TutorialAction $ Text.replace "Tutorial" "TutorialUser" data TutorialActionData = TutorialDeregisterData getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html getCUserR = postCUserR postCUserR tid ssh csh uCId = do showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth (course, user@(Entity _ User{..}), registered) <- runDB $ do uid <- decrypt uCId course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh user <- get404 uid registered <- exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ] return (course, Entity uid user, registered) sections <- mapM (runMaybeT . ($ user) . ($ course)) [ courseUserProfileSection , courseUserNoteSection , courseUserExamsSection , courseUserTutorialsSection , courseUserSubmissionsSection ] -- generate output let headingLong | registered , Just sex <- guardOn showSex =<< userSex = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|] | registered = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|] | Just sex <- guardOn showSex =<< userSex = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseAssociatedWith} #{csh} #{tid}|] | otherwise = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|] headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName siteLayout headingLong $ do setTitleI headingShort mapM_ maybeVoid sections courseUserProfileSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserProfileSection course@(Entity cid Course{..}) (Entity uid User{ userShowSex = _, ..}) = do showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth currentRoute <- MaybeT getCurrentRoute (mRegistration, studies) <- lift . runDB $ do registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid studies <- E.select $ E.from $ \(course' `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId E.on $ isCourseStudyFeature course' studyfeat E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.where_ $ course' E.^. CourseId E.==. E.val cid return (studyfeat, studydegree, studyterms) return (registration, studies) mayRegister <- lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR let regButton | is _Just mRegistration = BtnCourseDeregister | otherwise = BtnCourseRegister ((regButtonRes, regButtonView), regButtonEnctype) <- lift . runFormPost . identifyForm FIDcRegButton $ if | is _Just $ courseParticipantAllocated . entityVal =<< mRegistration -> renderWForm FormStandard $ fmap (regButton, ) <$ (wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip) <*> optionalActionW ((,) <$> areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing <*> apopt checkBoxField (fslI MsgCourseDeregistrationAllocationNoShow & setTooltip MsgCourseDeregistrationAllocationNoShowTip) Nothing ) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) | otherwise -> \csrf -> pure (FormSuccess (regButton, Nothing), toWidget csrf) let registrationButtonFrag :: Text registrationButtonFrag = "registration-button" regButtonWidget = wrapForm' regButton regButtonView FormSettings { formMethod = POST , formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag , formEncoding = regButtonEnctype , formAttrs = [] , formSubmit = FormSubmit , formAnchor = Just registrationButtonFrag } formResult regButtonRes $ \case _ | not mayRegister -> permissionDenied "User may not be registered" (BtnCourseDeregister, mbReason) | Just (Entity _pId CourseParticipant{..}) <- mRegistration -> do lift . runDB $ do unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid" deregisterParticipant courseParticipantUser course whenIsJust mbReason $ \(reason, noShow) -> do updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ] now <- liftIO getCurrentTime insert_ $ AllocationDeregister courseParticipantUser (Just cid) now (Just reason) let recordNoShow eId = do didRecord <- is _Just <$> insertUnique ExamResult { examResultExam = eId , examResultUser = uid , examResultResult = ExamNoShow , examResultLastChanged = now } when didRecord $ audit $ TransactionExamResultEdit eId uid when noShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk redirect $ CourseR courseTerm courseSchool courseShorthand CUsersR | otherwise -> invalidArgs ["User not registered"] (BtnCourseRegister, _) -> do now <- liftIO getCurrentTime lift . runDBJobs $ do void $ upsert (CourseParticipant cid uid now Nothing CourseParticipantActive) [ CourseParticipantRegistration =. now , CourseParticipantAllocated =. Nothing , CourseParticipantState =. CourseParticipantActive ] queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid audit $ TransactionCourseParticipantEdit cid uid addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk redirect currentRoute _other -> error "Invalid @regButton@" mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime return $(widgetFile "course/user/profile") courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR currentRoute <- MaybeT getCurrentRoute (thisUniqueNote, noteText, noteEdits) <- lift . runDB $ do let thisUniqueNote = UniqueCourseUserNote uid cid mbNoteEnt <- getBy thisUniqueNote (noteText,noteEdits) <- case mbNoteEnt of Nothing -> return (Nothing,[]) (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do E.on $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime] E.limit 1 -- more will be shown, if changed here return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname) return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits) return (thisUniqueNote, noteText, noteEdits) let editByWgt = [whamlet| $newline never