460 lines
22 KiB
Haskell
460 lines
22 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Utils.Invitations
|
|
( -- * Procedure
|
|
--
|
|
-- $procedure
|
|
IsInvitableJunction(..)
|
|
, Invitation'
|
|
, _invitationDBData, _invitationTokenData
|
|
, InvitationReference(..), invRef
|
|
, InvitationConfig(..), InvitationTokenConfig(..)
|
|
, sourceInvitations, sourceInvitationsF
|
|
, deleteInvitations, deleteInvitationsF, deleteInvitation
|
|
, sinkInvitations, sinkInvitationsF, sinkInvitation
|
|
, invitationR', InvitationR(..)
|
|
) where
|
|
|
|
import Import
|
|
import Utils.Form
|
|
import Jobs.Queue
|
|
|
|
import Text.Hamlet
|
|
|
|
import qualified Data.Conduit.List as C
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
import qualified Data.HashSet as HashSet
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.Aeson (fromJSON)
|
|
import qualified Data.Aeson as JSON
|
|
|
|
import Data.Typeable
|
|
|
|
import Database.Persist.Sql (SqlBackendCanWrite)
|
|
|
|
|
|
class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
|
|
, ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction)
|
|
, FromJSON (InvitationDBData junction), FromJSON (InvitationTokenData junction)
|
|
, Eq (InvitationDBData 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 :: Type
|
|
-- | `junction` without `Key User` and `Key (InvitationFor junction)`
|
|
data InvitableJunction junction :: Type
|
|
|
|
-- | `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 :: Type) | 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 :: Type
|
|
-- | `InvitationTokenData` is the part of `InvitationData` that is stored readably within the token
|
|
data InvitationTokenData junction :: Type
|
|
|
|
_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
|
|
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
|
|
|
|
|
|
type Invitation' junction = (UserEmail, Key (InvitationFor junction), InvitationData junction)
|
|
|
|
|
|
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
|
|
[ "junction" JSON..= show (typeRep (Proxy @junction))
|
|
, "record" JSON..= fId
|
|
]
|
|
instance IsInvitableJunction junction => FromJSON (InvitationReference junction) where
|
|
parseJSON = JSON.withObject "InvitationReference" $ \o -> do
|
|
table <- o JSON..: "junction"
|
|
key <- o JSON..: "record"
|
|
|
|
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
|
|
data InvitationConfig junction = forall formCtx. InvitationConfig
|
|
{ invitationRoute :: Entity (InvitationFor junction) -> InvitationData junction -> DB (Route UniWorX)
|
|
-- ^ Which route calls `invitationR` for this kind of invitation?
|
|
, invitationResolveFor :: InvitationTokenData junction -> DB (Key (InvitationFor junction))
|
|
-- ^ Monadically resolve `InvitationFor` during `inviteR`
|
|
--
|
|
-- Usually from `getCurrentRoute`
|
|
, invitationSubject :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
|
|
-- ^ Subject of the e-mail which sends the token to the user
|
|
, invitationHeading :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
|
|
-- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR`
|
|
, invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> DB (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
|
|
-- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`)
|
|
, invitationTokenConfig :: Entity (InvitationFor junction) -> InvitationData junction -> DB InvitationTokenConfig
|
|
-- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
|
|
, invitationRestriction :: Entity (InvitationFor junction) -> InvitationData junction -> DB AuthResult
|
|
-- ^ Additional restrictions to check before allowing an user to redeem an invitation token
|
|
, invitationForm :: Entity (InvitationFor junction) -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction, formCtx)
|
|
-- ^ Assimilate the additional data entered by the redeeming user
|
|
, invitationInsertHook :: forall a. UserEmail -> Entity (InvitationFor junction) -> InvitationData junction -> junction -> formCtx -> (YesodJobDB UniWorX a -> YesodJobDB UniWorX a)
|
|
-- ^ Perform additional actions before or after insertion of the junction into the database
|
|
, invitationSuccessMsg :: Entity (InvitationFor junction) -> Entity junction -> DB (SomeMessage UniWorX)
|
|
-- ^ What to tell the redeeming user after accepting the invitation
|
|
, invitationUltDest :: Entity (InvitationFor junction) -> Entity junction -> DB (SomeRoute UniWorX)
|
|
-- ^ Where to redirect the redeeming user after accepting the invitation
|
|
}
|
|
|
|
-- | Additional configuration needed for an invocation of `bearerToken`
|
|
data InvitationTokenConfig = InvitationTokenConfig
|
|
{ itAuthority :: HashSet (Either Value UserId)
|
|
, itAddAuth :: Maybe AuthDNF
|
|
, itExpiresAt :: Maybe (Maybe UTCTime)
|
|
, itStartsAt :: Maybe UTCTime
|
|
} deriving (Generic)
|
|
|
|
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 m backend.
|
|
( IsInvitableJunction junction
|
|
, MonadHandler m
|
|
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
|
|
, HasPersistBackend backend
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> InvitationConfig junction
|
|
-> ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
|
|
-- | Register invitations in the database and send them by email
|
|
--
|
|
-- When an invitation for a certain junction (i.e. an `UserEmail`, `Key
|
|
-- (InvitationFor junction)`-Pair) already exists it is deleted and resent
|
|
-- (because the token-data may have changed)
|
|
sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
|
|
where
|
|
determineExists :: ConduitT (Invitation' junction)
|
|
(Invitation' junction)
|
|
(ReaderT backend (WriterT (Set QueuedJobId) m))
|
|
()
|
|
determineExists
|
|
| is _Just (ephemeralInvitation @junction)
|
|
= C.map id
|
|
| otherwise
|
|
= awaitForever $ \inp@(email, fid, view _InvitationData -> (dat, _)) -> do
|
|
dbEntry <- lift . getBy $ UniqueInvitation email (invRef @junction fid)
|
|
case dbEntry of
|
|
Just (Entity _ Invitation{invitationData})
|
|
| Just dbData <- decode invitationData
|
|
, dbData == dat
|
|
-> return ()
|
|
Just (Entity invId _)
|
|
-> lift (delete invId) >> yield inp
|
|
Nothing
|
|
-> yield inp
|
|
where
|
|
decode invData
|
|
= case fromJSON invData of
|
|
JSON.Success dbData -> return dbData
|
|
JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
|
|
|
|
sinkInvitations' :: ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
|
|
sinkInvitations' = transPipe (hoist (hoist liftHandler) . withReaderT persistBackend) $ do
|
|
C.mapM_ $ \(jInvitee, fid, dat) -> do
|
|
app <- getYesod
|
|
let mr = renderMessage app $ NonEmpty.toList appLanguages
|
|
ur <- getUrlRenderParams
|
|
|
|
fEnt <- Entity fid <$> get404 fid
|
|
|
|
jInviter <- liftHandler maybeAuthId
|
|
route <- mapReaderT liftHandler $ invitationRoute fEnt dat
|
|
InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat
|
|
protoToken <- bearerToken itAuthority Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
|
|
let token = protoToken & bearerRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
|
|
bearer <- encodeBearer token
|
|
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece bearer)])
|
|
jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat
|
|
jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat)
|
|
|
|
when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation
|
|
{ invitationEmail = jInvitee
|
|
, invitationFor = invRef @junction fid
|
|
, invitationData = toJSON $ dat ^. _invitationDBData
|
|
, invitationExpiresAt = bearerExpiresAt token
|
|
}
|
|
|
|
queueDBJob JobInvitation{..}
|
|
|
|
sinkInvitationsF :: forall junction mono m backend.
|
|
( IsInvitableJunction junction
|
|
, MonoFoldable mono
|
|
, Element mono ~ Invitation' junction
|
|
, MonadHandler m
|
|
, MonadThrow m
|
|
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
|
|
, HasPersistBackend backend
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> InvitationConfig junction
|
|
-> mono
|
|
-> ReaderT backend (WriterT (Set QueuedJobId) m) ()
|
|
-- | Non-conduit version of `sinkInvitations`
|
|
sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg
|
|
|
|
sinkInvitation :: forall junction m backend.
|
|
( IsInvitableJunction junction
|
|
, MonadHandler m
|
|
, MonadThrow m
|
|
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
|
|
, HasPersistBackend backend
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> InvitationConfig junction
|
|
-> Invitation' junction
|
|
-> ReaderT backend (WriterT (Set QueuedJobId) m) ()
|
|
-- | Singular version of `sinkInvitationsF`
|
|
sinkInvitation cfg = sinkInvitationsF cfg . Identity
|
|
|
|
|
|
sourceInvitations :: forall junction m backend.
|
|
( IsInvitableJunction junction
|
|
, MonadResource m
|
|
, MonadThrow m
|
|
, PersistRecordBackend Invitation backend
|
|
, HasPersistBackend backend
|
|
, PersistQueryRead backend
|
|
)
|
|
=> Key (InvitationFor junction)
|
|
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
|
|
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
|
|
where
|
|
decode (Entity _ Invitation{invitationEmail, invitationData})
|
|
= case fromJSON invitationData of
|
|
JSON.Success dbData -> return (invitationEmail, dbData)
|
|
JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str
|
|
|
|
sourceInvitationsF :: forall junction map m backend.
|
|
( IsInvitableJunction junction
|
|
, IsMap map
|
|
, ContainerKey map ~ UserEmail
|
|
, MapValue map ~ InvitationDBData junction
|
|
, MonadResource m
|
|
, MonadThrow m
|
|
, PersistRecordBackend Invitation backend
|
|
, HasPersistBackend backend
|
|
, PersistQueryRead backend
|
|
)
|
|
=> Key (InvitationFor junction)
|
|
-> ReaderT backend m map
|
|
sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap (uncurry singletonMap)
|
|
|
|
|
|
-- | Deletes all invitations for given emails and a given instance of the
|
|
-- non-user side of the junction
|
|
--
|
|
-- Requires type application to determine @junction@-type, i.e.:
|
|
--
|
|
-- > runConduit $ yield userEmail .| deleteInvitations @SubmissionUser submissionId
|
|
deleteInvitations :: forall junction m backend.
|
|
( IsInvitableJunction junction
|
|
, MonadIO m
|
|
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
|
|
)
|
|
=> Key (InvitationFor junction)
|
|
-> ConduitT UserEmail Void (ReaderT backend m) ()
|
|
deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k
|
|
|
|
deleteInvitationsF :: forall junction m mono backend.
|
|
( IsInvitableJunction junction
|
|
, MonadIO m
|
|
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
|
|
, MonoFoldable mono
|
|
, Element mono ~ UserEmail
|
|
)
|
|
=> Key (InvitationFor junction)
|
|
-> mono
|
|
-> ReaderT backend m ()
|
|
-- | Non-conduit version of `deleteInvitations`
|
|
deleteInvitationsF invitationFor (otoList -> emailList)
|
|
= deleteWhere [InvitationEmail <-. nubOrd emailList, InvitationFor ==. invRef @junction invitationFor]
|
|
|
|
deleteInvitation :: forall junction m backend.
|
|
( IsInvitableJunction junction
|
|
, MonadIO m
|
|
, PersistRecordBackend Invitation backend, SqlBackendCanWrite backend
|
|
)
|
|
=> Key (InvitationFor junction)
|
|
-> UserEmail
|
|
-> ReaderT backend m ()
|
|
-- | Singular version of `deleteInvitationsF`
|
|
deleteInvitation invitationFor = deleteInvitationsF @junction invitationFor . Identity
|
|
|
|
|
|
data ButtonInvite = BtnInviteAccept | BtnInviteDecline
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
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{..} = liftHandler $ do
|
|
InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentBearerRestrictions :: Handler (InvitationTokenRestriction junction)
|
|
invitee <- requireAuthId
|
|
cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute
|
|
|
|
(tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDBJobs $ do
|
|
fEnt@(Entity fid _) <- hoist lift (invitationResolveFor itData) >>= (\k -> Entity k <$> get404 k)
|
|
dbData <- case ephemeralInvitation @junction of
|
|
Nothing -> do
|
|
Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)
|
|
case fromJSON invitationData of
|
|
JSON.Success dbData -> return dbData
|
|
JSON.Error str -> throwM . PersistMarshalError $ "Could not decode invitationData: " <> pack str
|
|
Just (cloneIso -> _DBData) -> return $ view _DBData ()
|
|
let
|
|
iData :: InvitationData junction
|
|
iData = review _InvitationData (dbData, itData)
|
|
guardAuthResult =<< hoist lift (invitationRestriction fEnt iData)
|
|
((dataRes, dataWidget), dataEnctype) <- hoist lift . runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
|
|
dataRes <- aFormToWForm $ invitationForm fEnt 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
|
|
_other -> return $ Just <$> dataRes
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
ur <- getUrlRenderParams
|
|
heading <- hoist lift $ invitationHeading fEnt iData
|
|
explanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> hoist lift (invitationExplanation fEnt iData)
|
|
|
|
fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
|
|
Nothing -> do
|
|
addMessageI Info MsgInvitationDeclined
|
|
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
|
|
return . Just $ SomeRoute NewsR
|
|
Just (jData, formCtx) -> do
|
|
let junction = review _InvitableJunction (invitee, fid, jData)
|
|
mResult <- invitationInsertHook itEmail fEnt iData junction formCtx $ insertUniqueEntity junction
|
|
case mResult of
|
|
Nothing -> invalidArgsI [MsgInvitationCollision]
|
|
Just res -> do
|
|
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
|
|
addMessageI Success =<< hoist lift (invitationSuccessMsg fEnt res)
|
|
Just <$> hoist lift (invitationUltDest fEnt 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")
|
|
|
|
|
|
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
|
|
-- 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.
|