refactor(add-users): restructure code; add action data types

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