{-# LANGUAGE RankNTypes #-}
module Neovim.RPC.Common
where
import Neovim.Context
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Data.Int (Int64)
import Data.Map
import Data.MessagePack
import Data.Monoid
import Data.Streaming.Network
import Data.String
import Data.Time
import Network.Socket as N hiding (SocketType)
import System.Environment (getEnv)
import System.IO (BufferMode (..), Handle, IOMode(ReadWriteMode),
hClose, hSetBuffering)
import System.Log.Logger
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, MonadIO io) => io RPCConfig
newRPCConfig :: io RPCConfig
newRPCConfig = TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
-> TVar Int64 -> RPCConfig
RPCConfig
(TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
-> TVar Int64 -> RPCConfig)
-> io (TVar (Map Int64 (UTCTime, TMVar (Either Object Object))))
-> io (TVar Int64 -> RPCConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (TVar (Map Int64 (UTCTime, TMVar (Either Object Object))))
-> io (TVar (Map Int64 (UTCTime, TMVar (Either Object Object))))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Map Int64 (UTCTime, TMVar (Either Object Object))
-> IO (TVar (Map Int64 (UTCTime, TMVar (Either Object Object))))
forall a. a -> IO (TVar a)
newTVarIO Map Int64 (UTCTime, TMVar (Either Object Object))
forall a. Monoid a => a
mempty)
io (TVar Int64 -> RPCConfig) -> io (TVar Int64) -> io RPCConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (TVar Int64) -> io (TVar Int64)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int64 -> IO (TVar Int64)
forall a. a -> IO (TVar a)
newTVarIO Int64
1)
data SocketType = Stdout Handle
| Environment
| UnixSocket FilePath
| TCP Int String
createHandle :: (Functor io, MonadIO io)
=> SocketType
-> io Handle
createHandle :: SocketType -> io Handle
createHandle = \case
Stdout Handle
h -> do
IO () -> io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> IO () -> io ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h (Maybe Int -> BufferMode
BlockBuffering Maybe Int
forall a. Maybe a
Nothing)
Handle -> io Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h
UnixSocket FilePath
f ->
SocketType -> io Handle
forall (io :: * -> *).
(Functor io, MonadIO io) =>
SocketType -> io Handle
createHandle (SocketType -> io Handle)
-> (Handle -> SocketType) -> Handle -> io Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> SocketType
Stdout (Handle -> io Handle) -> io Handle -> io Handle
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> io Handle
forall (io :: * -> *). MonadIO io => FilePath -> io Handle
createUnixSocketHandle FilePath
f
TCP Int
p FilePath
h ->
SocketType -> io Handle
forall (io :: * -> *).
(Functor io, MonadIO io) =>
SocketType -> io Handle
createHandle (SocketType -> io Handle)
-> (Handle -> SocketType) -> Handle -> io Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> SocketType
Stdout (Handle -> io Handle) -> io Handle -> io Handle
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> FilePath -> io Handle
forall (io :: * -> *). MonadIO io => Int -> FilePath -> io Handle
createTCPSocketHandle Int
p FilePath
h
SocketType
Environment ->
SocketType -> io Handle
forall (io :: * -> *).
(Functor io, MonadIO io) =>
SocketType -> io Handle
createHandle (SocketType -> io Handle)
-> (Handle -> SocketType) -> Handle -> io Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> SocketType
Stdout (Handle -> io Handle) -> io Handle -> io Handle
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< io Handle
createSocketHandleFromEnvironment
where
createUnixSocketHandle :: (MonadIO io) => FilePath -> io Handle
createUnixSocketHandle :: FilePath -> io Handle
createUnixSocketHandle FilePath
f =
IO Handle -> io Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> io Handle) -> IO Handle -> io Handle
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Socket
getSocketUnix FilePath
f IO Socket -> (Socket -> IO Handle) -> IO Handle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Socket -> IOMode -> IO Handle) -> IOMode -> Socket -> IO Handle
forall a b c. (a -> b -> c) -> b -> a -> c
flip Socket -> IOMode -> IO Handle
socketToHandle IOMode
ReadWriteMode
createTCPSocketHandle :: (MonadIO io) => Int -> String -> io Handle
createTCPSocketHandle :: Int -> FilePath -> io Handle
createTCPSocketHandle Int
p FilePath
h = IO Handle -> io Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> io Handle) -> IO Handle -> io Handle
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> IO (Socket, SockAddr)
getSocketTCP (FilePath -> ByteString
forall a. IsString a => FilePath -> a
fromString FilePath
h) Int
p
IO (Socket, SockAddr)
-> ((Socket, SockAddr) -> IO Handle) -> IO Handle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Socket -> IOMode -> IO Handle) -> IOMode -> Socket -> IO Handle
forall a b c. (a -> b -> c) -> b -> a -> c
flip Socket -> IOMode -> IO Handle
socketToHandle IOMode
ReadWriteMode (Socket -> IO Handle)
-> ((Socket, SockAddr) -> Socket)
-> (Socket, SockAddr)
-> IO Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst
createSocketHandleFromEnvironment :: io Handle
createSocketHandleFromEnvironment = do
FilePath
listenAddress <- IO FilePath -> io FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO FilePath
getEnv FilePath
"NVIM_LISTEN_ADDRESS")
case FilePath -> [FilePath]
words FilePath
listenAddress of
[FilePath
unixSocket] -> SocketType -> io Handle
forall (io :: * -> *).
(Functor io, MonadIO io) =>
SocketType -> io Handle
createHandle (FilePath -> SocketType
UnixSocket FilePath
unixSocket)
[FilePath
h,FilePath
p] -> SocketType -> io Handle
forall (io :: * -> *).
(Functor io, MonadIO io) =>
SocketType -> io Handle
createHandle (Int -> FilePath -> SocketType
TCP (FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
p) FilePath
h)
[FilePath]
_ -> do
let errMsg :: FilePath
errMsg = [FilePath] -> FilePath
unlines
[ FilePath
"Unhandled socket type from environment variable: "
, FilePath
"\t" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
listenAddress
]
IO () -> io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> IO () -> io ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
errorM FilePath
"createHandle" FilePath
errMsg
FilePath -> io Handle
forall a. HasCallStack => FilePath -> a
error FilePath
errMsg
cleanUpHandle :: (MonadIO io) => Handle -> Bool -> io ()
cleanUpHandle :: Handle -> Bool -> io ()
cleanUpHandle Handle
h Bool
completed = IO () -> io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> IO () -> io ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
hClose Handle
h
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
completed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> FilePath -> IO ()
warningM FilePath
"cleanUpHandle" FilePath
"Cleanup called on uncompleted handle."