feat(course-users): register exam action with optional occurrence

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)
+            multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing
-                  (fslI MsgCourseExam)
+            --apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [ExamCourse ==. cid] [Asc ExamName] examName)
-                  Nothing
+            --      (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