diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c29f933d6..8a6a194bc 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -792,4 +792,12 @@ CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu 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} -SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein. \ No newline at end of file +SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein. + +InvitationAction: Aktion +InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden +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 diff --git a/models/invitations b/models/invitations new file mode 100644 index 000000000..c1d15148c --- /dev/null +++ b/models/invitations @@ -0,0 +1,5 @@ +Invitation + email UserEmail + for Value + data Value + UniqueInvitation email for \ No newline at end of file diff --git a/package.yaml b/package.yaml index 47917503c..16178c5ae 100644 --- a/package.yaml +++ b/package.yaml @@ -172,12 +172,14 @@ default-extensions: - PackageImports - TypeApplications - RecursiveDo + - TypeFamilyDependencies ghc-options: - -Wall - -fno-warn-type-defaults - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures + - -fno-max-relevant-binds when: - condition: flag(pedantic) diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs new file mode 100644 index 000000000..480282060 --- /dev/null +++ b/src/Handler/Utils/Invitations.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Handler.Utils.Invitations + ( -- * Procedure + -- + -- $procedure + IsInvitableJunction(..) + , _invitationDBData, _invitationTokenData + , InvitationConfig(..), InvitationTokenConfig(..) + , sinkInvitations, sinkInvitationsF + , invitationR + ) where + +import Import +import Utils.Lens +import Utils.Form +import Jobs.Queue + +import Handler.Utils.Tokens + +import Text.Hamlet + +import Control.Monad.Trans.Reader (mapReaderT) + +import qualified Data.Conduit.List as C +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.HashSet as HashSet + +import Data.Aeson (fromJSON) +import qualified Data.Aeson as JSON +import Data.Aeson.TH + + +class ( PersistRecordBackend junction (YesodPersistBackend UniWorX) + , ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction) + , FromJSON (InvitationDBData junction), FromJSON (InvitationTokenData junction) + , PersistRecordBackend (InvitationFor junction) (YesodPersistBackend UniWorX) + ) => IsInvitableJunction junction where + -- | One side of the junction is always `User`; `InvitationFor junction` is the other + 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` + type InvitationData junction = (dat :: *) | dat -> junction + type InvitationData junction = (InvitationDBData junction, InvitationTokenData junction) + -- | `InvitationDBData` is the part of `InvitationData` that is stored confidentially in the database + data InvitationDBData junction :: * + -- | `InvitationTokenData` is the part of `InvitationData` that is stored readably within the token + data InvitationTokenData junction :: * + + _InvitableJunction :: Iso' junction (UserId, Key (InvitationFor junction), InvitableJunction junction) + + _InvitationData :: Iso' (InvitationData junction) (InvitationDBData junction, InvitationTokenData junction) + default _InvitationData :: InvitationData junction ~ (InvitationDBData junction, InvitationTokenData junction) + => Iso' (InvitationData junction) (InvitationDBData junction, InvitationTokenData junction) + _InvitationData = id + + -- | If `ephemeralInvitation` is not `Nothing` pending invitations are not stored in the database + -- + -- In this case no invitation data can be stored in the database (@InvitationDBData junction ~ ()@) + ephemeralInvitation :: Maybe (AnIso' () (InvitationDBData junction)) + ephemeralInvitation = Nothing + + {-# MINIMAL _InvitableJunction #-} + +_invitationDBData :: IsInvitableJunction junction => Lens' (InvitationData junction) (InvitationDBData junction) +_invitationDBData = _InvitationData . _1 +_invitationTokenData :: IsInvitableJunction junction => Lens' (InvitationData junction) (InvitationTokenData junction) +_invitationTokenData = _InvitationData . _2 + + +-- | Configuration needed for creating and accepting/declining `Invitation`s +-- +-- It is advisable to define this once per `junction` in a global constant +data InvitationConfig junction = InvitationConfig + { invitationRoute :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (Route UniWorX) + -- ^ Which route calls `invitationR` for this kind of invitation? + , invitationResolveFor :: YesodDB UniWorX (Key (InvitationFor junction)) + -- ^ Monadically resolve `InvitationFor` during `inviteR` + -- + -- Usually from `requireBearerToken` or `getCurrentRoute` + , invitationSubject :: InvitationFor junction -> InvitationData junction -> SomeMessage UniWorX + -- ^ Subject of the e-mail which sends the token to the user + , invitationHeading :: InvitationFor junction -> InvitationData junction -> SomeMessage UniWorX + -- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR` + , invitationExplanation :: InvitationFor junction -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) + -- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`) + , invitationTokenConfig :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX InvitationTokenConfig + -- ^ 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) + -- ^ 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 + , invitationUltDest :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeRoute UniWorX) + -- ^ Where to redirect the redeeming user after accepting the invitation + } deriving (Generic, Typeable) + +-- | Additional configuration needed for an invocation of `bearerToken` +data InvitationTokenConfig = InvitationTokenConfig + { itAuthority :: UserId + , itAddAuth :: Maybe AuthDNF + , itExpiresAt :: Maybe (Maybe UTCTime) + , itStartsAt :: Maybe UTCTime + } deriving (Generic, Typeable) + +data InvitationTokenRestriction junction = IsInvitableJunction junction => InvitationTokenRestriction + { itEmail :: UserEmail + , itData :: InvitationTokenData junction + } +deriving instance Eq (InvitationTokenData junction) => Eq (InvitationTokenRestriction junction) +deriving instance Ord (InvitationTokenData junction) => Ord (InvitationTokenRestriction junction) +deriving instance (Read (InvitationTokenData junction), IsInvitableJunction junction) => Read (InvitationTokenRestriction junction) +deriving instance Show (InvitationTokenData junction) => Show (InvitationTokenRestriction junction) + +$(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) + + +sinkInvitations :: forall junction. + IsInvitableJunction junction + => InvitationConfig junction + -> Sink (UserEmail, Key (InvitationFor junction), InvitationData junction) (YesodJobDB UniWorX) () +-- | Register invitations in the database +-- +-- When an invitation for a certain junction (i.e. an `UserEmail`, `Key +-- (InvitationFor junction)`-Pair) already exists it's `InvitationData` is +-- updated, instead. +-- +-- For new junctions an invitation is sent by e-mail. +sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lift . sinkInvitations' + where + determineExists :: Conduit (UserEmail, Key (InvitationFor junction), InvitationData junction) + (YesodJobDB UniWorX) + (Either (InvitationId, InvitationData junction) (UserEmail, Key (InvitationFor junction), InvitationData junction)) + determineExists + | is _Just (ephemeralInvitation @junction) + = C.map Right + | otherwise + = C.mapM $ \inp@(email, fid, dat) -> + maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (toJSON 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 + forM_ existing $ \(iid, dat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ] + forM_ new $ \(jInvitee, fid, dat) -> do + app <- getYesod + let mr = renderMessage app $ NonEmpty.toList appLanguages + ur <- getUrlRenderParams + + fRec <- get404 fid + + jInviter <- liftHandlerT requireAuthId + route <- mapReaderT liftHandlerT $ invitationRoute fRec dat + InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat + protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt + let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData) + jwt <- encodeToken token + jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)]) + let jInvitationSubject = mr $ invitationSubject fRec dat + jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur + + queueDBJob JobInvitation{..} + +sinkInvitationsF :: forall junction mono. + ( IsInvitableJunction junction + , MonoFoldable mono + , Element mono ~ (UserEmail, Key (InvitationFor junction), InvitationData junction) + ) + => InvitationConfig junction + -> mono + -> YesodJobDB UniWorX () +-- | Non-conduit version of `sinkInvitations` +sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg + + +data ButtonInvite = BtnInviteAccept | BtnInviteDecline + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ButtonInvite +instance Finite ButtonInvite + +nullaryPathPiece ''ButtonInvite $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''ButtonInvite id + +instance Button UniWorX ButtonInvite where + btnClasses BtnInviteAccept = [BCIsButton, BCPrimary] + btnClasses BtnInviteDecline = [BCIsButton, BCDanger] + + btnValidate _ BtnInviteAccept = True + btnValidate _ BtnInviteDecline = False + +invitationR :: forall junction m. + ( IsInvitableJunction junction + , MonadHandler m + , HandlerSite m ~ UniWorX + ) + => InvitationConfig junction + -> m Html +-- | Generic handler for incoming invitations +invitationR InvitationConfig{..} = liftHandlerT $ do + InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return currentTokenRestrictions :: Handler (InvitationTokenRestriction junction) + invitee <- requireAuthId + Just cRoute <- getCurrentRoute + + (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do + Entity fid fRec <- invitationResolveFor >>= (\k -> Entity k <$> get404 k) + dbData <- case ephemeralInvitation @junction of + Nothing -> do + Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ toJSON fid) + case fromJSON invitationData of + JSON.Success dbData -> return dbData + JSON.Error str -> fail $ "Could not decode invitationData: " <> str + Just (cloneIso -> _DBData) -> return $ view _DBData () + let + iData :: InvitationData junction + iData = review _InvitationData (dbData, itData) + guardAuthResult =<< invitationRestriction fRec iData + ((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do + dataRes <- aFormToWForm $ invitationForm fRec iData + 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 + _other -> return $ Just <$> dataRes + + MsgRenderer mr <- getMsgRenderer + ur <- getUrlRenderParams + let + heading = invitationHeading fRec iData + explanation = invitationExplanation fRec iData (toHtml . mr) ur + + fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case + Nothing -> do + addMessageI Info MsgInvitationDeclined + deleteBy . UniqueInvitation itEmail $ toJSON fid + return . Just $ SomeRoute HomeR + Just jData -> do + mResult <- insertUniqueEntity $ review _InvitableJunction (invitee, fid, jData) + case mResult of + Nothing -> invalidArgsI [MsgInvitationCollision] + Just res -> do + addMessageI Success =<< invitationSuccessMsg fRec res + Just <$> invitationUltDest fRec res + + whenIsJust tRoute redirect + + let formWidget = wrapForm dataWidget def + { formMethod = POST + , formAction = Just $ SomeRoute cRoute + , formEncoding = dataEnctype + , formSubmit = FormNoSubmit + } + + siteLayoutMsg heading $(widgetFile "widgets/invitation-site") + + +-- $procedure +-- +-- `Invitation`s encode a pending entry of some junction table between some +-- record and `User` e.g. +-- +-- > data SheetCorrector = SheetCorrector +-- > { sheetCorrectorUser :: UserId +-- > , sheetCorrectorSheet :: SheetId +-- > , sheetCorrectorLoad :: Load +-- > } +-- +-- We split the record, encoding a line in the junction table, into a `(UserId, +-- InvitationData)`-Pair, storing only part of the `InvitationData` in a +-- separate table (what we don't store in that table gets encoded into a +-- `BearerToken`). +-- +-- After a User, authorized by said token, supplies their `UserId` the record is +-- completed and `insert`ed into the database. +-- +-- We also make provisions for storing one side of the junction's `Key`s +-- (`InvitationFor`) separately from the rest of the `InvitationData` to make +-- querying for pending invitations easier. diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs index e95b16a69..8ca5ad400 100644 --- a/src/Handler/Utils/Tokens.hs +++ b/src/Handler/Utils/Tokens.hs @@ -1,5 +1,6 @@ module Handler.Utils.Tokens ( maybeBearerToken, requireBearerToken + , currentTokenRestrictions ) where import Import @@ -25,3 +26,9 @@ requireBearerToken = liftHandlerT $ do isWrite <- isWriteRequest currentRoute guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token return token + +currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, FromJSON a, ToJSON a) => m (Maybe a) +currentTokenRestrictions = runMaybeT $ do + token <- MaybeT maybeBearerToken + route <- MaybeT getCurrentRoute + hoistMaybe $ preview (_tokenRestrictionIx route) token diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 51de48a1e..f43f2d864 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -84,6 +84,7 @@ import Control.Monad.Random.Class as Import (MonadRandom(..)) import Text.Blaze.Instances as Import () import Jose.Jwt.Instances as Import () +import Jose.Jwt as Import (Jwt) import Web.PathPieces.Instances as Import () diff --git a/src/Jobs.hs b/src/Jobs.hs index c935c79af..b44642d15 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -62,6 +62,7 @@ import Jobs.Handler.DistributeCorrections import Jobs.Handler.SendCourseCommunication import Jobs.Handler.LecturerInvitation import Jobs.Handler.CorrectorInvitation +import Jobs.Handler.Invitation data JobQueueException = JInvalid QueuedJobId QueuedJob diff --git a/src/Jobs/Handler/Invitation.hs b/src/Jobs/Handler/Invitation.hs new file mode 100644 index 000000000..f9c93828f --- /dev/null +++ b/src/Jobs/Handler/Invitation.hs @@ -0,0 +1,14 @@ +module Jobs.Handler.Invitation + ( dispatchJobInvitation + ) where + +import Import + + +dispatchJobInvitation :: UserId + -> UserEmail + -> Text + -> Text + -> Html + -> Handler () +dispatchJobInvitation = error "dispatchJobInvitation" diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index fc399d6a5..4dcf0de35 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -37,6 +37,12 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica | JobCorrectorInvitation { jInviter :: UserId , jCorrectorInvitation :: SheetCorrectorInvitation } + | JobInvitation { jInviter :: UserId + , jInvitee :: UserEmail + , jInvitationUrl :: Text + , jInvitationSubject :: Text + , jInvitationExplanation :: Html + } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } diff --git a/src/Jose/Jwt/Instances.hs b/src/Jose/Jwt/Instances.hs index 4bf4e3827..0c0c093ef 100644 --- a/src/Jose/Jwt/Instances.hs +++ b/src/Jose/Jwt/Instances.hs @@ -9,10 +9,18 @@ import ClassyPrelude.Yesod import Jose.Jwt +deriving instance Ord Jwt +deriving instance Read Jwt +deriving instance Generic Jwt +deriving instance Typeable Jwt + instance PathPiece Jwt where toPathPiece (Jwt bytes) = decodeUtf8 bytes fromPathPiece = Just . Jwt . encodeUtf8 +instance Hashable Jwt + + deriving instance Generic JwtError deriving instance Typeable JwtError diff --git a/src/Utils.hs b/src/Utils.hs index 40fa580ee..a5939a40b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -462,6 +462,12 @@ formResultToMaybe :: Alternative m => FormResult a -> m a formResultToMaybe (FormSuccess x) = pure x formResultToMaybe _ = empty +maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a +maybeThrow exc = maybe (throwM exc) return + +maybeThrowM :: (MonadThrow m, Exception e) => m e -> Maybe a -> m a +maybeThrowM excM = maybe (throwM =<< excM) return + ------------ -- Either -- ------------ diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 25180df04..ec9fc2d86 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -23,6 +23,7 @@ import qualified Data.Set as Set import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.RWS (mapRWST) import Data.List ((!!)) @@ -614,6 +615,18 @@ prismAForm p outer form = review p <$> form inner where inner = outer >>= preview p +----------------------- +-- Form Manipulation -- +----------------------- + +aFormToWForm :: MonadHandler m => AForm m a -> WForm m (FormResult a) +aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm + where + mFormToWForm' f = do + ((a, vs), ints, enctype) <- lift f + writer ((a, ints, enctype), vs) + + --------------------------------------------- -- Special variants of @mopt@, @mreq@, ... -- --------------------------------------------- diff --git a/templates/widgets/invitation-site.hamlet b/templates/widgets/invitation-site.hamlet new file mode 100644 index 000000000..064e92184 --- /dev/null +++ b/templates/widgets/invitation-site.hamlet @@ -0,0 +1,4 @@ +
+ #{explanation} +
+ ^{formWidget}