chore(add-users): add confirmation form

messages/uniworx/categories/courses/courses/de-de-formal.msg

@@ -108,6 +108,8 @@ CourseParticipantEnlistDirectly: Bekannte Nutzer:innen sofort als Teilnehmer:in
 CourseSubmissionGroup: Feste Abgabegruppe
 SubmissionGroupEmptyIsUnsetTip: Leer lassen um Benutzer:innen aus den jeweiligen Abgabegruppen ersatzlos zu entfernen
 CourseParticipantsRegisterHeading: Kursteilnehmer:innen hinzufügen
+CourseParticipantsRegisterActionAddParticipants: Personen zum Kurs anmelden
+CourseParticipantsRegisterActionAddTutorialMembers: Personen zu Kurs und Übungsgruppe anmelden
 CourseParticipantsRegisterUsersField: Zum Kurs anzumeldende Personen
 CourseParticipantsRegisterUsersFieldTip: Bitte Personalnummer angeben. Mehrere Personen bitte mit Komma getrennt angeben.
 CourseParticipantsRegisterTutorialOption: Kursteilnehmer:innen zu Übungsgruppe anmelden?

messages/uniworx/categories/courses/courses/en-eu.msg

@@ -108,6 +108,8 @@ CourseParticipantEnlistDirectly: Enrol known users directly
 CourseSubmissionGroup: Registered submission group
 SubmissionGroupEmptyIsUnsetTip: Leave empty to remove users from their respective submission groups
 CourseParticipantsRegisterHeading: Add course participants
+CourseParticipantsRegisterActionAddParticipants: Add course participants
+CourseParticipantsRegisterActionAddTutorialMembers: Add course and tutorial participants
 CourseParticipantsRegisterUsersField: Persons to register for course
 CourseParticipantsRegisterUsersFieldTip: Please enter personal number. Please separate multiple entries with commas.
 CourseParticipantsRegisterTutorialOption: Register course participants for tutorial?

src/Handler/Course/ParticipantInvite.hs

@@ -18,8 +18,10 @@ import Jobs.Queue
 --import qualified Data.Conduit.List as C (sourceList)
 --import qualified Data.Conduit.Combinators as C
 
+import qualified Data.Aeson as Aeson
 import qualified Data.CaseInsensitive as CI
 --import Data.List (genericLength)
+import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Text as Text
 import qualified Data.Time.Zones as TZ
@@ -37,56 +39,74 @@ type UserSearchKey = Text
 type TutorialIdent = CI Text
 
 
---data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort
+data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort
---  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
---instance Universe ButtonCourseRegisterMode
+instance Universe ButtonCourseRegisterMode
---instance Finite ButtonCourseRegisterMode
+instance Finite ButtonCourseRegisterMode
---
+
---embedRenderMessage ''UniWorX ''ButtonCourseRegisterMode id
+embedRenderMessage ''UniWorX ''ButtonCourseRegisterMode id
---
+
---nullaryPathPiece ''ButtonCourseRegisterMode $ camelToPathPiece' 1
+nullaryPathPiece ''ButtonCourseRegisterMode $ camelToPathPiece' 1
---
+
---instance Button UniWorX ButtonCourseRegisterMode where
+instance Button UniWorX ButtonCourseRegisterMode where
---  btnLabel x = [whamlet|_{x}|]
+  btnLabel x = [whamlet|_{x}|]
---
+
---  btnClasses BtnCourseRegisterAdd     = [BCIsButton, BCPrimary]
+  btnClasses BtnCourseRegisterAdd     = [BCIsButton, BCPrimary]
---  btnClasses BtnCourseRegisterConfirm = [BCIsButton, BCPrimary]
+  btnClasses BtnCourseRegisterConfirm = [BCIsButton, BCPrimary]
---  btnClasses BtnCourseRegisterAbort   = [BCIsButton, BCDanger]
+  btnClasses BtnCourseRegisterAbort   = [BCIsButton, BCDanger]
---
+
---  btnValidate _ BtnCourseRegisterAbort = False
+  btnValidate _ BtnCourseRegisterAbort = False
---  btnValidate _ _                      = True
+  btnValidate _ _                      = True
---
+
---
+
---data CourseRegisterAction
+data CourseRegisterAction
---   = CourseRegisterActionAddParticipant
+   = CourseRegisterActionAddParticipant
---   | CourseRegisterActionAddTutorialMember
+   | CourseRegisterActionAddTutorialMember
---   | CourseRegisterActionUnknownPerson
+-- | CourseRegisterActionUnknownPerson
---   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
---instance Universe CourseRegisterAction
+instance Universe CourseRegisterAction
---instance Finite CourseRegisterAction
+instance Finite CourseRegisterAction
---
+
---data CourseRegisterActionData
+data CourseRegisterActionData
---   = CourseRegisterActionAddParticipantData
+   = CourseRegisterActionAddParticipantData
---     { crActAddParticipantUser     :: UserId
+     { crActAddParticipantIdent       :: UserSearchKey
---     , crActAddParticipantTutorial :: Maybe TutorialIdent
+     , crActAddParticipantUser        :: UserId
---     }
+     }
---   | CourseRegisterActionAddTutorialMemberData
+   | CourseRegisterActionAddTutorialMemberData
---     { crActAddTutorialMemberParticipant :: CourseParticipantId
+     { crActAddTutorialMemberIdent    :: UserSearchKey
---     , crActAddTutorialMemberTutorial    :: TutorialIdent
+     , crActAddTutorialMemberUser     :: UserId
---     }
+     , crActAddTutorialMemberTutorial :: TutorialIdent
---   | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display
+     }
---     { crActUnknownPersonIdent :: Text
+-- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display
---     }
+--   { crActUnknownPersonIdent :: Text
---   deriving (Eq, Ord, Read, Show, Generic, Typeable)
+--   }
---
+   deriving (Eq, Ord, Read, Show, Generic, Typeable)
---makeLenses_ ''CourseRegisterActionData
+
---
+makeLenses_ ''CourseRegisterActionData
---classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction
+
---classifyRegisterAction = \case
+instance Aeson.FromJSON CourseRegisterActionData where
---  CourseRegisterActionAddParticipantData{}    -> CourseRegisterActionAddParticipant
+  parseJSON = Aeson.genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }
---  CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember
+
---  CourseRegisterActionUnknownPersonData{}     -> CourseRegisterActionUnknownPerson
+instance Aeson.ToJSON CourseRegisterActionData where
---
+  toJSON = Aeson.genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }
+  toEncoding = Aeson.genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }
+
+_classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction
+_classifyRegisterAction = \case
+  CourseRegisterActionAddParticipantData{}    -> CourseRegisterActionAddParticipant
+  CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember
+--CourseRegisterActionUnknownPersonData{}     -> CourseRegisterActionUnknownPerson
+
+courseRegisterRenderActionClass :: CourseRegisterAction -> Widget
+courseRegisterRenderActionClass = \case
+  CourseRegisterActionAddParticipant    -> [whamlet|_{MsgCourseParticipantsRegisterActionAddParticipants}|]
+  CourseRegisterActionAddTutorialMember -> [whamlet|_{MsgCourseParticipantsRegisterActionAddTutorialMembers}|]
+
+courseRegisterRenderAction :: CourseRegisterActionData -> Widget
+courseRegisterRenderAction = \case
+  CourseRegisterActionAddParticipantData{..}    -> [whamlet|TODO USER (#{crActAddParticipantIdent})|]
+  CourseRegisterActionAddTutorialMemberData{..} -> [whamlet|TODO USER (#{crActAddTutorialMemberIdent})|]
+
 --data CourseRegisterActionClass
 --   = CourseRegisterActionClassNew
 --   | CourseRegisterActionClassExisting
@@ -175,7 +195,7 @@ instance Monoid AddParticipantsResult where
 getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCAddUserR = postCAddUserR
 postCAddUserR tid ssh csh = do
-  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+  _cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
   today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
   currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
 
@@ -201,16 +221,58 @@ postCAddUserR tid ssh csh = do
                 <li>#{usr}
             |]
        in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
-    if null usersFound
+    when (null usersFound) $
-      then redirect currentRoute
+      redirect currentRoute
-      else do
+
-        registeredUsers <- registerUsers cid avsUsers
+    liftHandler . (>>= sendResponse) $
-        case auReqTutorial of
+      siteLayoutMsg MsgCourseParticipantsRegisterHeading $ do
-          Nothing -> redirect $ CourseR tid ssh csh CUsersR
+        setTitleI MsgCourseParticipantsRegisterHeading
-          Just tutorialName -> do
+
-            tutId <- upsertNewTutorial cid tutorialName
+        actionMap :: Map CourseRegisterAction (Set CourseRegisterActionData) <- fmap Map.unions . forM usersFound $ \case
-            registerTutorialMembers tutId registeredUsers
+          (_, Nothing) -> error "Found user in AVS, but response is Nothing!" -- this should not be possible
-            redirect $ CTutorialR tid ssh csh tutorialName TUsersR
+          (ukey, Just uid) -> do
+            -- isParticipant <- exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]
+            case auReqTutorial of
+              Nothing -> return . Map.singleton CourseRegisterActionAddParticipant . Set.singleton $ CourseRegisterActionAddParticipantData ukey uid
+              Just crActAddTutorialMemberTutorial -> return . Map.singleton CourseRegisterActionAddTutorialMember . Set.singleton $ CourseRegisterActionAddTutorialMemberData ukey uid crActAddTutorialMemberTutorial
+
+        let
+          precomputeIdents :: forall f m. (Eq (Element f), MonoFoldable f, MonadHandler m) => f -> m (Element f -> Text)
+          precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed")
+        actionClassIdent <- precomputeIdents $ Map.keys actionMap
+        actionIdent <- precomputeIdents . Set.unions $ Map.elems actionMap
+
+        let
+          confirmCheckBox :: [(Text,Text)] -> CourseRegisterActionData -> Widget
+          confirmCheckBox vAttrs act = do
+            let
+              sJsonField :: Field (HandlerFor UniWorX) CourseRegisterActionData
+              sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
+                [whamlet|
+                  $newline never
+                  <input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} checked>
+                |]
+            fieldView sJsonField (actionIdent act) (toPathPiece PostCourseUserAddConfirmAction) vAttrs (Right act) False
+          availableActs :: Widget
+          availableActs = fieldView (secretJsonField :: Field Handler (Set CourseRegisterActionData)) "" (toPathPiece PostCourseUserAddConfirmAvailableActions) [] (Right . Set.unions $ Map.elems actionMap) False
+        (confirmForm', confirmEnctype) <- generateFormPost . withButtonForm' [BtnCourseRegisterConfirm, BtnCourseRegisterAbort] . identifyForm FIDCourseRegisterConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "course/add-user/confirmation"))
+        let confirmForm = wrapForm confirmForm' FormSettings
+              { formMethod   = POST
+              , formAction   = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
+              , formEncoding = confirmEnctype
+              , formAttrs    = []
+              , formSubmit   = FormNoSubmit
+              , formAnchor   = Nothing :: Maybe Text
+              }
+        $(widgetFile "course/add-user/confirmation-wrapper")
+
+        --registeredUsers <- registerUsers cid avsUsers
+        --case auReqTutorial of
+        --  Nothing -> redirect $ CourseR tid ssh csh CUsersR
+        --  Just tutorialName -> do
+        --    tutId <- upsertNewTutorial cid tutorialName
+        --    registerTutorialMembers tutId registeredUsers
+        --    redirect $ CTutorialR tid ssh csh tutorialName TUsersR
 
   let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
 
@@ -310,21 +372,21 @@ postCAddUserR tid ssh csh = do
 --      $(widgetFile "course/add-user/confirmation-wrapper")
 
 
-registerUsers :: CourseId -> Map UserSearchKey (Maybe UserId) -> Handler (Set UserId) -- WriterT [Message] (YesodJobDB UniWorX) ()
+_registerUsers :: CourseId -> Map UserSearchKey (Maybe UserId) -> Handler (Set UserId) -- WriterT [Message] (YesodJobDB UniWorX) ()
-registerUsers cid users
+_registerUsers cid users
   | Map.null users = do
     addMessageI Error MsgCourseParticipantsRegisterNoneGiven
     return Set.empty
   | otherwise = do
-    (mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (registerUser cid) $ Map.toList users
+    (mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (_registerUser cid) $ Map.toList users
     unless (Set.null aurRegisterSuccess) $
       addMessageI Success . MsgCourseParticipantsRegistered $ Set.size aurRegisterSuccess
     unless (Set.null aurAlreadyRegistered) $
       addMessageI Info . MsgCourseParticipantsAlreadyRegistered $ Set.size aurAlreadyRegistered
     return $ aurRegisterSuccess `Set.union` aurAlreadyRegistered
 
-upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId
+_upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId
-upsertNewTutorial cid tutorialName = do
+_upsertNewTutorial cid tutorialName = do
   now <- liftIO getCurrentTime
   Entity tutId _ <- runDB $ upsert
     Tutorial
@@ -347,8 +409,8 @@ upsertNewTutorial cid tutorialName = do
     ]
   return tutId
 
-registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
+_registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
-registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
+_registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
   prevParticipants <- fmap Set.fromList $ selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] []
   participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> upsert
     TutorialParticipant
@@ -389,12 +451,12 @@ registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
 --    tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess
 
 
-registerUser :: CourseId
+_registerUser :: CourseId
              -> (UserSearchKey, Maybe UserId)
              -> YesodJobDB UniWorX AddParticipantsResult
              -- -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
-registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent } -- tell $ mempty { aurNotFound = Set.singleton avsIdent }
+_registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent } -- tell $ mempty { aurNotFound = Set.singleton avsIdent }
-registerUser  cid (_avsIdent, Just uid) = exceptT return return $ do
+_registerUser  cid (_avsIdent, Just uid) = exceptT return return $ do
   whenM (lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
     throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
 

src/Utils/Parameters.hs

@@ -74,6 +74,7 @@ data GlobalPostParam = PostFormIdentifier
                      | PostBearer
                      | PostDBCsvImportAction | PostDBCsvImportAvailableActions
                      | PostDBCsvReImport
+                     | PostCourseUserAddConfirmAction | PostCourseUserAddConfirmAvailableActions
                      | PostLoginDummy
                      | PostExamAutoOccurrencePrevious
                      | PostLanguage

templates/course/add-user/confirmation-wrapper.hamlet

@@ -4,7 +4,7 @@ $# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
-<section>
+$#<section>
-  <p>_{MsgCourseAddUserConfirmationTip}
+$#  <p>_{MsgCourseAddUserConfirmationTip}
 <section>
   ^{confirmForm}

templates/course/add-user/confirmation.hamlet

@@ -7,11 +7,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 #{csrf}
 ^{availableActs}
 <div .actions>
-  $forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap)
+  $forall actionClass <- sortOn id (Map.keys actionMap)
     <div .action>
-      <input type=checkbox id=#{actionClassIdent actionClass} .action__checkbox :defaultChecked actionClass:checked>
+      <input type=checkbox id=#{actionClassIdent actionClass} .action__checkbox checked>
       <label .action__label for=#{actionClassIdent actionClass}>
-        ^{dbtCsvRenderActionClass actionClass}
+        ^{courseRegisterRenderActionClass actionClass}
 
       <fieldset .action__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{actionClassIdent actionClass}>
         <div .action__checked-counter>
@@ -22,6 +22,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         <div .action__options>
           $forall action <- Set.toList (actionMap ! actionClass)
             <div .action__option>
-              ^{csvActionCheckBox [] action}
+              ^{confirmCheckBox [] action}
               <label .action__option-label for=#{actionIdent action}>
-                ^{dbtCsvRenderKey existing action}
+                ^{courseRegisterRenderAction action}