diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 4ed0c1c40..1046b6bf9 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -271,7 +271,7 @@ data CourseUserActionData = CourseUserSendMailData { registerTutorial :: TutorialId } | CourseUserRegisterExamData - { registerExam :: ExamId + { registerExam :: (ExamId, Maybe ExamOccurrenceId) } deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -479,7 +479,13 @@ postCUsersR tid ssh csh = do mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh hasTutorials <- exists [TutorialCourse ==. cid] - hasExams <- exists [ExamCourse ==. cid] + exams <- E.select . E.from $ \exam -> do + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return exam + examOccurrencesPerExam <- E.select . E.from $ \(exam `E.LeftOuterJoin` examOccurrence) -> do + E.on $ E.just (exam E.^. ExamId) E.==. examOccurrence E.?. ExamOccurrenceExam + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return (exam, examOccurrence) let colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) @@ -495,6 +501,32 @@ postCUsersR tid ssh csh = do , pure $ colUserComment tid ssh csh ] psValidator = def & defaultSortingByName + hasExams = not $ null examOccurrencesPerExam + examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId)) + examOccActs = examOccurrencesPerExam + & (map (bimap entityKey hoistMaybe)) + & Map.fromListWith (<>) + & imap (\k v -> case v of + [] -> pure (k, Nothing) + _ -> (k,) <$> aopt (selectField' (Just $ SomeMessage MsgExamNoOccurrence) $ examOccOpts v) (fslI MsgExamOccurrence) (Just Nothing) + ) + where + examOccOpts :: [Entity ExamOccurrence] -> Handler (OptionList ExamOccurrenceId) + examOccOpts examOccs = fmap mkOptionList . forM examOccs $ \Entity{..} -> do + optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExamOccurrence + let + optionExternalValue = toPathPiece optionExternalValue' + optionInternalValue = entityKey + optionDisplay = CI.original $ examOccurrenceName entityVal + return Option{..} + examActs :: Handler (OptionList ExamId) + examActs = fmap mkOptionList . forM exams $ \Entity{..} -> do + optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExam + let + optionExternalValue = toPathPiece optionExternalValue' + optionInternalValue = entityKey + optionDisplay = CI.original $ examName entityVal + return Option{..} acts = mconcat [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData , singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData <$> @@ -502,9 +534,10 @@ postCUsersR tid ssh csh = do (fslI MsgCourseTutorial) Nothing , singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$> - apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [ExamCourse ==. cid] [Asc ExamName] examName) - (fslI MsgCourseExam) - Nothing + multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing + --apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [ExamCourse ==. cid] [Asc ExamName] examName) + -- (fslI MsgCourseExam) + -- Nothing , if | mayRegister -> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid @@ -539,16 +572,16 @@ postCUsersR tid ssh csh = do (CourseUserRegisterExamData{..}, selectedUsers) -> do Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do now <- liftIO getCurrentTime - -- TODO allow occurence + let (exam, mOccurrence) = registerExam mExamReg <- insertUnique ExamRegistration - { examRegistrationExam = registerExam + { examRegistrationExam = exam , examRegistrationUser = uid - , examRegistrationOccurrence = Nothing + , examRegistrationOccurrence = mOccurrence , examRegistrationTime = now } if isJust mExamReg then do - audit $ TransactionExamRegister registerExam uid + audit $ TransactionExamRegister exam uid return 1 else return 0 addMessageI Success $ MsgCourseUsersExamRegistered nrReg