Merge branch 'feat/course-participant-invitation'
This commit is contained in:
Gregor Kleen
commit
0568e8a3f6
@ -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
|
||||
2
routes
2
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
--
|
||||
|
||||
@ -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'
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -0,0 +1,5 @@
|
||||
<h2>
|
||||
_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}
|
||||
<ul>
|
||||
$forall email <- alreadyRegistered
|
||||
<li style="font-family: monospace">#{email}
|
||||
@ -0,0 +1,5 @@
|
||||
<h2>
|
||||
_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}
|
||||
<ul>
|
||||
$forall email <- registeredNoField
|
||||
<li style="font-family: monospace">#{email}
|
||||
Loading…
Reference in New Issue
Block a user