Prototype of generic invitation infrastructure

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.
+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

models/invitations

@@ -0,0 +1,5 @@
+Invitation
+  email     UserEmail
+  for       Value
+  data      Value
+  UniqueInvitation email for

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)

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.

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

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 ()
 
 

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

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"

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 }

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
 

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 --
 ------------

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@, ... --
 ---------------------------------------------

templates/widgets/invitation-site.hamlet

@@ -0,0 +1,4 @@
+<section>
+  #{explanation}
+<section>
+  ^{formWidget}