content: {-# Language OverloadedStrings #-}
  {-|
  Module      : Client.State.Extensions
  Description : Integration between the client and external extensions
  Copyright   : (c) Eric Mertens, 2018
  License     : ISC
  Maintainer  : emertens@gmail.com
  
  This module implements the interaction between the client and its extensions.
  This includes aspects of the extension system that depend on the current client
  state.
  -}
  module Client.State.Extensions
    ( clientChatExtension
    , clientCommandExtension
    , clientStartExtensions
    , clientNotifyExtensions
    , clientStopExtensions
    , clientExtTimer
    , clientThreadJoin
    ) where
  
  import Client.CApi
  import Client.CApi.Types
  import Client.Configuration (configExtensions, ExtensionConfiguration)
  import Client.Message
  import Client.State
  import Control.Concurrent.MVar (putMVar, takeMVar)
  import Control.Exception (displayException, try)
  import Control.Lens
  import Control.Monad (foldM)
  import Control.Monad.IO.Class (liftIO)
  import Data.Foldable (find)
  import Data.IntMap qualified as IntMap
  import Data.Text (Text)
  import Data.Text qualified as Text
  import Data.Time (getZonedTime)
  import Foreign.Ptr (Ptr, nullFunPtr)
  import Foreign.StablePtr (castStablePtrToPtr)
  import Irc.RawIrcMsg (RawIrcMsg)
  
  -- | Start extensions after ensuring existing ones are stopped
  clientStartExtensions ::
    ClientState    {- ^ client state                     -} ->
    IO ClientState {- ^ client state with new extensions -}
  clientStartExtensions st =
    do let cfg = view clientConfig st
       st1 <- clientStopExtensions st
       foldM start1 st1 (view configExtensions cfg)
  
  -- | Start a single extension and register it with the client or
  -- record the error message.
  start1 :: ClientState -> ExtensionConfiguration -> IO ClientState
  start1 st config =
    do res <- try (openExtension config) :: IO (Either IOError ActiveExtension)
  
       case res of
         Left err ->
           do now <- getZonedTime
              return $! recordNetworkMessage ClientMessage
                { _msgTime    = now
                , _msgBody    = ErrorBody (Text.pack (displayException err))
                , _msgNetwork = ""
                } st
  
         Right ae ->
              -- allocate a new identity for this extension
           do let i = case IntMap.maxViewWithKey (view (clientExtensions . esActive) st) of
                        Just ((k,_),_) -> k+1
                        Nothing -> 0
  
              let st1 = st & clientExtensions . esActive . at i ?~ ae
              (st2, h) <- clientPark i st1 (startExtension (clientToken st1) config ae)
  
              -- save handle back into active extension
              return $! st2 & clientExtensions . esActive . ix i %~ \ae' ->
                          ae' { aeSession = h }
  
  
  
  -- | Unload all active extensions.
  clientStopExtensions ::
    ClientState    {- ^ client state                          -} ->
    IO ClientState {- ^ client state with extensions unloaded -}
  clientStopExtensions st =
    do let (aes,st1) = st & clientExtensions . esActive %%~ upd
       ifoldlM step st1 aes
    where
      upd = fmap (fmap disable) . IntMap.partition readyToClose
      disable ae = ae { aeLive = False }
      readyToClose ae = aeThreads ae == 0
      step i st2 ae =
        do (st3,_) <- clientPark i st2 (stopExtension ae)
           return st3
  
  
  -- | Dispatch chat messages through extensions before sending to server.
  clientChatExtension ::
    Text        {- ^ network                     -} ->
    Text        {- ^ target                      -} ->
    Text        {- ^ message                     -} ->
    ClientState {- ^ client state, allow message -} ->
    IO (ClientState, Bool)
  clientChatExtension net tgt msg st
    | noCallback = return (st, True)
    | otherwise  = evalNestedIO $
                   do chat <- withChat net tgt msg
                      liftIO (chat1 chat st (IntMap.toList (IntMap.filter aeLive aes)))
    where
      aes = view (clientExtensions . esActive) st
      noCallback = all (\ae -> fgnChat (aeFgn ae) == nullFunPtr) aes
  
  chat1 ::
    Ptr FgnChat             {- ^ serialized chat message     -} ->
    ClientState             {- ^ client state                -} ->
    [(Int,ActiveExtension)] {- ^ extensions needing callback -} ->
    IO (ClientState, Bool)  {- ^ new state and allow         -}
  chat1 _    st [] = return (st, True)
  chat1 chat st ((i,ae):aes) =
    do (st1, allow) <- clientPark i st (chatExtension ae chat)
       if allow then chat1 chat st1 aes
                else return (st1, False)
  
  
  -- | Dispatch incoming IRC message through extensions
  clientNotifyExtensions ::
    Text                   {- ^ network                 -} ->
    RawIrcMsg              {- ^ incoming message        -} ->
    ClientState            {- ^ client state            -} ->
    IO (ClientState, Bool) {- ^ drop message when false -}
  clientNotifyExtensions network raw st
    | noCallback = return (st, True)
    | otherwise  = evalNestedIO $
                   do fgn <- withRawIrcMsg network raw
                      liftIO (message1 fgn st (IntMap.toList (IntMap.filter aeLive aes)))
    where
      aes = view (clientExtensions . esActive) st
      noCallback = all (\ae -> fgnMessage (aeFgn ae) == nullFunPtr) aes
  
  message1 ::
    Ptr FgnMsg              {- ^ serialized IRC message      -} ->
    ClientState             {- ^ client state                -} ->
    [(Int,ActiveExtension)] {- ^ extensions needing callback -} ->
    IO (ClientState, Bool)  {- ^ new state and allow         -}
  message1 _    st [] = return (st, True)
  message1 chat st ((i,ae):aes) =
    do (st1, allow) <- clientPark i st (notifyExtension ae chat)
       if allow then message1 chat st1 aes
                else return (st1, False)
  
  
  -- | Dispatch @/extension@ command to correct extension. Returns
  -- 'Nothing' when no matching extension is available.
  clientCommandExtension ::
    Text                   {- ^ extension name              -} ->
    Text                   {- ^ command                     -} ->
    ClientState            {- ^ client state                -} ->
    IO (Maybe ClientState) {- ^ new client state on success -}
  clientCommandExtension name command st =
    case find (\(_,ae) -> aeName ae == name)
              (IntMap.toList (IntMap.filter aeLive (view (clientExtensions . esActive) st))) of
          Nothing -> return Nothing
          Just (i,ae) ->
            do (st', _) <- clientPark i st (commandExtension command ae)
               return (Just st')
  
  
  -- | Prepare the client to support reentry from the extension API.
  clientPark ::
    Int              {- ^ extension ID                                        -} ->
    ClientState      {- ^ client state                                        -} ->
    IO a             {- ^ continuation using the stable pointer to the client -} ->
    IO (ClientState, a)
  clientPark i st k =
    do let mvar = view (clientExtensions . esMVar) st
       putMVar mvar (i,st)
       res     <- k
       (_,st') <- takeMVar mvar
       return (st', res)
  
  -- | Get the pointer used by C extensions to reenter the client.
  clientToken :: ClientState -> Ptr ()
  clientToken = views (clientExtensions . esStablePtr) castStablePtrToPtr
  
  -- | Run the next available timer event on a particular extension.
  clientExtTimer ::
    Int         {- ^ extension ID -} ->
    ClientState {- ^ client state -} ->
    IO ClientState
  clientExtTimer i st =
    do let ae = st ^?! clientExtensions . esActive . ix i
       case popTimer ae of
         Nothing -> return st
         Just (_, timerId, fun, dat, ae') ->
           do let st1 = set (clientExtensions . esActive . ix i) ae' st
              (st2,_) <- clientPark i st1 (runTimerCallback fun dat timerId)
              return st2
  
  -- | Run the thread join action on a given extension.
  clientThreadJoin ::
    Int         {- ^ extension ID  -} ->
    ThreadEntry {- ^ thread result -} ->
    ClientState {- ^ client state  -} ->
    IO ClientState
  clientThreadJoin i thread st =
    let ae = st ^?! clientExtensions . esActive . ix i
    in finish ae { aeThreads = aeThreads ae - 1}
    where
      finish ae
        | aeLive ae = -- normal behavior, run finalizer
           do let st1 = set (clientExtensions . esActive . ix i) ae st
              (st2,_) <- clientPark i st1 (threadFinish thread)
              pure st2
        | aeThreads ae == 0 = -- delayed stop, all threads done
           do let st1 = over (clientExtensions . esActive) (sans i) st
              (st2,_) <- clientPark i st1 (stopExtension ae)
              return st2
        | otherwise = -- delayed stop, more threads remain
           do pure (set (clientExtensions . esActive . ix i) ae st)
  