From 5bc0254f7f757dd73dba51e81586aa20aa4da69c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 23 Apr 2019 01:22:36 +0200 Subject: [PATCH] Implement lecturer invitations with new system --- messages/uniworx/de.msg | 4 +- routes | 2 +- src/Handler/Course.hs | 142 +++++++++++++------------ src/Handler/Utils/Invitations.hs | 72 ++++++++++--- src/Jobs.hs | 1 - src/Jobs/Handler/LecturerInvitation.hs | 41 ------- src/Jobs/Types.hs | 3 - templates/courseLecInvite.hamlet | 3 - 8 files changed, 139 insertions(+), 129 deletions(-) delete mode 100644 src/Jobs/Handler/LecturerInvitation.hs delete mode 100644 templates/courseLecInvite.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8a6a194bc..509bb2120 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -800,4 +800,6 @@ InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten InvitationCollision: Einladung konnte nicht angenommen werden da ein derartiger Eintrag bereits existiert InvitationDeclined: Einladung wurde abgelehnt BtnInviteAccept: Einladung annehmen -BtnInviteDecline: Einladung ablehnen \ No newline at end of file +BtnInviteDecline: Einladung ablehnen + +LecturerType: Rolle \ No newline at end of file diff --git a/routes b/routes index 0e801e22b..c9af2ca13 100644 --- a/routes +++ b/routes @@ -76,7 +76,7 @@ / CShowR GET !free /register CRegisterR POST !timeANDcapacity /edit CEditR GET POST - /lecturer-invite/#UserEmail CLecInviteR GET POST + /lecturer-invite CLecInviteR GET POST /delete CDeleteR GET POST !lecturerANDempty /users CUsersR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5697b7bd4..3cc623819 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -15,6 +15,7 @@ import Handler.Utils.Delete import Handler.Utils.Database import Handler.Utils.Table.Cells import Handler.Utils.Table.Columns +import Handler.Utils.Invitations import Database.Persist.Sql (deleteWhereCount) import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -37,6 +38,11 @@ import Text.Blaze.Html.Renderer.Text (renderHtml) import Jobs.Queue +import Data.Aeson hiding (Result(..)) + +import Text.Hamlet (ihamlet) + + -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) @@ -500,12 +506,10 @@ courseEditHandler miButtonAction mbCourseForm = do , courseDeregisterUntil = cfDeRegUntil res } whenIsJust insertOkay $ \cid -> do - forM_ (cfLecturers res) $ \case - Right (lid, lty) -> insert_ $ Lecturer lid cid lty - Left (lEmail, mLTy) -> do - insert_ $ LecturerInvitation lEmail cid mLTy - queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy - insert_ $ CourseEdit aid now cid + let (invites, adds) = partitionEithers $ cfLecturers res + insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds + sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites + insert_ $ CourseEdit aid now cid return insertOkay case insertOkay of Just _ -> do @@ -545,16 +549,11 @@ courseEditHandler miButtonAction mbCourseForm = do (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False Nothing -> do deleteWhere [LecturerCourse ==. cid] - deleteWhere [LecturerInvitationCourse ==. cid, LecturerInvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)] - forM_ (cfLecturers res) $ \case - Right (lid, lty) -> insert_ $ Lecturer lid cid lty - Left (lEmail, mLTy) -> do - insertRes <- insertUnique (LecturerInvitation lEmail cid mLTy) - case insertRes of - Just _ -> - queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy - Nothing -> - updateBy (UniqueLecturerInvitation lEmail cid) [ LecturerInvitationType =. mLTy ] + deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)] + let (invites, adds) = partitionEithers $ cfLecturers res + insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds + sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites + insert_ $ CourseEdit aid now cid addMessageI Success $ MsgCourseEditOk tid ssh csh return True @@ -568,6 +567,65 @@ courseEditHandler miButtonAction mbCourseForm = do } +instance IsInvitableJunction Lecturer where + type InvitationFor Lecturer = Course + data InvitableJunction Lecturer = JunctionLecturer + { jLecturerType :: LecturerType + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData Lecturer = InvDBDataLecturer + { invDBLecturerType :: Maybe LecturerType + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData Lecturer = InvTokenDataLecturer + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType)) + (\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..}) + +instance ToJSON (InvitableJunction Lecturer) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction Lecturer) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData Lecturer) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } +instance FromJSON (InvitationDBData Lecturer) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } + +instance ToJSON (InvitationTokenData Lecturer) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } +instance FromJSON (InvitationTokenData Lecturer) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + +lecturerInvitationConfig :: InvitationConfig Lecturer +lecturerInvitationConfig = InvitationConfig{..} + where + invitationRoute Course{..} _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR + invitationResolveFor = do + Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute + getKeyBy404 $ TermSchoolCourseShort tid csh ssh + invitationSubject Course{..} _ = SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand + invitationHeading Course{..} _ = SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] + invitationTokenConfig _ _ = do + itAuthority <- liftHandlerT requireAuthId + return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing + invitationRestriction _ _ = return Authorized + invitationForm _ (InvDBDataLecturer mlType, _) = hoistAForm liftHandlerT $ toJunction <$> case mlType of + Nothing -> areq (selectField optionsFinite) lFs Nothing + Just lType -> aforced (selectField optionsFinite) lFs lType + where + toJunction jLecturerType = JunctionLecturer{..} + lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical + invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do + MsgRenderer mr <- getMsgRenderer + return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand + invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR + + data CourseForm = CourseForm { cfCourseId :: Maybe CourseId , cfName :: CourseName @@ -1131,54 +1189,6 @@ postCCommR tid ssh csh = do } -data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe ButtonLecInvite -instance Finite ButtonLecInvite - -nullaryPathPiece ''ButtonLecInvite $ camelToPathPiece' 3 -embedRenderMessage ''UniWorX ''ButtonLecInvite id - -instance Button UniWorX ButtonLecInvite where - btnClasses BtnLecInvAccept = [BCIsButton, BCPrimary] - btnClasses BtnLecInvDecline = [BCIsButton, BCDanger] - -getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> UserEmail -> Handler Html +getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCLecInviteR = postCLecInviteR -postCLecInviteR tid ssh csh email = do - uid <- requireAuthId - (Entity cid Course{..}, Entity liId LecturerInvitation{..}) <- runDB $ do - cRes@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh - iRes <- getBy404 $ UniqueLecturerInvitation email cid - return (cRes, iRes) - - ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost . formEmbedJwtPost $ \csrf -> do - (ltRes, ltView) <- case lecturerInvitationType of - Nothing -> mreq (selectField optionsFinite) "" Nothing - Just lType -> mforced (selectField optionsFinite) "" lType - (btnRes, btnWdgt) <- buttonForm mempty - return ((,) <$> ltRes <*> btnRes, toWidget csrf <> fvInput ltView <> btnWdgt) - - let btnWidget = wrapForm btnInnerWidget def - { formEncoding = btnEncoding - , formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email - , formSubmit = FormNoSubmit - } - - formResult btnResult $ \case - (lType, BtnLecInvAccept) -> do - runDB $ do - delete liId - insert_ $ Lecturer uid cid lType - MsgRenderer mr <- getMsgRenderer - addMessageI Success $ MsgLecturerInvitationAccepted (mr lType) csh - redirect $ CourseR tid ssh csh CShowR - (_, BtnLecInvDecline) -> do - runDB $ - delete liId - addMessageI Info $ MsgLecturerInvitationDeclined csh - redirect HomeR - - siteLayoutMsg (MsgCourseLecInviteHeading $ CI.original courseName) $ do - setTitleI . MsgCourseLecInviteHeading $ CI.original courseName - $(widgetFile "courseLecInvite") +postCLecInviteR = invitationR lecturerInvitationConfig diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 480282060..257881ea1 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Handler.Utils.Invitations ( -- * Procedure @@ -6,9 +7,10 @@ module Handler.Utils.Invitations -- $procedure IsInvitableJunction(..) , _invitationDBData, _invitationTokenData + , InvitationReference(..), invRef , InvitationConfig(..), InvitationTokenConfig(..) , sinkInvitations, sinkInvitationsF - , invitationR + , invitationR', InvitationR(..) ) where import Import @@ -30,11 +32,15 @@ import Data.Aeson (fromJSON) import qualified Data.Aeson as JSON import Data.Aeson.TH +import Data.Proxy (Proxy(..)) +import Data.Typeable + class ( PersistRecordBackend junction (YesodPersistBackend UniWorX) , ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction) , FromJSON (InvitationDBData junction), FromJSON (InvitationTokenData junction) , PersistRecordBackend (InvitationFor junction) (YesodPersistBackend UniWorX) + , Typeable junction ) => IsInvitableJunction junction where -- | One side of the junction is always `User`; `InvitationFor junction` is the other type InvitationFor junction :: * @@ -72,6 +78,32 @@ _invitationTokenData :: IsInvitableJunction junction => Lens' (InvitationData ju _invitationTokenData = _InvitationData . _2 +data InvitationReference junction = IsInvitableJunction junction => InvRef (Key (InvitationFor junction)) + +deriving instance Eq (InvitationReference junction) +deriving instance Ord (InvitationReference junction) +deriving instance IsInvitableJunction junction => Read (InvitationReference junction) +deriving instance Show (InvitationReference junction) + +instance ToJSON (InvitationReference junction) where + toJSON (InvRef fId) = JSON.object + [ "type" JSON..= show (typeRep (Proxy @junction)) + , "key" JSON..= fId + ] +instance IsInvitableJunction junction => FromJSON (InvitationReference junction) where + parseJSON = JSON.withObject "InvitationReference" $ \o -> do + table <- o JSON..: "type" + key <- o JSON..: "key" + + unless (table == show (typeRep (Proxy @junction))) $ + fail "Unexpected table" + + return $ InvRef key + +invRef :: forall junction. IsInvitableJunction junction => Key (InvitationFor junction) -> JSON.Value +invRef = toJSON . InvRef @junction + + -- | Configuration needed for creating and accepting/declining `Invitation`s -- -- It is advisable to define this once per `junction` in a global constant @@ -147,13 +179,13 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif = C.map Right | otherwise = C.mapM $ \inp@(email, fid, dat) -> - maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (toJSON fid)) + maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (toJSON $ InvRef @junction fid)) sinkInvitations' :: [Either (InvitationId, InvitationData junction) (UserEmail, Key (InvitationFor junction), InvitationData junction)] -> YesodJobDB UniWorX () sinkInvitations' (partitionEithers -> (existing, new)) = do when (is _Nothing (ephemeralInvitation @junction)) $ do - insertMany_ $ map (\(email, fid, dat) -> Invitation email (toJSON fid) (toJSON $ dat ^. _invitationDBData)) new + insertMany_ $ map (\(email, fid, dat) -> Invitation email (toJSON $ InvRef @junction fid) (toJSON $ dat ^. _invitationDBData)) new forM_ existing $ \(iid, dat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ] forM_ new $ \(jInvitee, fid, dat) -> do app <- getYesod @@ -201,15 +233,15 @@ instance Button UniWorX ButtonInvite where btnValidate _ BtnInviteAccept = True btnValidate _ BtnInviteDecline = False -invitationR :: forall junction m. - ( IsInvitableJunction junction - , MonadHandler m - , HandlerSite m ~ UniWorX - ) - => InvitationConfig junction - -> m Html +invitationR' :: forall junction m. + ( IsInvitableJunction junction + , MonadHandler m + , HandlerSite m ~ UniWorX + ) + => InvitationConfig junction + -> m Html -- | Generic handler for incoming invitations -invitationR InvitationConfig{..} = liftHandlerT $ do +invitationR' InvitationConfig{..} = liftHandlerT $ do InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return currentTokenRestrictions :: Handler (InvitationTokenRestriction junction) invitee <- requireAuthId Just cRoute <- getCurrentRoute @@ -218,7 +250,7 @@ invitationR InvitationConfig{..} = liftHandlerT $ do Entity fid fRec <- invitationResolveFor >>= (\k -> Entity k <$> get404 k) dbData <- case ephemeralInvitation @junction of Nothing -> do - Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ toJSON fid) + Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail . toJSON $ InvRef @junction fid) case fromJSON invitationData of JSON.Success dbData -> return dbData JSON.Error str -> fail $ "Could not decode invitationData: " <> str @@ -243,7 +275,7 @@ invitationR InvitationConfig{..} = liftHandlerT $ do fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case Nothing -> do addMessageI Info MsgInvitationDeclined - deleteBy . UniqueInvitation itEmail $ toJSON fid + deleteBy . UniqueInvitation itEmail . toJSON $ InvRef @junction fid return . Just $ SomeRoute HomeR Just jData -> do mResult <- insertUniqueEntity $ review _InvitableJunction (invitee, fid, jData) @@ -265,6 +297,20 @@ invitationR InvitationConfig{..} = liftHandlerT $ do siteLayoutMsg heading $(widgetFile "widgets/invitation-site") +class InvitationR a where + invitationR :: forall junction. + ( IsInvitableJunction junction + ) + => InvitationConfig junction + -> a + +instance InvitationR (Handler Html) where + invitationR = invitationR' + +instance InvitationR b => InvitationR (a -> b) where + invitationR cfg _ = invitationR cfg + + -- $procedure -- -- `Invitation`s encode a pending entry of some junction table between some diff --git a/src/Jobs.hs b/src/Jobs.hs index b44642d15..13696ec82 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -60,7 +60,6 @@ import Jobs.Handler.HelpRequest import Jobs.Handler.SetLogSettings import Jobs.Handler.DistributeCorrections import Jobs.Handler.SendCourseCommunication -import Jobs.Handler.LecturerInvitation import Jobs.Handler.CorrectorInvitation import Jobs.Handler.Invitation diff --git a/src/Jobs/Handler/LecturerInvitation.hs b/src/Jobs/Handler/LecturerInvitation.hs deleted file mode 100644 index e3fd03a6d..000000000 --- a/src/Jobs/Handler/LecturerInvitation.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Jobs.Handler.LecturerInvitation - ( dispatchJobLecturerInvitation - ) where - -import Import - -import Text.Hamlet - -import qualified Data.HashSet as HashSet - -import qualified Data.CaseInsensitive as CI - -import Utils.Lens - - -dispatchJobLecturerInvitation :: UserId -> LecturerInvitation -> Handler () -dispatchJobLecturerInvitation jInviter jLecturerInvitation@LecturerInvitation{..} = do - ctx <- runDB . runMaybeT $ do - course <- MaybeT $ get lecturerInvitationCourse - void . MaybeT $ getByValue jLecturerInvitation - user <- MaybeT $ get jInviter - return (course, user) - - case ctx of - Just (Course{..}, User{..}) -> do - let baseRoute = CourseR courseTerm courseSchool courseShorthand $ CLecInviteR lecturerInvitationEmail - jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing - let - invitationUrl :: SomeRoute UniWorX - invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)]) - invitationUrl' <- toTextUrl invitationUrl - - mailT def $ do - _mailTo .= [Address Nothing $ CI.original lecturerInvitationEmail] - replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail) - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - setSubjectI $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand - - addPart ($(ihamletFile "templates/mail/lecturerInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) - Nothing -> runDB . - deleteBy $ UniqueLecturerInvitation lecturerInvitationEmail lecturerInvitationCourse diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 4dcf0de35..c5a0aa763 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -31,9 +31,6 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica , jSubject :: Maybe Text , jMailContent :: Html } - | JobLecturerInvitation { jInviter :: UserId - , jLecturerInvitation :: LecturerInvitation - } | JobCorrectorInvitation { jInviter :: UserId , jCorrectorInvitation :: SheetCorrectorInvitation } diff --git a/templates/courseLecInvite.hamlet b/templates/courseLecInvite.hamlet deleted file mode 100644 index 408556fb7..000000000 --- a/templates/courseLecInvite.hamlet +++ /dev/null @@ -1,3 +0,0 @@ -

- _{MsgCourseLecInviteExplanation} -^{btnWidget}