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