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