{-# LANGUAGE RankNTypes        #-}
{- |
Module      :  Neovim.RPC.Common
Description :  Common functons for the RPC module
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental

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


-- | Things shared between the socket reader and the event handler.
data RPCConfig = RPCConfig
    { RPCConfig
-> TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
recipients :: TVar (Map Int64 (UTCTime, TMVar (Either Object Object)))
    -- ^ A map from message identifiers (as per RPC spec) to a tuple with a
    -- timestamp and a 'TMVar' that is used to communicate the result back to
    -- the calling thread.

    , RPCConfig -> TVar Int64
nextMessageId :: TVar Int64
    -- ^ Message identifier for the next message as per RPC spec.
    }

-- | Create a new basic configuration containing a communication channel for
-- remote procedure call events and an empty lookup table for functions to
-- mediate.
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)

-- | Simple data type defining the kind of socket the socket reader should use.
data SocketType = Stdout Handle
                -- ^ Use the handle for receiving msgpack-rpc messages. This is
                -- suitable for an embedded neovim which is used in test cases.
                | Environment
                -- ^ Read the connection information from the environment
                -- variable @NVIM_LISTEN_ADDRESS@.
                | UnixSocket FilePath
                -- ^ Use a unix socket.
                | TCP Int String
                -- ^ Use an IP socket. First argument is the port and the
                -- second is the host name.

-- | Create a 'Handle' from the given socket description.
--
-- The handle is not automatically closed.
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


-- | Close the handle and print a warning if the conduit chain has been
-- interrupted prematurely.
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."