diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index f0012dbe0..33609c82d 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index d99c81ffd..40e1ff960 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/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 diff --git a/routes b/routes index 435ca94d3..09ef362ad 100644 --- a/routes +++ b/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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b17708671..de957e320 100644 --- a/src/Foundation/Navigation.hs +++ b/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 diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index fc8d44312..059734222 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/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(..) - , getCInviteR, postCInviteR - , getCAddUserR, postCAddUserR + ( 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 qualified Data.HashSet as HashSet +--import Data.Aeson hiding (Result(..)) +--import qualified Data.CaseInsensitive as CI +--import qualified Data.HashSet as HashSet +import Data.List (genericLength) 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 - enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) + 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) - let submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal) - mbGrp <- wopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgCourseSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing + ((usersToRegister, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do + 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 - users <- wreq (multiUserInvitationField . maybe MUIAlwaysInvite (const $ MUILookupAnyUser Nothing) $ formResultToMaybe enlist) - (fslpI MsgCourseParticipantInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing + formResultModal usersToRegister (CourseR tid ssh csh CUsersR) $ + registerUsers cid -- TODO: register for tutorial, if specified - return $ Map.fromSet . const <$> mbGrp <*> users + let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading - formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ - hoist runDBJobs . registerUsers' cid - - let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading - - siteLayoutMsg heading $ do - setTitleI heading - wrapForm formWgt def - { 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 cid = registerUsers' cid . Map.fromSet (const Nothing) +registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] Handler () +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) () -registerUsers' cid users = do - let (emails,uids) = partitionKeysEither users + when (null avsUsers) $ + tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven - -- 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) $ - tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails + -- unless (null avsUsers) $ + -- 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) $ - tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess + unless (null aurRegisterSuccess) $ + 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' :: CourseId - -> UserId - -> Maybe SubmissionGroupName - -> WriterT AddParticipantsResult (YesodJobDB UniWorX) () -registerUser' cid uid mbGrp = exceptT tell tell $ do +registerUser cid uid = 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 { aurSuccess = Set.singleton uid } - - -getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCInviteR = postCInviteR -postCInviteR = invitationR participantInvitationConfig + return $ mempty { aurRegisterSuccess = Set.singleton uid }