From 487c46a1cec5769b09bb54840fe28de4d63cfd5a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 13 May 2019 00:17:12 +0200 Subject: [PATCH] Finish implementation of course participant invitations Fixes #250 --- messages/uniworx/de.msg | 9 ++ src/Foundation.hs | 14 ++- src/Handler/Course.hs | 103 +++++++++++++----- src/Utils/Frontend/Modal.hs | 17 ++- .../courseInvitationAlreadyRegistered.hamlet | 5 + ...rseInvitationRegisteredWithoutField.hamlet | 5 + 6 files changed, 126 insertions(+), 27 deletions(-) create mode 100644 templates/messages/courseInvitationAlreadyRegistered.hamlet create mode 100644 templates/messages/courseInvitationRegisteredWithoutField.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f35f195af..a4762c0b5 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -745,6 +745,7 @@ MenuLogin: Login MenuLogout: Logout MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer +MenuCourseAddMembers: Kursteilnehmer hinzufügen MenuCourseCommunication: Kursmitteilung MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen @@ -860,6 +861,8 @@ CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzun 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 @@ -951,3 +954,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/src/Foundation.hs b/src/Foundation.hs index 9161ef86a..e71ac2611 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1248,7 +1248,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 @@ -1417,6 +1417,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) @@ -1955,6 +1957,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 9cdd21810..7091cb0b5 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) @@ -704,7 +709,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 @@ -1408,52 +1413,100 @@ participantInvitationConfig = InvitationConfig{..} getKeyBy404 $ TermSchoolCourseShort tid csh ssh invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgParticipantInviteExplanation}|] + 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 = wFormToAForm $ do + invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do now <- liftIO getCurrentTime studyFeatures <- wreq (studyFeaturesPrimaryFieldFor [ ] (Just uid)) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing return $ JunctionParticipant <$> pure now <*> studyFeatures -  invitationSuccessMsg Course{..} _ = - return . SomeMessage $ MsgParticipantInvitationAccepted courseTerm courseSchool courseShorthand + 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 <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - ((usersToEnlist,formWgt),formEcnoding) <- runFormPost . renderWForm FormStandard $ do - enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) - areq (multiUserField (fromMaybe False $ formResultToMaybe enlist) Nothing) + 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 - formResult usersToEnlist processUsers + + 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 :: Set (Either UserEmail UserId) -> Handler () - processUsers users = do - error "TODO" - {-} - let (emails,uids) = partionEithers $ Set.toList users - runDB $ do + 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 - (alreadyRegistered,registeredNoField,registeredOneField) <- execWriterT $ mapM registerUser uids - let statusMsg = modal _linkText (Right _widgetmessage) - statusTy = Info -- Success -- TODO - addMessageWidget statusTy statusMsg - redirect $ CourseR tid ssh csh CUsersR + execWriterT $ mapM (registerUser cid) uids - registerUser :: UserId -> WriterT ([UserEmail],[UserEmail],[UserEmail]) (YesodDB UniWorX) () - registerUser uid = do + when (not $ null emails) $ + tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails - tell ([],[],[]) - -} + 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 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)} +