{- |
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 (..),
    FunctionalityDescription (..),
    NeovimEventId (..),
    NvimMethod (..),
    Subscription (..),
    getCommandOptions,
 )
import Neovim.Plugin.IPC.Classes
import qualified Neovim.RPC.Classes as MsgpackRPC
import Neovim.RPC.Common
import Neovim.RPC.FunctionCall

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

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.
Int64
-> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()
handleRequest 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 NeovimEventId
eventId [Object]
args)) ->
            forall a.
NeovimEventId -> [Object] -> ConduitT a Void SocketHandler ()
handleNotification NeovimEventId
eventId [Object]
args
        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

lookupFunction ::
    Internal.Config RPCConfig ->
    FunctionName ->
    IO (Maybe (FunctionalityDescription, Internal.FunctionType))
lookupFunction :: Config RPCConfig
-> FunctionName
-> IO (Maybe (FunctionalityDescription, FunctionType))
lookupFunction Config RPCConfig
rpc (F Text
functionName) = do
    FunctionMap
functionMap <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
readTMVar (forall env. Config env -> TMVar FunctionMap
Internal.globalFunctionMap Config RPCConfig
rpc)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> NvimMethod
NvimMethod Text
functionName) FunctionMap
functionMap

handleRequest :: Int64 -> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()
handleRequest :: forall a.
Int64
-> FunctionName -> [Object] -> ConduitT a Void SocketHandler ()
handleRequest Int64
requestId FunctionName
functionToCall [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.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Int
10 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000) (Config RPCConfig -> IO ()
handle Config RPCConfig
cfg)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    handle :: Internal.Config RPCConfig -> IO ()
    handle :: Config RPCConfig -> IO ()
handle Config RPCConfig
rpc =
        Config RPCConfig
-> FunctionName
-> IO (Maybe (FunctionalityDescription, FunctionType))
lookupFunction Config RPCConfig
rpc FunctionName
functionToCall 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 (m :: * -> *) message.
(MonadUnliftIO 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
requestId (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 Int64
requestId
                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
requestId (UTCTime
now, TMVar (Either Object Object)
reply)
                forall (m :: * -> *) message.
(MonadUnliftIO 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
requestId (FunctionalityDescription -> [Object] -> [Object]
parseParams FunctionalityDescription
copts [Object]
params)

handleNotification :: NeovimEventId -> [Object] -> ConduitT a Void SocketHandler ()
handleNotification :: forall a.
NeovimEventId -> [Object] -> ConduitT a Void SocketHandler ()
handleNotification eventId :: NeovimEventId
eventId@(NeovimEventId Text
str) [Object]
args = 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Config RPCConfig
-> FunctionName
-> IO (Maybe (FunctionalityDescription, FunctionType))
lookupFunction Config RPCConfig
cfg (Text -> FunctionName
F Text
str)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (FunctionalityDescription
copts, Internal.Stateful TQueue SomeMessage
c) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            String -> String -> IO ()
debugM String
logger forall a b. (a -> b) -> a -> b
$ String
"Executing function asynchronously: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
str
            forall (m :: * -> *) message.
(MonadUnliftIO m, Message message) =>
TQueue SomeMessage -> message -> m ()
writeMessage TQueue SomeMessage
c forall a b. (a -> b) -> a -> b
$ NeovimEventId -> [Object] -> Notification
Notification NeovimEventId
eventId (FunctionalityDescription -> [Object] -> [Object]
parseParams FunctionalityDescription
copts [Object]
args)
        Maybe (FunctionalityDescription, FunctionType)
Nothing -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
debugM String
logger forall a b. (a -> b) -> a -> b
$ String
"Handling event: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
str
            TMVar Subscriptions
subscriptions' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env a. (Config env -> a) -> Neovim env a
Internal.asks' forall env. Config env -> TMVar Subscriptions
Internal.subscriptions
            [Subscription]
subscribers <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                    Subscriptions
s <- forall a. TMVar a -> STM a
readTMVar TMVar Subscriptions
subscriptions'
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NeovimEventId
eventId (Subscriptions -> Map NeovimEventId [Subscription]
Internal.byEventId Subscriptions
s)
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Subscription]
subscribers forall a b. (a -> b) -> a -> b
$ \Subscription
subscription -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Subscription -> [Object] -> IO ()
subAction Subscription
subscription [Object]
args

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 [[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{} [Object]
args = case [Object]
args of
    [ObjectArray [Object]
fArgs] -> [Object]
fArgs
    [Object]
_ -> [Object]
args