module Handler.Course.Register ( ButtonCourseRegister(..) , CourseRegisterForm(..) , courseRegisterForm , getCRegisterR, postCRegisterR , deregisterParticipant ) where import Import import Handler.Utils import Handler.Utils.Exam import Utils.Course import qualified Data.Text as Text import qualified Data.Conduit.List as C import Database.Persist.Sql (transactionUndo) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -- Dedicated CourseRegistrationButton data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister | BtnCourseApply | BtnCourseRetractApplication deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonCourseRegister instance Finite ButtonCourseRegister nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonCourseRegister id instance Button UniWorX ButtonCourseRegister where btnClasses BtnCourseRegister = [BCIsButton, BCPrimary] btnClasses BtnCourseDeregister = [BCIsButton, BCDanger] btnClasses BtnCourseApply = [BCIsButton, BCPrimary] btnClasses BtnCourseRetractApplication = [BCIsButton, BCDanger] btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|] btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|] btnLabel BtnCourseApply = [whamlet|#{iconApply True} _{MsgBtnCourseApply}|] btnLabel BtnCourseRetractApplication = [whamlet|#{iconApply False} _{MsgBtnCourseRetractApplication}|] data CourseRegisterForm = CourseRegisterForm { crfApplicationText :: Maybe Text , crfApplicationFiles :: Maybe FileUploads } courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister) -- ^ `CourseRegisterForm` for current user courseRegisterForm (Entity cid Course{..}) = liftHandler $ do muid <- maybeAuthId ata <- getSessionActiveAuthTags now <- liftIO getCurrentTime (registration, application) <- runDB $ do registration <- fmap join . for muid $ fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy . flip UniqueParticipant cid application <- fmap (listToMaybe =<<) . for muid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] [] return (registration, application) let btn | courseApplicationsRequired , is _Just application = BtnCourseRetractApplication | is _Just registration = BtnCourseDeregister | courseApplicationsRequired = BtnCourseApply | otherwise = BtnCourseRegister isRegistered = btn `elem` [BtnCourseRetractApplication, BtnCourseDeregister] return . (, btn) . wFormToAForm $ do MsgRenderer mr <- getMsgRenderer secretRes <- if | Just secret <- courseRegisterSecret , not isRegistered -> let guardSecret (FormSuccess secret') | secret == secret' = return $ FormSuccess () | otherwise = formFailure [MsgCourseSecretWrong] guardSecret FormMissing = return FormMissing guardSecret (FormFailure errs) = return $ FormFailure errs in guardSecret =<< wreq textField (fslpI MsgCourseSecret $ mr MsgCourseSecret) Nothing | otherwise -> return $ FormSuccess () appTextRes <- let fs | courseApplicationsRequired , is _Just courseApplicationsInstructions = fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions | courseApplicationsRequired = fslI MsgCourseApplicationText | is _Just courseApplicationsInstructions = fslI MsgCourseRegistrationText & setTooltip MsgCourseRegistrationFollowInstructions | otherwise = fslI MsgCourseRegistrationText textField' = convertField unTextarea Textarea textareaField in if | not courseApplicationsText -> return $ FormSuccess Nothing | is _Just muid , isRegistered -> wforced (convertField Just (fromMaybe Text.empty) textField') fs (application >>= courseApplicationText . entityVal) | otherwise -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal) hasFiles <- for application $ \(Entity appId _) -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] appCID <- for application $ encrypt . entityKey let appFilesInfo = (,) <$> hasFiles <*> appCID filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $ let filesLinkField = Field{..} where fieldParse _ _ = return $ Right Nothing fieldEnctype = mempty fieldView theId _ attrs _ _ = [whamlet| $newline never $case appFilesInfo $of Just (True, appCID) _{filesMsg} $of _ _{MsgCourseApplicationNoFiles} |] in void $ wforced filesLinkField (fslI filesMsg) Nothing when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $ wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive | otherwise = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive in if | isRegistered -> return $ FormSuccess Nothing | otherwise -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> E.where_ $ course E.^. CourseId E.==. E.val cid E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool) E.||. mayEditCourse muid ata course E.||. courseIsVisible now course Nothing E.||. isCourseLecturer muid ata (course E.^. CourseId) E.||. isCourseTutor muid ata (course E.^. CourseId) E.||. isCourseSheetCorrector muid ata (course E.^. CourseId) E.||. isCourseExamCorrector muid ata (course E.^. CourseId) ) when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow when (isRegistered && not mayViewCourseAfterDeregistration) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse return $ CourseRegisterForm <$ secretRes <*> appTextRes <*> appFilesRes -- | Workaround for klicking register button without being logged in. -- After log in, the user sees a "get request not supported" error. getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCRegisterR tid ssh csh = do muid <- maybeAuthId case muid of Nothing -> addMessageI Info MsgLoginNecessary (Just uid) -> runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid when (isNothing registration) $ addMessageI Warning MsgRegisterRetry redirect $ CourseR tid ssh csh CShowR postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCRegisterR tid ssh csh = do uid <- requireAuthId course@(Entity cid Course{..}) <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh (courseRegisterForm', courseRegisterButton) <- courseRegisterForm course ((regResult,_), _) <- runFormPost $ renderAForm FormStandard courseRegisterForm' formResult regResult $ \CourseRegisterForm{..} -> do cTime <- liftIO getCurrentTime let doApplication = courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles) mkApplication | doApplication = void <$> do appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] appRes <- case appIds of [] -> insertUnique $ CourseApplication cid uid crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing (prevId:ps) -> do forM_ ps $ \appId -> do deleteApplicationFiles appId delete appId audit $ TransactionCourseApplicationDeleted cid uid appId deleteApplicationFiles prevId update prevId [ CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ] return $ Just prevId whenIsJust appRes $ audit . TransactionCourseApplicationEdit cid uid whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId)) return appRes | otherwise = return $ Just () mkRegistration = do audit $ TransactionCourseParticipantEdit cid uid entityKey <$> upsert (CourseParticipant cid uid cTime Nothing CourseParticipantActive) [ CourseParticipantRegistration =. cTime , CourseParticipantAllocated =. Nothing , CourseParticipantState =. CourseParticipantActive ] case courseRegisterButton of BtnCourseRegister -> runDB . bool id setSerializable doApplication $ do regOk <- (\app reg -> (, reg) <$> app) <$> mkApplication <*> mkRegistration case regOk of Nothing -> transactionUndo Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk BtnCourseDeregister -> runDB . setSerializable $ do part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid forM_ part $ \(Entity _partId CourseParticipant{..}) -> do deregisterParticipant uid cid when (is _Just courseParticipantAllocated) $ do updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive courseDeregisterNoShow ] now <- liftIO getCurrentTime insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing let recordNoShow eId = do didRecord <- is _Just <$> insertUnique ExamResult { examResultExam = eId , examResultUser = uid , examResultResult = ExamNoShow , examResultLastChanged = now } when didRecord $ audit $ TransactionExamResultEdit eId uid when courseDeregisterNoShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk BtnCourseApply -> runDB . setSerializable $ do regOk <- mkApplication case regOk of Nothing -> transactionUndo Just _ -> addMessageIconI Success IconApplyTrue MsgCourseApplyOk BtnCourseRetractApplication -> runDB $ do deleteApplications uid cid addMessageIconI Info IconApplyFalse MsgCourseRetractApplyOk muid <- maybeAuthId ata <- getSessionActiveAuthTags now <- liftIO getCurrentTime courseVisible <- runDB . E.selectExists . E.from $ \c -> E.where_ $ c E.^. CourseId E.==. E.val cid E.&&. mayViewCourse muid ata now c Nothing redirect $ bool NewsR (CourseR tid ssh csh CShowR) courseVisible deleteApplications :: UserId -> CourseId -> DB () deleteApplications uid cid = do appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] forM_ appIds $ \appId -> do deleteApplicationFiles appId delete appId audit $ TransactionCourseApplicationDeleted cid uid appId deleteApplicationFiles :: CourseApplicationId -> DB () deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication ==. appId ] deregisterParticipant :: UserId -> CourseId -> DB () deregisterParticipant uid cid = do deleteApplications uid cid part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid forM_ part $ \(Entity partId CourseParticipant{}) -> do update partId [CourseParticipantState =. CourseParticipantInactive False] audit $ TransactionCourseParticipantDeleted cid uid examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId E.where_ $ exam E.^. ExamCourse E.==. E.val cid E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid return examRegistration forM_ examRegistrations $ \(Entity _ ExamRegistration{..}) -> do deregisterExamUsers examRegistrationExam $ pure examRegistrationUser E.delete . E.from $ \tutorialParticipant -> do let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse) E.where_ $ tutorialCourse E.==. E.val cid E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid