{-# 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.Lens
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)
      , 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 = InvitationConfig
  { invitationRoute       :: Entity (InvitationFor junction) -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
    -- ^ Which route calls `invitationR` for this kind of invitation?
  , invitationResolveFor  :: YesodDB UniWorX (Key (InvitationFor junction))
    -- ^ Monadically resolve `InvitationFor` during `inviteR`
    --
    -- Usually from `requireBearerToken` or `getCurrentRoute`
  , invitationSubject     :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
    -- ^ Subject of the e-mail which sends the token to the user
  , invitationHeading     :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
    -- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR`
  , invitationExplanation :: 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 :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX InvitationTokenConfig
    -- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
  , invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult
    -- ^ Additional restrictions to check before allowing an user to redeem an invitation token
  , invitationForm        :: InvitationFor junction -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction)
    -- ^ Assimilate the additional data entered by the redeeming user
  , invitationSuccessMsg  :: InvitationFor junction -> Entity junction         -> YesodDB UniWorX (SomeMessage UniWorX)
    -- ^ What to tell the redeeming user after accepting the invitation
  , invitationUltDest     :: InvitationFor junction -> Entity junction         -> YesodDB UniWorX (SomeRoute UniWorX)
    -- ^ Where to redirect the redeeming user after accepting the invitation
  } deriving (Generic, Typeable)

-- | 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 .| C.foldMap pure >>= lift . sinkInvitations'
  where
    determineExists :: Conduit (Invitation' junction)
                               (YesodJobDB UniWorX)
                               (Either (InvitationId, InvitationData junction) (Invitation' junction))
    determineExists
      | is _Just (ephemeralInvitation @junction)
      = C.map Right
      | otherwise
      = C.mapM $ \inp@(email, fid, dat) ->
          maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid))

    sinkInvitations' :: [Either (InvitationId, InvitationData junction) (Invitation' junction)]
                     -> YesodJobDB UniWorX ()
    sinkInvitations' (partitionEithers -> (existing, new)) = do
      when (is _Nothing (ephemeralInvitation @junction)) $ do
        insertMany_ $ map (\(email, fid, dat) -> Invitation email (invRef @junction fid) (toJSON $ dat ^. _invitationDBData)) new
        forM_ existing $ \(iid, dat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ]
      forM_ new $ \(jInvitee, fid, dat) -> do
        app <- getYesod
        let mr = renderMessage app $ NonEmpty.toList appLanguages
        ur <- getUrlRenderParams

        fRec <- get404 fid

        jInviter <- liftHandlerT requireAuthId
        route <- mapReaderT liftHandlerT $ invitationRoute (Entity fid fRec) dat
        InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec 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 fRec dat
        let jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur

        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 currentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
  invitee <- requireAuthId
  Just cRoute <- getCurrentRoute

  (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
    Entity fid fRec <- invitationResolveFor >>= (\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 fRec iData
    ((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
      dataRes <- aFormToWForm $ invitationForm fRec 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 fRec iData
    let explanation = invitationExplanation fRec 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 -> do
        mResult <- insertUniqueEntity $ review _InvitableJunction (invitee, fid, jData)
        case mResult of
          Nothing -> invalidArgsI [MsgInvitationCollision]
          Just res -> do
            deleteBy . UniqueInvitation itEmail $ invRef @junction fid
            addMessageI Success =<< invitationSuccessMsg fRec res
            Just <$> invitationUltDest fRec 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.