374 lines
17 KiB
Haskell
374 lines
17 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
|
|
module Handler.Utils.Invitations
|
|
( -- * Procedure
|
|
--
|
|
-- $procedure
|
|
IsInvitableJunction(..)
|
|
, Invitation'
|
|
, _invitationDBData, _invitationTokenData
|
|
, InvitationReference(..), invRef
|
|
, InvitationConfig(..), InvitationTokenConfig(..)
|
|
, sourceInvitations, sourceInvitationsList
|
|
, sinkInvitations, sinkInvitationsF
|
|
, invitationR', InvitationR(..)
|
|
) where
|
|
|
|
import Import
|
|
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.Proxy (Proxy(..))
|
|
import Data.Typeable
|
|
|
|
|
|
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
|
|
--
|
|
-- 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
|
|
|
|
|
|
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 -> 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. Entity (InvitationFor junction) -> InvitationData junction -> junction -> formCtx -> (DB a -> DB 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 :: 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 (Invitation' 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 .| sinkInvitations'
|
|
where
|
|
determineExists :: Conduit (Invitation' junction)
|
|
(YesodJobDB UniWorX)
|
|
(Invitation' junction)
|
|
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 -> fail $ "Could not decode invitationData: " <> str
|
|
|
|
sinkInvitations' :: Sink (Invitation' junction) (YesodJobDB UniWorX) ()
|
|
sinkInvitations' = do
|
|
C.mapM_ $ \(jInvitee, fid, dat) -> do
|
|
app <- getYesod
|
|
let mr = renderMessage app $ NonEmpty.toList appLanguages
|
|
ur <- getUrlRenderParams
|
|
|
|
fEnt <- Entity fid <$> get404 fid
|
|
|
|
jInviter <- liftHandlerT requireAuthId
|
|
route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat
|
|
InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fEnt 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)])
|
|
jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat
|
|
let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur
|
|
|
|
when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation jInvitee (invRef @junction fid) (toJSON $ dat ^. _invitationDBData)
|
|
|
|
queueDBJob JobInvitation{..}
|
|
|
|
sinkInvitationsF :: forall junction mono.
|
|
( IsInvitableJunction junction
|
|
, MonoFoldable mono
|
|
, Element mono ~ Invitation' junction
|
|
)
|
|
=> InvitationConfig junction
|
|
-> mono
|
|
-> YesodJobDB UniWorX ()
|
|
-- | Non-conduit version of `sinkInvitations`
|
|
sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg
|
|
|
|
|
|
|
|
sourceInvitations :: forall junction.
|
|
IsInvitableJunction junction
|
|
=> Key (InvitationFor junction)
|
|
-> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction)
|
|
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
|
|
where
|
|
decode (Entity _ (Invitation email _ invitationData))
|
|
= case fromJSON invitationData of
|
|
JSON.Success dbData -> return (email, dbData)
|
|
JSON.Error str -> fail $ "Could not decode invitationData: " <> str
|
|
|
|
sourceInvitationsList :: forall junction.
|
|
IsInvitableJunction junction
|
|
=> Key (InvitationFor junction)
|
|
-> YesodDB UniWorX [(UserEmail, InvitationDBData junction)]
|
|
sourceInvitationsList forKey = runConduit $ sourceInvitations forKey .| C.foldMap pure
|
|
|
|
|
|
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 requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
|
|
invitee <- requireAuthId
|
|
Just cRoute <- getCurrentRoute
|
|
|
|
(tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
|
|
fEnt@(Entity fid _) <- 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 -> fail $ "Could not decode invitationData: " <> str
|
|
Just (cloneIso -> _DBData) -> return $ view _DBData ()
|
|
let
|
|
iData :: InvitationData junction
|
|
iData = review _InvitationData (dbData, itData)
|
|
guardAuthResult =<< invitationRestriction fEnt iData
|
|
((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . 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 <- invitationHeading fEnt iData
|
|
let explanation = invitationExplanation fEnt iData (toHtml . mr) ur
|
|
|
|
fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
|
|
Nothing -> do
|
|
addMessageI Info MsgInvitationDeclined
|
|
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
|
|
return . Just $ SomeRoute HomeR
|
|
Just (jData, formCtx) -> do
|
|
let junction = review _InvitableJunction (invitee, fid, jData)
|
|
mResult <- invitationInsertHook fEnt iData junction formCtx $ insertUniqueEntity junction
|
|
case mResult of
|
|
Nothing -> invalidArgsI [MsgInvitationCollision]
|
|
Just res -> do
|
|
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
|
|
addMessageI Success =<< invitationSuccessMsg fEnt res
|
|
Just <$> 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.
|