{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

-- | Logic of Explorer socket-io Server.

module Pos.Explorer.Socket.Methods
       ( Subscription (..)
       , ClientEvent (..)
       , ServerEvent (..)
       , SubscriptionParam (..)

       -- * Creating `SubscriptionParam`s
       , addrSubParam
       , blockPageSubParam
       , txsSubParam

       -- Sessions
       , startSession
       , finishSession

       -- Un-/Subscriptions
       , subscribeAddr
       , subscribeBlocksLastPage
       , subscribeEpochsLastPage
       , subscribeTxs
       , unsubscribeAddr
       , unsubscribeBlocksLastPage
       , unsubscribeEpochsLastPage
       , unsubscribeFully
       , unsubscribeTxs

       -- * Notifications
       , notifyAddrSubscribers
       , notifyBlocksLastPageSubscribers
       , notifyTxsSubscribers
       , notifyEpochsLastPageSubscribers

      -- * DB data
       , getBlundsFromTo
       , getBlockTxs
       , getTxInfo

       -- * Helper
       , addressSetByTxs
       , addrsTouchedByTx
       , fromCAddressOrThrow

       -- needed by tests
       , SubscriptionMode
       ) where

import           Universum hiding (id)

import           Control.Lens (at, ix, lens, non, (.=), _Just)
import           Control.Monad.State (MonadState)
import           Data.Aeson (ToJSON)
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
import           Formatting (sformat, shown, stext, (%))
import           Network.EngineIO (SocketId)
import           Network.SocketIO (Socket, socketId)
import           Pos.Chain.Block (Block, Blund, HeaderHash, mainBlockTxPayload)
import           Pos.Chain.Genesis (GenesisHash)
import           Pos.Chain.Txp (Tx (..), TxOut (..), TxOutAux (..),
                     txOutAddress, txpTxs)
import           Pos.Core (Address, SlotCount)
import           Pos.Core.Chrono (getOldestFirst)
import           Pos.Crypto (hash, withHash)
import           Pos.DB.Block (getBlund)
import qualified Pos.DB.Block as DB
import           Pos.DB.Class (MonadDBRead)
import           Pos.DB.Txp (getTxOut)
import           Pos.Explorer.Core (TxExtra (..))
import qualified Pos.Explorer.DB as DB
import           Pos.Util (maybeThrow)

import           Pos.Explorer.Aeson.ClientTypes ()
import           Pos.Explorer.ExplorerMode (ExplorerMode)
import           Pos.Explorer.Socket.Holder (ClientContext, ConnectionsState,
                     ExplorerSocket (..), ExplorerSockets, ccAddress,
                     ccConnection, csAddressSubscribers,
                     csBlocksPageSubscribers, csClients,
                     csEpochsLastPageSubscribers, csTxsSubscribers,
                     mkClientContext, _ProdSocket)
import           Pos.Explorer.Socket.Util (EventName (..), emitTo)
import           Pos.Explorer.Web.ClientTypes (CAddress, CTxBrief,
                     CTxEntry (..), EpochIndex (..), TxInternal (..),
                     fromCAddress, toTxBrief)
import           Pos.Explorer.Web.Error (ExplorerError (..))
import           Pos.Explorer.Web.Server (getBlocksLastPage, getEpochPage,
                     getEpochPagesOrThrow, topsortTxsOrFail)
import           Pos.Util.Wlog (WithLogger, logDebug, logWarning,
                     modifyLoggerName)


-- * Event names

data Subscription
    = SubAddr
    | SubBlockLastPage  -- ^ subscribe on blocks last page (latest blocks)
    | SubEpochsLastPage -- ^ subscribe on epochs last page (latest epoch)
    | SubTx
    deriving (Show, Generic)

data ClientEvent
    = Subscribe Subscription
    | Unsubscribe Subscription
    | CallMe
    deriving (Show, Generic)

instance EventName ClientEvent where
    toName = show

data ServerEvent
    = AddrUpdated
    | BlocksLastPageUpdated
    | EpochsLastPageUpdated
    | TxsUpdated
    | CallYou
    deriving (Show, Generic)

instance EventName ServerEvent where
    toName = show

-- * Util

fromCAddressOrThrow :: MonadThrow m => CAddress -> m Address
fromCAddressOrThrow =
    either (\_ -> throwM $ Internal "Malformed address") return .
    fromCAddress

-- * Client requests provessing

type SubscriptionMode m =
    ( WithLogger m
    , MonadThrow m
    , MonadState ConnectionsState m
    )

-- | This describes points related to some subscribtion action.
-- Each subscription type has its own /client data/ which user provides
-- as parameter when subscribes, it is then stored in 'ClientContext' type.
data SubscriptionParam cli = SubscriptionParam
    { -- | Identificator of current session
      spSessId       :: SocketId
      -- | Description of this subscription
    , spDesc         :: cli -> Text
      -- | Sets current session subscribed / unsubscribed
    , spSubscription :: cli -> Lens' ConnectionsState (Maybe ())
      -- | Sets related client data present / absent
    , spCliData      :: Lens' ClientContext (Maybe cli)
    }

startSession
    :: SubscriptionMode m
    => Socket -> m ()
startSession socket = do
    let cc = mkClientContext $ ProdSocket socket
        id = socketId socket
    csClients . at id .= Just cc
    logDebug $ sformat ("New session has started (#"%shown%")") id

finishSession
    :: SubscriptionMode m
    => SocketId -> m ()
finishSession sessId =
    whenJustM (use $ csClients . at sessId) $ \_ -> do
        unsubscribeFully sessId
        csClients . at sessId .= Nothing
        logDebug $ sformat ("Session #"%shown%" has finished") sessId

subscribe
    :: SubscriptionMode m
    => cli -> SubscriptionParam cli -> m ()
subscribe cliData sp@SubscriptionParam{..} = do
    unsubscribe sp
    session <- use $ csClients . at spSessId
    case session of
        Just _  -> do
            spSubscription cliData .= Just ()
            csClients . ix spSessId . spCliData .= Just cliData
            logDebug $ sformat ("Client #"%shown%" subscribed to "%stext%" \
                       \updates") spSessId (spDesc cliData)
        _       ->
            logWarning $ sformat ("Unregistered client tries to subscribe on "%
                         stext%" updates") (spDesc cliData)

unsubscribe
    :: SubscriptionMode m
    => SubscriptionParam cli -> m ()
unsubscribe SubscriptionParam{..} = do
    mCliData <- preuse $ csClients . ix spSessId . spCliData . _Just
    case mCliData of
        Just cliData -> do
            csClients . ix spSessId . spCliData .= Nothing
            spSubscription cliData .= Nothing
            logDebug $ sformat ("Client #"%shown%" unsubscribed from "%stext%
                       " updates") spSessId (spDesc cliData)
        Nothing ->
            logDebug $ sformat ("Client #"%shown%" unsubscribes from action \
                       \at which it wasn't subscribed") spSessId

-- | This is hack which makes client data look like always be present in
-- 'ClientContext'.
-- It's exploited in 'unsubscribe' then, because it works only if client data
-- is present.
noCliDataKept :: Lens' a (Maybe ())
noCliDataKept = lens (\_ -> Just ()) const

addrSubParam :: SocketId -> SubscriptionParam Address
addrSubParam sessId =
    SubscriptionParam
        { spSessId        = sessId
        , spDesc          = ("address " <> ) . show
        , spSubscription  = \addr ->
            csAddressSubscribers . at addr . non S.empty . at sessId
        , spCliData       = ccAddress
        }

blockPageSubParam :: SocketId -> SubscriptionParam ()
blockPageSubParam sessId =
    SubscriptionParam
        { spSessId       = sessId
        , spDesc         = const "blockchain last page"
        , spSubscription = \_ -> csBlocksPageSubscribers . at sessId
        , spCliData      = noCliDataKept
        }

txsSubParam :: SocketId -> SubscriptionParam ()
txsSubParam sessId =
    SubscriptionParam
        { spSessId       = sessId
        , spDesc         = const "txs"
        , spSubscription = \_ -> csTxsSubscribers . at sessId
        , spCliData      = noCliDataKept
        }


epochsLastPageSubParam :: SocketId -> SubscriptionParam ()
epochsLastPageSubParam sessId =
    SubscriptionParam
        { spSessId       = sessId
        , spDesc         = const "epochs last page"
        , spSubscription = \_ -> csEpochsLastPageSubscribers . at sessId
        , spCliData      = noCliDataKept
        }

-- | Unsubscribes on any previous address and subscribes on given one.
subscribeAddr
    :: SubscriptionMode m
    => CAddress -> SocketId -> m ()
subscribeAddr caddr sessId = do
    addr <- fromCAddressOrThrow caddr
    subscribe addr (addrSubParam sessId)

unsubscribeAddr
    :: SubscriptionMode m
    => SocketId -> m ()
unsubscribeAddr sessId = unsubscribe (addrSubParam sessId)

subscribeBlocksLastPage
    :: SubscriptionMode m
    => SocketId -> m ()
subscribeBlocksLastPage sessId = subscribe () (blockPageSubParam sessId)

unsubscribeBlocksLastPage
    :: SubscriptionMode m
    => SocketId -> m ()
unsubscribeBlocksLastPage sessId = unsubscribe (blockPageSubParam sessId)

subscribeTxs
    :: SubscriptionMode m
    => SocketId -> m ()
subscribeTxs sessId = subscribe () (txsSubParam sessId)

unsubscribeTxs
    :: SubscriptionMode m
    => SocketId -> m ()
unsubscribeTxs sessId = unsubscribe (txsSubParam sessId)

subscribeEpochsLastPage
    :: SubscriptionMode m
    => SocketId -> m ()
subscribeEpochsLastPage sessId =
    subscribe () (epochsLastPageSubParam sessId)

unsubscribeEpochsLastPage
    :: SubscriptionMode m
    => SocketId -> m ()
unsubscribeEpochsLastPage sessId = unsubscribe (epochsLastPageSubParam sessId)

unsubscribeFully
    :: SubscriptionMode m
    => SocketId -> m ()
unsubscribeFully sessId = do
    logDebug $ sformat ("Client #"%shown%" unsubscribes from all updates")
               sessId
    modifyLoggerName (const "drop") $ do
        unsubscribeAddr sessId
        unsubscribeBlocksLastPage sessId
        unsubscribeTxs sessId
        unsubscribeEpochsLastPage sessId

-- * Notifications

broadcast
    :: (ExplorerMode ctx m, EventName event, ToJSON args)
    => event -> args -> Set SocketId -> ExplorerSockets m ()
broadcast event args recipients = do
    forM_ recipients $ \sockid -> do
        mSock <- preview $ csClients . ix sockid . ccConnection . _ProdSocket
        case mSock of
            Nothing   -> logWarning $
                sformat ("No socket with SocketId="%shown%" registered for using in production") sockid
            Just sock -> emitTo sock event args
                `catchAny` handler sockid
  where
    handler sockid = logWarning .
        sformat ("Failed to send to SocketId="%shown%": "%shown) sockid

notifyAddrSubscribers
    :: forall ctx m . ExplorerMode ctx m
    => Address -> [CTxBrief] -> ExplorerSockets m ()
notifyAddrSubscribers addr cTxEntries = do
    mRecipients <- view $ csAddressSubscribers . at addr
    whenJust mRecipients $ broadcast @ctx AddrUpdated cTxEntries

notifyBlocksLastPageSubscribers
    :: forall ctx m . ExplorerMode ctx m => SlotCount -> ExplorerSockets m ()
notifyBlocksLastPageSubscribers epochSlots = do
    recipients <- view csBlocksPageSubscribers
    blocks     <- lift $ getBlocksLastPage @ctx epochSlots
    broadcast @ctx BlocksLastPageUpdated blocks recipients

notifyTxsSubscribers
    :: forall ctx m . ExplorerMode ctx m
    => [CTxEntry] -> ExplorerSockets m ()
notifyTxsSubscribers cTxEntries =
    view csTxsSubscribers >>= broadcast @ctx TxsUpdated cTxEntries

notifyEpochsLastPageSubscribers
    :: forall ctx m
     . ExplorerMode ctx m
    => SlotCount
    -> EpochIndex
    -> ExplorerSockets m ()
notifyEpochsLastPageSubscribers epochSlots currentEpoch = do
    -- subscriber
    recipients <- view $ csEpochsLastPageSubscribers
    -- last epoch page
    lastPage <- lift $ getEpochPagesOrThrow currentEpoch
    -- epochs of last page
    epochs <- lift $ getEpochPage @ctx epochSlots currentEpoch $ Just lastPage
    broadcast @ctx EpochsLastPageUpdated epochs recipients

-- * Helpers

-- | Gets blocks from recent inclusive to old one exclusive.
getBlundsFromTo
    :: forall ctx m . ExplorerMode ctx m
    => GenesisHash -> HeaderHash -> HeaderHash -> m (Maybe [Blund])
getBlundsFromTo genesisHash recentBlock oldBlock =
    DB.getHashesRange Nothing oldBlock recentBlock >>= \case
        Left _ -> pure Nothing
        Right hashes ->
            Just . catMaybes <$> forM (NE.tail $ getOldestFirst hashes) (getBlund genesisHash)

addrsTouchedByTx
    :: MonadDBRead m
    => Tx -> m (S.Set Address)
addrsTouchedByTx tx = do
      -- for each transaction, get its OutTx
      -- and transactions from InTx
      inTxs <- forM (_txInputs tx) $ getTxOut >=> \case
      -- inTxs :: NonEmpty [TxOut]
          -- TODO [CSM-153]: lookup mempool as well
          Nothing       -> return mempty
          Just txOutAux -> return . one $ toaOut txOutAux

      pure $ addressSetByTxs (_txOutputs tx) inTxs

-- | Helper to filter addresses by a given tx from a list of txs
addressSetByTxs :: NonEmpty TxOut -> NonEmpty [TxOut] -> (S.Set Address)
addressSetByTxs tx txs =
    let txs' = (toList tx) <> (concat txs) in
    S.fromList $ txOutAddress <$> txs'

getBlockTxs
    :: forall ctx m . (ExplorerMode ctx m)
    => Block -> m [TxInternal]
getBlockTxs (Left  _  ) = return []
getBlockTxs (Right blk) = do
    txs <- topsortTxsOrFail withHash $ toList $ blk ^. mainBlockTxPayload . txpTxs
    forM txs $ \tx -> do
        extra@TxExtra {..} <- DB.getTxExtra (hash tx) >>=
            maybeThrow (Internal "In-block transaction doesn't \
                                 \have extra info in DB")
        pure $ TxInternal extra tx

getTxInfo
    :: (ExplorerMode ctx m)
    => TxInternal -> m (CTxBrief, S.Set Address)
getTxInfo tx = do
    let ctxBrief = toTxBrief tx
    addrs <- addrsTouchedByTx (tiTx tx)
    return (ctxBrief, addrs)
