{- |
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.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.
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

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