80 lines
2.9 KiB
Haskell
80 lines
2.9 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.ExamOffice.Course
|
|
( getCExamOfficeR, postCExamOfficeR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Handler.Utils.ExamOffice.Course
|
|
import Handler.Utils
|
|
|
|
|
|
examOfficeOptOutForm :: UserId -> CourseId -> Maybe (Set SchoolId) -> Form (Set SchoolId)
|
|
-- ^ Deals with sets of _opt outs_
|
|
examOfficeOptOutForm uid cid (fromMaybe Set.empty -> template) = renderWForm FormStandard $ do
|
|
schools <- liftHandler . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid)
|
|
|
|
res <- fmap sequence . forM schools $ \(Entity ssh School{..}, E.Value isForced)
|
|
-> fmap (ssh, ) <$> bool wpopt wforcedJust isForced checkBoxField (fslI schoolName) (Just $ ssh `Set.notMember` template)
|
|
|
|
return $ res <&> setOf (folded . filtered (not . view _2) . _1)
|
|
|
|
getCExamOfficeR, postCExamOfficeR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCExamOfficeR = postCExamOfficeR
|
|
postCExamOfficeR tid ssh csh = do
|
|
uid <- requireAuthId
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
|
|
(cid, optOuts, hasForced) <- runDB $ do
|
|
cid <- getKeyBy404 (TermSchoolCourseShort tid ssh csh)
|
|
optOuts <- selectList [ CourseUserExamOfficeOptOutCourse ==. cid, CourseUserExamOfficeOptOutUser ==. uid ] []
|
|
hasForced <- E.selectExists $ do
|
|
(_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid)
|
|
E.where_ isForced
|
|
return (cid, optOuts, hasForced)
|
|
|
|
((optOutRes, optOutView), optOutEnc)
|
|
<- runFormPost $ examOfficeOptOutForm uid cid (Just $ setOf (folded . _entityVal . _courseUserExamOfficeOptOutSchool) optOuts )
|
|
|
|
formResultModal optOutRes (CourseR tid ssh csh CExamOfficeR) $ \optOuts' -> do
|
|
lift . runDB $ do
|
|
deleteWhere [ CourseUserExamOfficeOptOutCourse ==. cid
|
|
, CourseUserExamOfficeOptOutUser ==. uid
|
|
, CourseUserExamOfficeOptOutSchool /<-. Set.toList optOuts'
|
|
]
|
|
forM_ optOuts' $ \ssh' ->
|
|
void $ insertUnique CourseUserExamOfficeOptOut
|
|
{ courseUserExamOfficeOptOutCourse = cid
|
|
, courseUserExamOfficeOptOutUser = uid
|
|
, courseUserExamOfficeOptOutSchool = ssh'
|
|
}
|
|
tell . pure =<< messageI Success MsgExamOfficeOptOutsChanged
|
|
|
|
|
|
let optOutView' = wrapForm optOutView def
|
|
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CExamOfficeR
|
|
, formEncoding = optOutEnc
|
|
, formAttrs = [ asyncSubmitAttr | isModal ]
|
|
}
|
|
|
|
siteLayoutMsg MsgHeadingCourseExamOffice $ do
|
|
setTitleI MsgHeadingCourseExamOffice
|
|
|
|
let explanation = $(i18nWidgetFile "course-exam-office-explanation")
|
|
|
|
[whamlet|
|
|
$newline never
|
|
<section>
|
|
^{explanation}
|
|
<section>
|
|
^{optOutView'}
|
|
|]
|