{-# LANGUAGE LambdaCase #-}
module Neovim.RPC.SocketReader (
runSocketReader,
parseParams,
) where
import Neovim.Classes ( Int64, NvimObject(toObject, fromObject) )
import Neovim.Context ( MonadIO(liftIO), asks, Neovim, runNeovim )
import qualified Neovim.Context.Internal as Internal
import Neovim.Plugin.Classes (
CommandArguments (..),
CommandOption (..),
FunctionName (..),
FunctionalityDescription (..),
NeovimEventId (..),
NvimMethod (..),
Subscription (..),
getCommandOptions,
)
import Neovim.Plugin.IPC.Classes
( getCurrentTime,
Notification(Notification),
Request(Request),
writeMessage )
import qualified Neovim.RPC.Classes as MsgpackRPC
import Neovim.RPC.Common ( RPCConfig(recipients) )
import Neovim.RPC.FunctionCall ( atomically' )
import Conduit as C
( Void,
MonadTrans(lift),
sourceHandle,
(.|),
awaitForever,
runConduit,
ConduitT )
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 ( Object(ObjectArray) )
import qualified Data.Serialize (get)
import System.IO (Handle)
import System.Log.Logger ( debugM, errorM, warningM )
import UnliftIO (atomically, timeout, readTVarIO, modifyTVar', putTMVar, readTMVar, async, newEmptyTMVarIO, modifyTVar)
import Prelude
logger :: String
logger :: String
logger = String
"Socket Reader"
type SocketHandler = Neovim RPCConfig
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
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 (m :: * -> *) a. MonadIO m => TVar a -> m 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 (io :: * -> *) result. MonadIO io => STM result -> io result
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 (m :: * -> *) a. MonadIO m => m (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 (io :: * -> *) result. MonadIO io => STM result -> io result
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
[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
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
c, [Object]
os)
(CmdNargs String
"+", ObjectArray (Object
o : [Object]
os)) ->
(CommandArguments
c, Object
o forall a. a -> [a] -> [a]
: [[Object] -> Object
ObjectArray [Object]
os])
(CmdNargs String
"?", ObjectArray [Object
o]) ->
(CommandArguments
c, [forall o. NvimObject o => o -> Object
toObject (forall a. a -> Maybe a
Just Object
o)])
(CmdNargs String
"?", ObjectArray []) ->
(CommandArguments
c, [forall o. NvimObject o => o -> Object
toObject (forall a. Maybe a
Nothing :: Maybe Object)])
(CmdNargs String
"0", ObjectArray []) ->
(CommandArguments
c, [])
(CmdNargs String
"1", ObjectArray [Object
o]) ->
(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