295 lines
14 KiB
Haskell
295 lines
14 KiB
Haskell
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)
|
|
<a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
|
|
_{filesMsg}
|
|
$of _
|
|
<span ##{theId} *{attrs}>
|
|
_{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
|