chore(add-users): remove invite functionality, implement avs form stub

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

@@ -107,8 +107,16 @@ CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer:i
 CourseParticipantEnlistDirectly: Bekannte Nutzer:innen sofort als Teilnehmer:in eintragen
 CourseSubmissionGroup: Feste Abgabegruppe
 SubmissionGroupEmptyIsUnsetTip: Leer lassen um Benutzer:innen aus den jeweiligen Abgabegruppen ersatzlos zu entfernen
-CourseParticipantsRegisterHeading: Kursteilnehmer :innen hinzufügen
+CourseParticipantsRegisterHeading: Kursteilnehmer:innen hinzufügen
+CourseParticipantsRegisterUsersField: Zum Kurs anzumeldende Personen
+CourseParticipantsRegisterUsersFieldTip: Bitte Personalnummer angeben. Mehrere Personen bitte mit Komma getrennt angeben.
+CourseParticipantsRegisterTutorialOption: Kursteilnehmer:innen zu Übungsgruppe anmelden?
+CourseParticipantsRegisterTutorialField: Übungsgruppe
+CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Übungsgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Übungsgruppe mit diesem Namen vorhanden, werden die Kursteilnehmenden dieser hinzugefügt.
+CourseParticipantsRegisterNoneGiven: Es wurden keine anzumeldenden Personen angegeben!
+
 CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
+CourseParticipantsAddedByAvs n@Int: #{n} AVS-Nutzer erfolgreich angemeldet (TODO)
 CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits angemeldet
 CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich angemeldet
 CourseApplicationText: Text-Bewerbung

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

@@ -108,7 +108,15 @@ CourseParticipantEnlistDirectly: Enrol known users directly
 CourseSubmissionGroup: Registered submission group
 SubmissionGroupEmptyIsUnsetTip: Leave empty to remove users from their respective submission groups
 CourseParticipantsRegisterHeading: Add course participants
+CourseParticipantsRegisterUsersField: Persons to register for course
+CourseParticipantsRegisterUsersFieldTip: Please enter personal number. Please separate multiple entries with commas.
+CourseParticipantsRegisterTutorialOption: Register course participants for tutorial?
+CourseParticipantsRegisterTutorialField: Tutorial
+CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it.
+CourseParticipantsRegisterNoneGiven: No persons given to register!
+
 CourseParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email
+CourseParticipantsAddedByAvs n: #{n} AVS users successfully registered (TODO)
 CourseParticipantsAlreadyRegistered n: #{n} #{pluralEN n "participant is" "participants are"} already enrolled
 CourseParticipantsRegistered n: Successfully registered #{n} #{pluralEN n "participant" "participants"}
 CourseApplicationText: Application text

routes

@@ -174,7 +174,6 @@
   /delete                     CDeleteR         GET POST        !lecturerANDemptyANDallocation-time
   /users                      CUsersR          GET POST
   !/users/new                 CAddUserR        GET POST        !lecturerANDallocation-time
-  !/users/invite              CInviteR         GET POST
   /users/#CryptoUUIDUser      CUserR           GET POST        !lecturerANDparticipant !lecturerANDapplicant
   /correctors                 CHiWisR          GET
   /communication              CCommR           GET POST

src/Foundation/Navigation.hs

@@ -249,7 +249,6 @@ breadcrumb (CourseR tid ssh csh CShowR) = useRunDB . maybeT (i18nCrumb MsgBreadc
 breadcrumb (CourseR tid ssh csh CEditR)     = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR
 breadcrumb (CourseR tid ssh csh CUsersR)    = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR
 breadcrumb (CourseR tid ssh csh CAddUserR)  = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR
-breadcrumb (CourseR tid ssh csh CInviteR)   = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR
 breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR
 breadcrumb (CourseR tid ssh csh (CUserR cID)) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do
   guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID

src/Handler/Course/ParticipantInvite.hs

@@ -2,137 +2,39 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 module Handler.Course.ParticipantInvite
-  ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
+  ( getCAddUserR, postCAddUserR
-  , getCInviteR, postCInviteR
-  , getCAddUserR, postCAddUserR
   , AddParticipantsResult(..)
   , addParticipantsResultMessages
   , registerUsers, registerUser
-  , registerUsers', registerUser'
   ) where
 
 import Import
 
 import Handler.Utils
-import Handler.Utils.Invitations
 import Handler.Utils.Course
+import Handler.Utils.Avs
 
 import Jobs.Queue
 
-import Control.Monad.Except (MonadError(..))
+--import Data.Aeson hiding (Result(..))
-
+--import qualified Data.CaseInsensitive as CI
-import Data.Aeson hiding (Result(..))
+--import qualified Data.HashSet as HashSet
-import qualified Data.CaseInsensitive as CI
+import Data.List (genericLength)
-import qualified Data.HashSet as HashSet
 import qualified Data.Map as Map
 import qualified Data.Text as Text
 import qualified Data.Time.Zones as TZ
 import qualified Data.Set as Set
 
+import Control.Monad.Except (MonadError(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
 
-data CourseAvsRegisterForm = CourseAvsRegisterForm
-  { cavsregParticipants :: Set Text -- TODO: NonEmpty
-  , cavsregTutorial     :: Maybe Day
-  }
-  deriving (Eq, Ord, Show, Read, Generic, Typeable)
-
-makeLenses_ ''CourseAvsRegisterForm
-
--- TODO: merge to postCAddUserR
-_courseAvsRegisterForm :: Maybe CourseAvsRegisterForm -> AForm Handler CourseAvsRegisterForm
-_courseAvsRegisterForm template = wFormToAForm $ do
-  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)
-
-  aFormToWForm $ CourseAvsRegisterForm
-    <$> areq (textField & cfCommaSeparatedSet) (fslI MsgCourseAvsRegisterParticipants & setTooltip MsgCourseAvsRegisterParticipantsTip) (cavsregParticipants <$> template)
-    <*> optionalActionA
-        ( areq dayField (fslI MsgCourseAvsRegisterTutorialDay) (Just . fromMaybe today . join $ cavsregTutorial <$> template)
-        )
-        (fslI MsgCourseAvsRegisterCreateTutorial) ((is _Just . cavsregTutorial <$> template) <|> Just True)
-
-
--- Invitations for ordinary participants of this course
-instance IsInvitableJunction CourseParticipant where
-  type InvitationFor CourseParticipant = Course
-  data InvitableJunction CourseParticipant = JunctionParticipant
-    { jParticipantRegistration :: UTCTime
-    , jParticipantAllocated    :: Maybe AllocationId
-    , jParticipantState        :: CourseParticipantState
-    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  data InvitationDBData CourseParticipant = InvDBDataParticipant
-    -- no data needed in DB to manage participant invitation
-    deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  data InvitationTokenData CourseParticipant = InvTokenDataParticipant
-    { invTokenParticipantSubmissionGroup :: Maybe SubmissionGroupName
-    }
-    deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-  _InvitableJunction = iso
-    (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState))
-    (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState) -> CourseParticipant{..})
-
-instance ToJSON (InvitableJunction CourseParticipant) where
-  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
-  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
-instance FromJSON (InvitableJunction CourseParticipant) where
-  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
-
-instance ToJSON (InvitationDBData CourseParticipant) where
-  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
-  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
-instance FromJSON (InvitationDBData CourseParticipant) where
-  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
-
-instance ToJSON (InvitationTokenData CourseParticipant) where
-  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
-  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
-instance FromJSON (InvitationTokenData CourseParticipant) where
-  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
-
-participantInvitationConfig :: InvitationConfig CourseParticipant
-participantInvitationConfig = InvitationConfig{..}
-  where
-    invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
-    invitationResolveFor _ = do
-      cRoute <- getCurrentRoute
-      case cRoute of
-        Just (CourseR tid csh ssh CInviteR) ->
-          getKeyBy404 $ TermSchoolCourseShort tid csh ssh
-        _other ->
-          error "participantInvitationConfig called from unsupported route"
-    invitationSubject     (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
-    invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
-    invitationExplanation  _                    _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
-    invitationTokenConfig _ _ = do
-      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
-      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
-    invitationRestriction _ _ = return Authorized
-    invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do
-      now <- liftIO getCurrentTime
-      return . pure . (, ()) $ JunctionParticipant now Nothing CourseParticipantActive
-    invitationInsertHook _ (Entity _ Course{..}) (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
-      deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
-      res <- act -- insertUnique
-      audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
-      void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup
-      memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
-      return res
-    invitationSuccessMsg (Entity _ Course{..}) _ =
-      return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
-    invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
-
 data AddParticipantsResult = AddParticipantsResult
   { aurAlreadyRegistered
-  , aurSuccess              :: Set UserId
+  , aurAlreadyTutorialMember
+  , aurRegisterSuccess
+  , aurTutorialSuccess       :: Set UserId
   } deriving (Read, Show, Generic, Typeable)
 
 instance Semigroup AddParticipantsResult where
@@ -142,50 +44,53 @@ instance Monoid AddParticipantsResult where
   mempty = memptydefault
   mappend = (<>)
 
+
 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
+  -- mr <- getMessageRender
+  today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
 
-    ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
+  let
-      enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
+    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)
 
-      let submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
+  ((usersToRegister, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
-      mbGrp <- wopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgCourseSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
+    users <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
+    mTutorial <- optionalActionW
+      ( areq textField (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ tshow today) ) -- TODO: use user date display setting
+      ( fslI MsgCourseParticipantsRegisterTutorialOption )
+      ( Just True )
+    return $ Map.fromSet . const <$> mTutorial <*> users
 
-      mr <- getMessageRender
+  formResultModal usersToRegister (CourseR tid ssh csh CUsersR) $
-      users <- wreq (multiUserInvitationField . maybe MUIAlwaysInvite (const $ MUILookupAnyUser Nothing) $ formResultToMaybe enlist)
+    registerUsers cid -- TODO: register for tutorial, if specified
-                 (fslpI MsgCourseParticipantInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing
 
-      return $ Map.fromSet . const <$> mbGrp <*> users
+  let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
 
-    formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
+  siteLayoutMsg heading $ do
-      hoist runDBJobs . registerUsers' cid
+    setTitleI heading
-
+    wrapForm formWgt def
-    let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
+      { formEncoding
-
+      , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
-    siteLayoutMsg heading $ do
+      }
-      setTitleI heading
-      wrapForm formWgt def
-        { formEncoding
-        , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
-        }
 
 
-registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
+registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] Handler ()
-registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing)
+registerUsers cid usersToRegister = do
+  avsUsers :: Map Text (Maybe UserId) <- fmap Map.fromList . forM (Map.keys usersToRegister) $ \userIdent -> do
+    mUser <- liftHandler $ upsertAvsUser userIdent -- TODO: upsertAvsUser should return whole Entity
+    return (userIdent, mUser)
 
-registerUsers' :: CourseId -> Map (Either UserEmail UserId) (Maybe SubmissionGroupName) -> WriterT [Message] (YesodJobDB UniWorX) ()
+  when (null avsUsers) $
-registerUsers' cid users = do
+    tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
-  let (emails,uids) = partitionKeysEither users
 
-  -- send Invitation eMails to unkown users
-  lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant{..})) | (mail, invTokenParticipantSubmissionGroup) <- Map.toList emails]
   -- register known users
-  tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser' cid) uids
+  -- tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser cid) uids
 
-  unless (null emails) $
+  -- unless (null avsUsers) $
-    tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
+  --   tell . pure <=< messageI Success . MsgCourseParticipantsAddedByAvs $ length avsUsers
 
 
 addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
@@ -199,21 +104,18 @@ addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
     let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
         modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
     tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
+  -- TODO: aurAlreadyTutorialMember
 
-  unless (null aurSuccess) $
+  unless (null aurRegisterSuccess) $
-    tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
+    tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess
+  unless (null aurTutorialSuccess) $
+    tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess
 
 
 registerUser :: CourseId
              -> UserId
              -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
-registerUser cid uid = registerUser' cid uid Nothing
+registerUser cid uid = exceptT tell tell $ do
-
-registerUser' :: CourseId
-              -> UserId
-              -> Maybe SubmissionGroupName
-              -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
-registerUser' cid uid mbGrp = exceptT tell tell $ do
   whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
     throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
 
@@ -233,11 +135,4 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do
   lift . lift . audit $ TransactionCourseParticipantEdit cid uid
   lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
 
-  void . lift . lift $ setUserSubmissionGroup cid uid mbGrp
+  return $ mempty { aurRegisterSuccess = Set.singleton uid }
-
-  return $ mempty { aurSuccess = Set.singleton uid }
-
-
-getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCInviteR = postCInviteR
-postCInviteR = invitationR participantInvitationConfig