93 lines
3.9 KiB
Haskell
93 lines
3.9 KiB
Haskell
module Handler.Exam.Register
|
|
( ButtonExamRegister(..)
|
|
, postERegisterR
|
|
, postERegisterOccR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Exam
|
|
|
|
import Database.Persist.Sql (deleteWhereCount)
|
|
|
|
|
|
-- Dedicated ExamRegistrationButton
|
|
data ButtonExamRegister = BtnExamRegisterOccurrence
|
|
| BtnExamSwitchOccurrence
|
|
| BtnExamRegister
|
|
| BtnExamDeregister
|
|
deriving (Enum, Bounded, Eq, Ord, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonExamRegister
|
|
instance Finite ButtonExamRegister
|
|
nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 2
|
|
|
|
instance Button UniWorX ButtonExamRegister where
|
|
btnClasses BtnExamRegisterOccurrence = [BCIsButton, BCPrimary]
|
|
btnClasses BtnExamSwitchOccurrence = [BCIsButton, BCPrimary]
|
|
btnClasses BtnExamRegister = [BCIsButton, BCPrimary]
|
|
btnClasses BtnExamDeregister = [BCIsButton, BCDanger]
|
|
|
|
btnLabel BtnExamRegisterOccurrence = [whamlet|#{iconExamRegister True } _{MsgBtnExamRegisterOccurrence}|]
|
|
btnLabel BtnExamSwitchOccurrence = [whamlet|_{MsgBtnExamSwitchOccurrence}|]
|
|
btnLabel BtnExamRegister = [whamlet|#{iconExamRegister True } _{MsgBtnExamRegister}|]
|
|
btnLabel BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|]
|
|
|
|
|
|
postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
|
postERegisterR tid ssh csh examn = do
|
|
Entity uid User{..} <- requireAuth
|
|
|
|
Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
|
|
|
|
((btnResult, _), _) <- runFormPost $ buttonForm' [BtnExamRegister, BtnExamDeregister]
|
|
|
|
formResult btnResult $ \case
|
|
BtnExamDeregister -> do
|
|
runDB $ do
|
|
deleted <- deleteWhereCount [ExamRegistrationExam ==. eId, ExamRegistrationUser ==. uid]
|
|
unless (deleted <= 0) $
|
|
audit $ TransactionExamDeregister eId uid
|
|
addMessageIconI Success IconExamRegisterFalse $ MsgExamDeregisteredSuccess examn
|
|
redirect $ CExamR tid ssh csh examn EShowR
|
|
BtnExamRegister -> do
|
|
runDB $ do
|
|
now <- liftIO getCurrentTime
|
|
void $ upsertBy (UniqueExamRegistration eId uid) (ExamRegistration eId uid Nothing now) [ExamRegistrationTime =. now]
|
|
audit $ TransactionExamRegister eId uid
|
|
addMessageIconI Success IconExamRegisterTrue $ MsgExamRegisteredSuccess examn
|
|
redirect $ CExamR tid ssh csh examn EShowR
|
|
_other -> error "Unexpected due to definition of buttonForm'"
|
|
|
|
redirect $ CExamR tid ssh csh examn EShowR
|
|
|
|
postERegisterOccR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamOccurrenceName -> Handler Html
|
|
postERegisterOccR tid ssh csh examn occn = do
|
|
Entity uid User{..} <- requireAuth
|
|
(Entity eId Exam{..}, Entity occId ExamOccurrence{..}) <- runDB $ do
|
|
eexam@(Entity eId _) <- fetchExam tid ssh csh examn
|
|
occ <- getBy404 $ UniqueExamOccurrence eId occn
|
|
return (eexam, occ)
|
|
|
|
((btnResult, _), _) <- runFormPost buttonForm
|
|
|
|
formResult btnResult $ \case
|
|
BtnExamDeregister -> do
|
|
runDB $ do
|
|
deleted <- deleteWhereCount [ExamRegistrationExam ==. eId, ExamRegistrationUser ==. uid]
|
|
unless (deleted <= 0) $
|
|
audit $ TransactionExamDeregister eId uid
|
|
addMessageIconI Success IconExamRegisterFalse $ MsgExamDeregisteredSuccess examn
|
|
redirect $ CExamR tid ssh csh examn EShowR
|
|
btn | btn `elem` [BtnExamRegisterOccurrence, BtnExamSwitchOccurrence] -> do
|
|
runDB $ do
|
|
now <- liftIO getCurrentTime
|
|
void $ upsertBy (UniqueExamRegistration eId uid) (ExamRegistration eId uid (Just occId) now) [ExamRegistrationOccurrence =. Just occId, ExamRegistrationTime =. now]
|
|
audit $ TransactionExamRegister eId uid
|
|
addMessageIconI Success IconExamRegisterTrue $ MsgExamRegisteredSuccess examn
|
|
redirect $ CExamR tid ssh csh examn EShowR
|
|
_other -> error "Unexpected due to definition of buttonForm'"
|
|
|
|
redirect $ CExamR tid ssh csh examn EShowR
|
|
|