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