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
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 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
[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