{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}
{- |
Module      :  Neovim.RPC.SocketReader
Description :  The component which reads RPC messages from the neovim instance
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental

-}
module Neovim.RPC.SocketReader (
    runSocketReader,
    parseParams,
    ) where

import           Neovim.Classes
import           Neovim.Context
import qualified Neovim.Context.Internal    as Internal
import           Neovim.Plugin.Classes      (CommandArguments (..),
                                             CommandOption (..),
                                             FunctionName (..),
                                             NvimMethod (..),
                                             FunctionalityDescription (..),
                                             getCommandOptions)
import           Neovim.Plugin.IPC.Classes
import qualified Neovim.RPC.Classes         as MsgpackRPC
import           Neovim.RPC.Common
import           Neovim.RPC.FunctionCall

import           Control.Applicative
import           Control.Concurrent.STM
import           Control.Monad              (void)
import           Conduit               as C
import           Data.Conduit.Cereal        (conduitGet2)
import           Data.Default               (def)
import           Data.Foldable              (foldl', forM_)
import qualified Data.Map                   as Map
import           Data.MessagePack
import           Data.Monoid
import qualified Data.Serialize             (get)
import           System.IO                  (Handle)
import           System.Log.Logger
import           UnliftIO.Async             (async, race)
import           UnliftIO.Concurrent        (threadDelay)

import           Prelude

logger :: String
logger :: String
logger = String
"Socket Reader"


type SocketHandler = Neovim RPCConfig


-- | This function will establish a connection to the given socket and read
-- msgpack-rpc events from it.
runSocketReader :: Handle
                -> Internal.Config RPCConfig
                -> IO ()
runSocketReader :: Handle -> Config RPCConfig -> IO ()
runSocketReader Handle
readableHandle Config RPCConfig
cfg =
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a env.
NFData a =>
Config env -> Neovim env a -> IO (Either (Doc AnsiStyle) a)
runNeovim (forall env anotherEnv. env -> Config anotherEnv -> Config env
Internal.retypeConfig (forall env. Config env -> env
Internal.customConfig Config RPCConfig
cfg) Config RPCConfig
cfg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
readableHandle
            forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
Get o -> ConduitT ByteString o m ()
conduitGet2 forall t. Serialize t => Get t
Data.Serialize.get
            forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Object Void SocketHandler ()
messageHandlerSink


-- | Sink that delegates the messages depending on their type.
-- <https://github.com/msgpack-rpc/msgpack-rpc/blob/master/spec.md>
messageHandlerSink :: ConduitT Object Void SocketHandler ()
messageHandlerSink :: ConduitT Object Void SocketHandler ()
messageHandlerSink = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall a b. (a -> b) -> a -> b
$ \Object
rpc -> do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
debugM String
logger forall a b. (a -> b) -> a -> b
$ String
"Received: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Object
rpc
    case forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
rpc of
        Right (MsgpackRPC.Request (Request FunctionName
fn Int64
i [Object]
ps)) ->
            forall a.
Maybe Int64
-> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()
handleRequestOrNotification (forall a. a -> Maybe a
Just Int64
i) FunctionName
fn [Object]
ps

        Right (MsgpackRPC.Response Int64
i Either Object Object
r) ->
            forall a.
Int64 -> Either Object Object -> ConduitT a Void SocketHandler ()
handleResponse Int64
i Either Object Object
r

        Right (MsgpackRPC.Notification (Notification FunctionName
fn [Object]
ps)) ->
            forall a.
Maybe Int64
-> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()
handleRequestOrNotification forall a. Maybe a
Nothing FunctionName
fn [Object]
ps

        Left Doc AnsiStyle
e -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
errorM String
logger forall a b. (a -> b) -> a -> b
$
            String
"Unhandled rpc message: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Doc AnsiStyle
e


handleResponse :: Int64 -> Either Object Object
               -> ConduitT a Void SocketHandler ()
handleResponse :: forall a.
Int64 -> Either Object Object -> ConduitT a Void SocketHandler ()
handleResponse Int64
i Either Object Object
result = do
    TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
answerMap <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RPCConfig
-> TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
recipients
    Maybe (UTCTime, TMVar (Either Object Object))
mReply <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int64
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. TVar a -> IO a
readTVarIO TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
answerMap)
    case Maybe (UTCTime, TMVar (Either Object Object))
mReply of
        Maybe (UTCTime, TMVar (Either Object Object))
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
warningM String
logger
            String
"Received response but could not find a matching recipient."
        Just (UTCTime
_,TMVar (Either Object Object)
reply) -> do
            forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
answerMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int64
i
            forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically' forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either Object Object)
reply Either Object Object
result


-- | Act upon the received request or notification. The main difference between
-- the two is that a notification does not generate a reply. The distinction
-- between those two cases is done via the first paramater which is 'Maybe' the
-- function call identifier.
handleRequestOrNotification :: Maybe Int64 -> FunctionName -> [Object]
                            -> ConduitT a Void SocketHandler ()
handleRequestOrNotification :: forall a.
Maybe Int64
-> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()
handleRequestOrNotification Maybe Int64
requestId functionToCall :: FunctionName
functionToCall@(F ByteString
functionName) [Object]
params = do
    Config RPCConfig
cfg <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env. Neovim env (Config env)
Internal.ask'
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race IO ()
logTimeout (Config RPCConfig -> IO ()
handle Config RPCConfig
cfg)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

  where
    lookupFunction
        :: TMVar Internal.FunctionMap
        -> STM (Maybe (FunctionalityDescription, Internal.FunctionType))
    lookupFunction :: TMVar FunctionMap
-> STM (Maybe (FunctionalityDescription, FunctionType))
lookupFunction TMVar FunctionMap
funMap = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> NvimMethod
NvimMethod ByteString
functionName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TMVar a -> STM a
readTMVar TMVar FunctionMap
funMap

    logTimeout :: IO ()
    logTimeout :: IO ()
logTimeout = do
        let seconds :: Int
seconds = Int
1000 forall a. Num a => a -> a -> a
* Int
1000
        forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
10 forall a. Num a => a -> a -> a
* Int
seconds)
        String -> String -> IO ()
debugM String
logger forall a b. (a -> b) -> a -> b
$ String
"Cancelled another action before it was finished"

    handle :: Internal.Config RPCConfig -> IO ()
    handle :: Config RPCConfig -> IO ()
handle Config RPCConfig
rpc = forall a. STM a -> IO a
atomically (TMVar FunctionMap
-> STM (Maybe (FunctionalityDescription, FunctionType))
lookupFunction (forall env. Config env -> TMVar FunctionMap
Internal.globalFunctionMap Config RPCConfig
rpc)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

        Maybe (FunctionalityDescription, FunctionType)
Nothing -> do
            let errM :: String
errM = String
"No provider for: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show FunctionName
functionToCall
            String -> String -> IO ()
debugM String
logger String
errM
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int64
requestId forall a b. (a -> b) -> a -> b
$ \Int64
i -> forall (m :: * -> *) message.
(MonadIO m, Message message) =>
TQueue SomeMessage -> message -> m ()
writeMessage (forall env. Config env -> TQueue SomeMessage
Internal.eventQueue Config RPCConfig
rpc) forall a b. (a -> b) -> a -> b
$
                Int64 -> Either Object Object -> Message
MsgpackRPC.Response Int64
i (forall a b. a -> Either a b
Left (forall o. NvimObject o => o -> Object
toObject String
errM))

        Just (FunctionalityDescription
copts, Internal.Stateful TQueue SomeMessage
c) -> do
            UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            TMVar (Either Object Object)
reply <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (TMVar a)
newEmptyTMVarIO
            let q :: TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
q = (RPCConfig
-> TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
recipients forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env. Config env -> env
Internal.customConfig) Config RPCConfig
rpc
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
debugM String
logger forall a b. (a -> b) -> a -> b
$ String
"Executing stateful function with ID: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Maybe Int64
requestId
            case Maybe Int64
requestId of
                Just Int64
i -> do
                    forall (io :: * -> *) result. MonadIO io => STM result -> io result
atomically' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
q forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int64
i (UTCTime
now, TMVar (Either Object Object)
reply)
                    forall (m :: * -> *) message.
(MonadIO m, Message message) =>
TQueue SomeMessage -> message -> m ()
writeMessage TQueue SomeMessage
c forall a b. (a -> b) -> a -> b
$ FunctionName -> Int64 -> [Object] -> Request
Request FunctionName
functionToCall Int64
i (FunctionalityDescription -> [Object] -> [Object]
parseParams FunctionalityDescription
copts [Object]
params)

                Maybe Int64
Nothing ->
                    forall (m :: * -> *) message.
(MonadIO m, Message message) =>
TQueue SomeMessage -> message -> m ()
writeMessage TQueue SomeMessage
c forall a b. (a -> b) -> a -> b
$ FunctionName -> [Object] -> Notification
Notification FunctionName
functionToCall (FunctionalityDescription -> [Object] -> [Object]
parseParams FunctionalityDescription
copts [Object]
params)


parseParams :: FunctionalityDescription -> [Object] -> [Object]
parseParams :: FunctionalityDescription -> [Object] -> [Object]
parseParams (Function FunctionName
_ Synchronous
_) [Object]
args = case [Object]
args of
    -- Defining a function on the remote host creates a function that, that
    -- passes all arguments in a list. At the time of this writing, no other
    -- arguments are passed for such a function.
    --
    -- The function generating the function on neovim side is called:
    -- @remote#define#FunctionOnHost@
    [ObjectArray [Object]
fArgs] -> [Object]
fArgs
    [Object]
_                   -> [Object]
args

parseParams cmd :: FunctionalityDescription
cmd@(Command FunctionName
_ CommandOptions
opts) [Object]
args = case [Object]
args of
    (ObjectArray [Object]
_ : [Object]
_) ->
        let cmdArgs :: [CommandOption]
cmdArgs = forall a. (a -> Bool) -> [a] -> [a]
filter CommandOption -> Bool
isPassedViaRPC (CommandOptions -> [CommandOption]
getCommandOptions CommandOptions
opts)
            (CommandArguments
c,[Object]
args') =
                forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (CommandArguments, [Object])
-> (CommandOption, Object) -> (CommandArguments, [Object])
createCommandArguments (forall a. Default a => a
def, []) forall a b. (a -> b) -> a -> b
$
                    forall a b. [a] -> [b] -> [(a, b)]
zip [CommandOption]
cmdArgs [Object]
args
        in forall o. NvimObject o => o -> Object
toObject CommandArguments
c forall a. a -> [a] -> [a]
: [Object]
args'

    [Object]
_ -> FunctionalityDescription -> [Object] -> [Object]
parseParams FunctionalityDescription
cmd forall a b. (a -> b) -> a -> b
$ [[Object] -> Object
ObjectArray [Object]
args]
  where
    isPassedViaRPC :: CommandOption -> Bool
    isPassedViaRPC :: CommandOption -> Bool
isPassedViaRPC = \case
        CmdSync{}  -> Bool
False
        CommandOption
_          -> Bool
True

    -- Neovim passes arguments in a special form, depending on the
    -- CommandOption values used to export the (command) function (e.g. via
    -- 'command' or 'command'').
    createCommandArguments :: (CommandArguments, [Object])
                           -> (CommandOption, Object)
                           -> (CommandArguments, [Object])
    createCommandArguments :: (CommandArguments, [Object])
-> (CommandOption, Object) -> (CommandArguments, [Object])
createCommandArguments old :: (CommandArguments, [Object])
old@(CommandArguments
c, [Object]
args') = \case
        (CmdRange RangeSpecification
_, Object
o) ->
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (CommandArguments, [Object])
old) (\(Int, Int)
r -> (CommandArguments
c { range :: Maybe (Int, Int)
range = forall a. a -> Maybe a
Just (Int, Int)
r }, [Object]
args')) forall a b. (a -> b) -> a -> b
$ forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
o

        (CmdCount Word
_, Object
o) ->
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (CommandArguments, [Object])
old) (\Int
n -> (CommandArguments
c { count :: Maybe Int
count = forall a. a -> Maybe a
Just Int
n }, [Object]
args')) forall a b. (a -> b) -> a -> b
$ forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
o

        (CommandOption
CmdBang, Object
o) ->
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (CommandArguments, [Object])
old) (\Bool
b -> (CommandArguments
c { bang :: Maybe Bool
bang = forall a. a -> Maybe a
Just Bool
b }, [Object]
args')) forall a b. (a -> b) -> a -> b
$ forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
o

        (CmdNargs String
"*", ObjectArray [Object]
os) ->
            -- CommandArguments -> [String] -> Neovim r st a
            (CommandArguments
c, [Object]
os)
        (CmdNargs String
"+", ObjectArray (Object
o:[Object]
os)) ->
            -- CommandArguments -> String -> [String] -> Neovim r st a
            (CommandArguments
c, Object
o forall a. a -> [a] -> [a]
: [[Object] -> Object
ObjectArray [Object]
os])
        (CmdNargs String
"?", ObjectArray [Object
o]) ->
            -- CommandArguments -> Maybe String -> Neovim r st a
            (CommandArguments
c, [forall o. NvimObject o => o -> Object
toObject (forall a. a -> Maybe a
Just Object
o)])

        (CmdNargs String
"?", ObjectArray []) ->
            -- CommandArguments -> Maybe String -> Neovim r st a
            (CommandArguments
c, [forall o. NvimObject o => o -> Object
toObject (forall a. Maybe a
Nothing :: Maybe Object)])

        (CmdNargs String
"0", ObjectArray []) ->
            -- CommandArguments -> Neovim r st a
            (CommandArguments
c, [])

        (CmdNargs String
"1", ObjectArray [Object
o]) ->
            -- CommandArguments -> String -> Neovim r st a
            (CommandArguments
c, [Object
o])

        (CommandOption
CmdRegister, Object
o) ->
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (CommandArguments, [Object])
old) (\String
r -> (CommandArguments
c { register :: Maybe String
register = forall a. a -> Maybe a
Just String
r }, [Object]
args')) forall a b. (a -> b) -> a -> b
$ forall o. NvimObject o => Object -> Either (Doc AnsiStyle) o
fromObject Object
o

        (CommandOption, Object)
_ -> (CommandArguments, [Object])
old

parseParams (Autocmd ByteString
_ FunctionName
_ Synchronous
_ AutocmdOptions
_) [Object]
args = case [Object]
args of
    [ObjectArray [Object]
fArgs] -> [Object]
fArgs
    [Object]
_ -> [Object]
args