diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 2c857bbcf..5bd9eaaff 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -24,6 +24,9 @@ import Control.Monad.Except (MonadError(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) +type TutorialIdent = CI Text + + data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonCourseRegisterMode @@ -44,9 +47,40 @@ instance Button UniWorX ButtonCourseRegisterMode where btnValidate _ _ = True +data CourseRegisterAction + = CourseRegisterActionAddParticipant + | CourseRegisterActionAddTutorialMember + | CourseRegisterActionUnknownPerson + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +instance Universe CourseRegisterAction +instance Finite CourseRegisterAction + +data CourseRegisterActionData + = CourseRegisterActionAddParticipantData + { crActParticipantUser :: UserId + , crActParticipantTutorial :: Maybe TutorialIdent + } + | CourseRegisterActionAddTutorialMemberData + { crActTutorialMemberParticipant :: CourseParticipantId + , crActTutorialMemberTutorial :: TutorialIdent + } + | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display + { crActUnknownPersonIdent :: Text + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makeLenses_ ''CourseRegisterActionData + +classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction +classifyRegisterAction = \case + CourseRegisterActionAddParticipantData{} -> CourseRegisterActionAddParticipant + CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember + CourseRegisterActionUnknownPersonData{} -> CourseRegisterActionUnknownPerson + + data AddUsers = AddUsers { auUsers :: Set Text - , auTutorial :: Maybe (CI Text) + , auTutorial :: Maybe TutorialIdent } deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -73,11 +107,10 @@ postCAddUserR tid ssh csh = do -- mr <- getMessageRender today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - let - cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) - cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) - - ((usersToRegister, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do + ((usersToRegister :: FormResult AddUsers, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do + let + cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) + cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) auUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auTutorial <- optionalActionW ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting @@ -92,9 +125,9 @@ postCAddUserR tid ssh csh = do = CourseR tid ssh csh CUsersR formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do avsUsers :: Map Text (Maybe UserId) <- sequenceA . flip Map.fromSet auUsers $ liftHandler . upsertAvsUser - let retrievedUsers = catMaybes $ Map.elems avsUsers - if - | uids@(_:_) <- retrievedUsers -> do + case catMaybes $ Map.elems avsUsers of + [] -> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven + uids -> do registerUsers cid avsUsers for_ auTutorial $ \tutorialName -> lift $ do -- TODO: move somewhere else @@ -125,8 +158,6 @@ postCAddUserR tid ssh csh = do } [] -- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids - | otherwise - -> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading