diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 918c007d9..2f846eadd 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -587,6 +587,8 @@ CommCourseSubject: Kursmitteilung MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter InvitationAcceptDecline: Einladung annehmen/ablehnen +MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursteilname + MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn} MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn} @@ -750,6 +752,7 @@ MenuLogin: Login MenuLogout: Logout MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer +MenuCourseAddMembers: Kursteilnehmer hinzufügen MenuCourseCommunication: Kursmitteilung MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen @@ -861,6 +864,14 @@ LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursver CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName} CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein. +CourseParticipantInviteHeading courseName@Text: Einladung zum Kursteilnahmer für #{courseName} +CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzunehmen. +CourseParticipantEnlistDirectly: bekannte Teilnehmer sofort als Teilnehmer eintragen +CourseParticipantInviteField: einzuladende EMail Adressen + +CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer für #{courseName} eingetragen + + CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn} @@ -956,3 +967,9 @@ HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werd HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können HealthSMTPConnect: SMTP-Server kann erreicht werden HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus + +CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt +CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet +CourseParticipantsRegisteredWithoutField n@Int: #{tshow n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} +CourseParticipantsRegistered n@Int: #{tshow n} Teilnehmer erfolgreich angemeldet +CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen \ No newline at end of file diff --git a/routes b/routes index 711599b14..34a0bb4ff 100644 --- a/routes +++ b/routes @@ -85,6 +85,8 @@ /lecturer-invite CLecInviteR GET POST /delete CDeleteR GET POST !lecturerANDempty /users CUsersR GET POST + !/users/new CAddUserR GET POST + !/users/invite CInviteR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET /communication CCommR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index 33b54d844..65f897acb 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1271,7 +1271,7 @@ siteLayout' headingOverride widget = do applySystemMessages authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags forM_ authTagPivots $ - \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) + \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) getMessages let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority @@ -1444,6 +1444,8 @@ instance YesodBreadcrumbs UniWorX where -- (CourseR tid ssh csh CRegisterR) -- is POST only breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CUsersR) = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CAddUserR) = return ("Kursteilnehmer hinzufügen", Just $ CourseR tid ssh csh CUsersR) + breadcrumb (CourseR tid ssh csh CInviteR) = return ("Einladung", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR) breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) @@ -1983,6 +1985,16 @@ pageActions (CourseR tid ssh csh SheetListR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseR tid ssh csh CUsersR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCourseAddMembers + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAddUserR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + ] pageActions (CourseR tid ssh csh MaterialListR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index c50780b77..5d2762eb2 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -41,6 +41,11 @@ import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) +import Control.Monad.Trans.Writer (WriterT, execWriterT) +import Control.Monad.Except (MonadError(..)) + +import Generics.Deriving.Monoid (memptydefault, mappenddefault) + -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) @@ -710,7 +715,7 @@ lecturerInvitationConfig = InvitationConfig{..} itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataLecturer mlType, _) = hoistAForm liftHandlerT $ toJunction <$> case mlType of + invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of Nothing -> areq (selectField optionsFinite) lFs Nothing Just lType -> aforced (selectField optionsFinite) lFs lType where @@ -1422,3 +1427,151 @@ postCCommR tid ssh csh = do getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCLecInviteR = postCLecInviteR postCLecInviteR = invitationR lecturerInvitationConfig + + + +-- Invitations for ordinary participants of this course +instance IsInvitableJunction CourseParticipant where + type InvitationFor CourseParticipant = Course + data InvitableJunction CourseParticipant = JunctionParticipant + { jParticipantRegistration :: UTCTime + , jParticipantFild :: Maybe StudyFeaturesId + } 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 + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField)) + (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..}) + + ephemeralInvitation = Just (iso (const InvDBDataParticipant) (const ())) + +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 { constructorTagModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } +instance FromJSON (InvitationTokenData CourseParticipant) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + +participantInvitationConfig :: InvitationConfig CourseParticipant +participantInvitationConfig = InvitationConfig{..} + where + invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR + invitationResolveFor = do + Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute + getKeyBy404 $ TermSchoolCourseShort tid csh ssh + invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand + invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] + -- Keine besonderen Einschränkungen beim Einlösen der Token + -- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden! + invitationTokenConfig _ _ = do + itAuthority <- liftHandlerT requireAuthId + return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing + invitationRestriction _ _ = return Authorized + invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do + now <- liftIO getCurrentTime + studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) + (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing + return $ JunctionParticipant <$> pure now <*> studyFeatures + invitationSuccessMsg Course{..} _ = + return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) + invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR + +data AddRecipientsResult = AddRecipientsResult + { aurAlreadyRegistered + , aurNoUniquePrimaryField + , aurSuccess :: [UserEmail] + } deriving (Read, Show, Generic, Typeable) + +instance Monoid AddRecipientsResult where + mempty = memptydefault + mappend = mappenddefault + +getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCAddUserR = postCAddUserR +postCAddUserR tid ssh csh = do + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do + enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) + wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) + (fslI MsgCourseParticipantInviteField) Nothing + + formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers 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 + } + where + processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler () + processUsers cid users = do + let (emails,uids) = partitionEithers $ Set.toList users + AddRecipientsResult alreadyRegistered registeredNoField registeredOneField <- lift . runDBJobs $ do + -- send Invitation eMails to unkown users + sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails] + -- register known users + execWriterT $ mapM (registerUser cid) uids + + when (not $ null emails) $ + tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails + + when (not $ null alreadyRegistered) $ do + let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}|] + modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") + tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) + + when (not $ null registeredNoField) $ do + let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}|] + modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField") + tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) + + when (not $ null registeredOneField) $ + tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length registeredOneField + + registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () + registerUser cid uid = exceptT tell tell $ do + User{..} <- lift . lift $ getJust uid + + whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ + throwError $ mempty { aurAlreadyRegistered = pure userEmail } + + features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] + + let courseParticipantField + | [f] <- features = Just f + | otherwise = Nothing + + courseParticipantRegistration <- liftIO getCurrentTime + void . lift . lift . insert $ CourseParticipant + { courseParticipantCourse = cid + , courseParticipantUser = uid + , .. + } + + return $ case courseParticipantField of + Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } + Just _ -> mempty { aurSuccess = pure userEmail } + + +getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCInviteR = postCInviteR +postCInviteR = invitationR participantInvitationConfig diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 53bd24028..0a3b8c3fe 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -857,7 +857,7 @@ correctorInvitationConfig = InvitationConfig{..} itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataSheetCorrector load state, _) = pure $ JunctionSheetCorrector load state + invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ JunctionSheetCorrector load state invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationUltDest Sheet{..} _ = do Course{..} <- get404 sheetCourse diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index d5f5961cd..15c228664 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -113,7 +113,7 @@ submissionUserInvitationConfig = InvitationConfig{..} itStartsAt = Nothing return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized - invitationForm _ _ = pure JunctionSubmissionUser + invitationForm _ _ _ = pure JunctionSubmissionUser invitationSuccessMsg Submission{..} _ = do Sheet{..} <- getJust submissionSheet return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 140743ce8..6566a9cef 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -260,7 +260,7 @@ tutorInvitationConfig = InvitationConfig{..} itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ _ = pure JunctionTutor + invitationForm _ _ _ = pure JunctionTutor invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName invitationUltDest Tutorial{..} _ = do Course{..} <- get404 tutorialCourse @@ -290,7 +290,7 @@ tutorialForm cid template html = do Just cRoute <- getCurrentRoute uid <- liftHandlerT requireAuthId - let + let tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) where miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) @@ -317,7 +317,7 @@ tutorialForm cid template html = do miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout") - + flip (renderAForm FormStandard) html $ TutorialForm <$> areq ciField (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template) <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) @@ -356,7 +356,7 @@ getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> getCTutorialNewR = postCTutorialNewR postCTutorialNewR tid ssh csh = do Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh - + ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing formResult newTutResult $ \TutorialForm{..} -> do @@ -447,7 +447,7 @@ postTEditR tid ssh csh tutn = do } when (is _Nothing insertRes) $ do let (invites, adds) = partitionEithers $ Set.toList tfTutors - + deleteWhere [ TutorTutorial ==. tutid ] insertMany_ $ map (Tutor tutid) adds diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index a8d0223ae..ba80dd1fe 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -48,7 +48,7 @@ class ( PersistRecordBackend junction (YesodPersistBackend UniWorX) type InvitationFor junction :: * -- | `junction` without `Key User` and `Key (InvitationFor junction)` data InvitableJunction junction :: * - + -- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction` -- -- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction` @@ -129,7 +129,7 @@ data InvitationConfig junction = InvitationConfig -- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently) , invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult -- ^ Additional restrictions to check before allowing an user to redeem an invitation token - , invitationForm :: InvitationFor junction -> InvitationData junction -> AForm (YesodDB UniWorX) (InvitableJunction junction) + , invitationForm :: InvitationFor junction -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction) -- ^ Assimilate the additional data entered by the redeeming user , invitationSuccessMsg :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeMessage UniWorX) -- ^ What to tell the redeeming user after accepting the invitation @@ -158,7 +158,7 @@ $(return []) instance ToJSON (InvitationTokenRestriction junction) where toJSON = $(mkToJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction) - + instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction junction) where parseJSON = $(mkParseJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction) @@ -198,7 +198,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif ur <- getUrlRenderParams fRec <- get404 fid - + jInviter <- liftHandlerT requireAuthId route <- mapReaderT liftHandlerT $ invitationRoute (Entity fid fRec) dat InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat @@ -284,7 +284,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do iData = review _InvitationData (dbData, itData) guardAuthResult =<< invitationRestriction fRec iData ((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do - dataRes <- aFormToWForm $ invitationForm fRec iData + dataRes <- aFormToWForm $ invitationForm fRec iData invitee btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction)) case btnRes of FormSuccess BtnInviteDecline -> return $ FormSuccess Nothing @@ -333,7 +333,7 @@ instance InvitationR (Handler Html) where instance InvitationR b => InvitationR (a -> b) where invitationR cfg _ = invitationR cfg - + -- $procedure -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index daab376d3..ad62f224f 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -8,7 +8,7 @@ import Settings import Utils.Parameters --- import Text.Blaze (toMarkup) -- for debugging +import Text.Blaze (Markup) import qualified Text.Blaze.Internal as Blaze (null) import qualified Data.Text as T @@ -498,6 +498,10 @@ renderAForm formLayout aform fragment = do let widget = $(widgetFile "widgets/aform/aform") return (res, widget) +renderWForm :: MonadHandler m => FormLayout -> WForm m (FormResult a) -> -- Form a -- (Synonym unavailable here) + (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) +renderWForm formLayout = renderAForm formLayout . wFormToAForm + -- | special id to identify form section headers, see 'aformSection' and 'formSection' -- currently only treated by form generation through 'renderAForm' diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs index 79142ae4b..dd83497ea 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/src/Utils/Frontend/Modal.hs @@ -1,7 +1,7 @@ module Utils.Frontend.Modal ( Modal(..) , customModal - , modal + , modal, msgModal ) where import ClassyPrelude.Yesod @@ -11,6 +11,9 @@ import Utils.Route import Settings (widgetFile) +import Control.Monad.Random.Class (MonadRandom(..)) +import qualified Data.UUID as UUID + data Modal site = Modal { modalTriggerId @@ -37,3 +40,15 @@ modal modalTrigger' modalContent = customModal Modal{..} modalTriggerId = Nothing modalId = Nothing modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger") + + +-- | Variant of `modal` for use in messages (uses a different id generator to avoid collisions) +msgModal :: WidgetT site IO () + -> Either (SomeRoute site) (WidgetT site IO ()) + -> WidgetT site IO () +msgModal modalTrigger' modalContent = do + modalTriggerId <- Just . UUID.toText <$> liftIO getRandom + modalId <- Just . UUID.toText <$> liftIO getRandom + customModal Modal{..} + where + modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger") diff --git a/templates/messages/courseInvitationAlreadyRegistered.hamlet b/templates/messages/courseInvitationAlreadyRegistered.hamlet new file mode 100644 index 000000000..e6102976b --- /dev/null +++ b/templates/messages/courseInvitationAlreadyRegistered.hamlet @@ -0,0 +1,5 @@ +

+ _{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)} +