fradrive/src/Handler/Utils/Invitations.hs
2020-07-17 15:54:42 +02:00

455 lines
22 KiB
Haskell

{-# 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.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 :: *
-- | `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
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, 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 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 (Just . 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 <-. nub 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, 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{..} = 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.