module Handler.Course.Register ( ButtonCourseRegister(..) , CourseRegisterForm(..) , courseRegisterForm , getCRegisterR, postCRegisterR ) where import Import import Utils.Lens import Handler.Utils import Data.Function ((&)) import qualified Data.Text as Text import qualified Data.Conduit.List as C import Database.Persist.Sql (transactionUndo) import qualified Database.Esqueleto 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 { crfStudyFeatures :: Maybe StudyFeaturesId , crfApplicationText :: Maybe Text , crfApplicationFiles :: Maybe (Source Handler File) } courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister) -- ^ `CourseRegisterForm` for current user courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do muid <- maybeAuthId (registration, application) <- runDB $ do registration <- fmap join . for muid $ 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 () fieldRes <- if | is _Nothing muid -> return $ FormSuccess Nothing | is _Just muid , isRegistered , Just mFeature <- courseApplicationField . entityVal <$> application <|> courseParticipantField . entityVal <$> registration -> wforced (studyFeaturesFieldFor Nothing True (maybeToList mFeature) muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) mFeature | otherwise -> wreq (studyFeaturesFieldFor Nothing False [] muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing 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) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] appCID <- for application $ encrypt . entityKey let appFilesInfo = (,) <$> hasFiles <*> appCID filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired if | isn't _NoUpload courseApplicationsFiles || fromMaybe False 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 | otherwise -> return () appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive | otherwise = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive in if | isRegistered -> return $ FormSuccess Nothing | otherwise -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles return $ CourseRegisterForm <$ secretRes <*> fieldRes <*> 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 <- 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 mkApplication | courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles) = void <$> do appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] appRes <- case appIds of [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures 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 [ CourseApplicationField =. crfStudyFeatures, CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ] return $ Just prevId whenIsJust appRes $ audit . TransactionCourseApplicationEdit cid uid whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do runConduit $ transPipe liftHandlerT fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId) return appRes | otherwise = return $ Just () mkRegistration = do audit $ TransactionCourseParticipantEdit cid uid insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False deleteApplications = do appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] forM_ appIds $ \appId -> do deleteApplicationFiles appId delete appId audit $ TransactionCourseApplicationDeleted cid uid appId deleteApplicationFiles appId = do fs <- selectList [ CourseApplicationFileApplication ==. appId ] [] deleteCascadeWhere [ FileId <-. map (courseApplicationFileFile . entityVal) fs ] case courseRegisterButton of BtnCourseRegister -> runDB $ do regOk <- (\app reg -> (,) <$> app <*> reg) <$> mkApplication <*> mkRegistration case regOk of Nothing -> transactionUndo Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk BtnCourseDeregister -> runDB $ do deleteApplications part <- getBy $ UniqueParticipant uid cid forM_ part $ \(Entity partId CourseParticipant{..}) -> do delete $ partId audit $ TransactionCourseParticipantDeleted cid uid when courseParticipantAllocated $ do now <- liftIO getCurrentTime insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing 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 return examRegistration forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do delete erId audit $ TransactionExamDeregister examRegistrationExam uid examResults <- E.select . E.from $ \(examResult `E.InnerJoin` exam) -> do E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId E.where_ $ exam E.^. ExamCourse E.==. E.val cid return examResult forM_ examResults $ \(Entity erId ExamResult{..}) -> do delete erId audit $ TransactionExamResultDeleted examResultExam uid addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk BtnCourseApply -> runDB $ do regOk <- mkApplication case regOk of Nothing -> transactionUndo Just _ -> addMessageIconI Success IconApplyTrue MsgCourseApplyOk BtnCourseRetractApplication -> runDB $ do deleteApplications addMessageIconI Info IconApplyFalse MsgCourseRetractApplyOk redirect $ CourseR tid ssh csh CShowR