This repository has been archived on 2024-10-24. You can view files and clone it, but cannot push or open issues or pull requests.
fradrive-old/src/Handler/Course/Schedule.hs

42 lines
1.4 KiB
Haskell

module Handler.Course.Schedule
( getCScheduleOptSetR, postCScheduleOptSetR
, getCScheduleOptDelR, postCScheduleOptDelR
) where
import Import
getCScheduleOptSetR, postCScheduleOptSetR :: TermId -> SchoolId -> CourseShorthand -> Bool -> Handler Html
getCScheduleOptSetR = postCScheduleOptSetR
postCScheduleOptSetR tid ssh csh opt = do
uid <- requireAuthId
mResult <- runDB $ maybeT (return Nothing) $ do
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
scheduleOpt <- lift $ upsert (CourseScheduleOpt
{ courseScheduleOptCourse = cid
, courseScheduleOptUser = uid
, courseScheduleOptOpt = opt
})
[ CourseScheduleOptOpt =. opt
]
return $ Just scheduleOpt
case mResult of
Just (Entity _ CourseScheduleOpt{..}) -> addMessageI Success $ bool MsgCourseScheduleOptOutSuccess MsgCourseScheduleOptInSuccess courseScheduleOptOpt
Nothing -> addMessageI Error MsgCourseScheduleOptError
redirect $ CourseR tid ssh csh CShowR
getCScheduleOptDelR, postCScheduleOptDelR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCScheduleOptDelR = postCScheduleOptDelR
postCScheduleOptDelR tid ssh csh = do
uid <- requireAuthId
runDB $ maybeT (return ()) $ do
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
lift . deleteBy $ UniqueCourseScheduleOpt cid uid
addMessageI Success MsgCourseScheduleOptDeleteSuccess
redirect $ CourseR tid ssh csh CShowR