{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
module Neovim.RPC.Common where
import Neovim.OS (getSocketUnix)
import Control.Applicative (Alternative ((<|>)))
import Control.Monad (unless)
import Data.Int (Int64)
import Data.Map (Map)
import Data.MessagePack (Object)
import Data.Streaming.Network (getSocketTCP)
import Data.String (IsString (fromString))
import Data.Time (UTCTime)
import Neovim.Compat.Megaparsec as P (
MonadParsec (eof, try),
Parser,
anySingle,
anySingleBut,
many,
parse,
single,
some,
)
import Network.Socket as N (socketToHandle)
import System.Log.Logger (errorM, warningM)
import Data.List (intercalate)
import qualified Data.List as List
import Data.Maybe (catMaybes)
import qualified Text.Megaparsec.Char.Lexer as L
import UnliftIO.Environment (lookupEnv)
import UnliftIO
import Prelude
data RPCConfig = RPCConfig
{ RPCConfig
-> TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
recipients :: TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
, RPCConfig -> TVar Int64
nextMessageId :: TVar Int64
}
newRPCConfig :: (Applicative io, MonadUnliftIO io) => io RPCConfig
newRPCConfig :: forall (io :: * -> *).
(Applicative io, MonadUnliftIO io) =>
io RPCConfig
newRPCConfig =
TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
-> TVar Int64 -> RPCConfig
RPCConfig
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 => a -> m (TVar a)
newTVarIO forall a. Monoid a => a
mempty)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int64
1)
data SocketType
=
Stdout Handle
|
Environment
|
UnixSocket FilePath
|
TCP Int String
createHandle ::
(Functor io, MonadUnliftIO io) =>
SocketType ->
io Handle
createHandle :: forall (io :: * -> *).
(Functor io, MonadUnliftIO io) =>
SocketType -> io Handle
createHandle = \case
Stdout Handle
h -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
h (Maybe Int -> BufferMode
BlockBuffering forall a. Maybe a
Nothing)
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h
UnixSocket String
f ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *).
(Functor io, MonadUnliftIO io) =>
SocketType -> io Handle
createHandle forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> SocketType
Stdout forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b c. (a -> b -> c) -> b -> a -> c
flip Socket -> IOMode -> IO Handle
socketToHandle IOMode
ReadWriteMode forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Socket
getSocketUnix String
f
TCP Int
p String
h ->
forall (io :: * -> *).
(Functor io, MonadUnliftIO io) =>
SocketType -> io Handle
createHandle forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> SocketType
Stdout forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (io :: * -> *).
MonadUnliftIO io =>
Int -> String -> io Handle
createTCPSocketHandle Int
p String
h
SocketType
Environment ->
forall (io :: * -> *).
(Functor io, MonadUnliftIO io) =>
SocketType -> io Handle
createHandle forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> SocketType
Stdout forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< io Handle
createSocketHandleFromEnvironment
where
createTCPSocketHandle :: (MonadUnliftIO io) => Int -> String -> io Handle
createTCPSocketHandle :: forall (io :: * -> *).
MonadUnliftIO io =>
Int -> String -> io Handle
createTCPSocketHandle Int
p String
h =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
ByteString -> Int -> IO (Socket, SockAddr)
getSocketTCP (forall a. IsString a => String -> a
fromString String
h) Int
p
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip Socket -> IOMode -> IO Handle
socketToHandle IOMode
ReadWriteMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
createSocketHandleFromEnvironment :: io Handle
createSocketHandleFromEnvironment = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
[String]
envValues <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
lookupEnv [String
"NVIM", String
"NVIM_LISTEN_ADDRESS"]
[SocketType]
listenAdresses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadFail m => String -> m SocketType
parseNvimEnvironmentVariable [String]
envValues
case [SocketType]
listenAdresses of
(SocketType
s : [SocketType]
_) -> forall (io :: * -> *).
(Functor io, MonadUnliftIO io) =>
SocketType -> io Handle
createHandle SocketType
s
[SocketType]
_ -> do
let errMsg :: String
errMsg =
[String] -> String
unlines
[ String
"Unhandled socket type from environment variable: "
, String
"\t" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
envValues
]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"createHandle" String
errMsg
forall a. HasCallStack => String -> a
error String
errMsg
parseNvimEnvironmentVariable :: MonadFail m => String -> m SocketType
parseNvimEnvironmentVariable :: forall (m :: * -> *). MonadFail m => String -> m SocketType
parseNvimEnvironmentVariable String
envValue =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ParsecT Void String Identity SocketType
pTcpAddress forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String Identity SocketType
pUnixSocket) String
envValue String
envValue
pUnixSocket :: P.Parser SocketType
pUnixSocket :: ParsecT Void String Identity SocketType
pUnixSocket = String -> SocketType
UnixSocket forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof
pTcpAddress :: P.Parser SocketType
pTcpAddress :: ParsecT Void String Identity SocketType
pTcpAddress = do
[String]
prefixes <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
P.anySingleBut Char
':') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
P.single Char
':'))
Int
port <- forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> String -> SocketType
TCP Int
port (forall a. [a] -> [[a]] -> [a]
List.intercalate String
":" [String]
prefixes)
cleanUpHandle :: (MonadUnliftIO io) => Handle -> Bool -> io ()
cleanUpHandle :: forall (io :: * -> *). MonadUnliftIO io => Handle -> Bool -> io ()
cleanUpHandle Handle
h Bool
completed = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
completed forall a b. (a -> b) -> a -> b
$
String -> String -> IO ()
warningM String
"cleanUpHandle" String
"Cleanup called on uncompleted handle."