{-| This module provides an example of how NodeIPC works.
--
--
-- We want server/client to read only the messages that each should care about
-- In order to realize this, we need two proccesses with each of them providing
-- read/write handle.
--
-- These processes will then pass each others handle respectively and use it to
-- communicate with each other.
--
-- Server will take client's write handle and server's read handle.
--
-- Client will take server's write handle and client's read handle.
--
-- This allows the two proccesses to send the message to the other while
-- reading the response that other had sent.
-}

module Cardano.Shell.NodeIPC.ServerExample
    ( exampleWithFD
    , exampleServerWithProcess
    -- * For testing
    , getReadWriteHandles
    ) where

import           Cardano.Prelude

import           Cardano.Shell.NodeIPC.Lib (MsgIn (..), MsgOut (..),
                                            NodeIPCError (..), Port (..),
                                            ProtocolDuration (..), startIPC)
import           Cardano.Shell.NodeIPC.Message (ReadHandle (..),
                                                WriteHandle (..), readMessage,
                                                sendMessage)
import           GHC.IO.Handle.FD (fdToHandle)
import           System.Environment (setEnv, unsetEnv)
import           System.IO (BufferMode (..), hClose, hSetBuffering)
import           System.Process (CreateProcess (..), StdStream (..), createPipe,
                                 createPipeFd, proc, withCreateProcess)

-- | Create a pipe for interprocess communication and return a
-- ('ReadHandle', 'WriteHandle') Handle pair.
getReadWriteHandles :: IO (ReadHandle, WriteHandle)
getReadWriteHandles :: IO (ReadHandle, WriteHandle)
getReadWriteHandles = do
    (Handle
readHndl, Handle
writeHndl) <- IO (Handle, Handle)
createPipe
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
readHndl BufferMode
LineBuffering
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
writeHndl BufferMode
LineBuffering
    let readHandle :: ReadHandle
readHandle  = Handle -> ReadHandle
ReadHandle Handle
readHndl
    let writeHandle :: WriteHandle
writeHandle = Handle -> WriteHandle
WriteHandle Handle
writeHndl
    (ReadHandle, WriteHandle) -> IO (ReadHandle, WriteHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReadHandle
readHandle, WriteHandle
writeHandle)

--------------------------------------------------------------------------------
-- Testing
--------------------------------------------------------------------------------

nodePort :: Port
nodePort :: Port
nodePort = Word16 -> Port
Port Word16
8090

-- | Example using file descriptor
exampleWithFD :: MsgIn -> IO (MsgOut, MsgOut)
exampleWithFD :: MsgIn -> IO (MsgOut, MsgOut)
exampleWithFD MsgIn
msgin = do

    (ReadHandle
serverReadHandle, WriteHandle
serverWriteHandle) <- IO (ReadHandle, WriteHandle)
getReadWriteHandles

    (Either NodeIPCError ()
_, (MsgOut, MsgOut)
responses) <- do
        (ReadHandle
clientReadHandle, WriteHandle
clientWriteHandle) <- IO (ReadHandle, WriteHandle)
getReadWriteHandles
        -- Send message to client
        WriteHandle -> MsgIn -> IO ()
forall (m :: * -> *) msg.
(MonadIO m, ToJSON msg) =>
WriteHandle -> msg -> m ()
sendMessage WriteHandle
clientWriteHandle MsgIn
msgin
        ProtocolDuration
-> ReadHandle -> WriteHandle -> Port -> IO (Either NodeIPCError ())
startIPC ProtocolDuration
SingleMessage ReadHandle
clientReadHandle WriteHandle
serverWriteHandle Port
nodePort
        IO (Either NodeIPCError ())
-> IO (MsgOut, MsgOut)
-> IO (Either NodeIPCError (), (MsgOut, MsgOut))
forall a b. IO a -> IO b -> IO (a, b)
`concurrently`
        ReadHandle -> IO (MsgOut, MsgOut)
receieveMessages ReadHandle
serverReadHandle

    (MsgOut, MsgOut) -> IO (MsgOut, MsgOut)
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgOut, MsgOut)
responses

-- | Example of an IPC server that is using haskell executable as an server.
--
-- This will be the server, the one which sends the message (such as @Ping@, @QueryPort@)
-- to get the response from the client.
-- The client is executed via @stack exec node-ipc haskell@
exampleServerWithProcess :: MsgIn -> IO (Either NodeIPCError (MsgOut, MsgOut))
exampleServerWithProcess :: MsgIn -> IO (Either NodeIPCError (MsgOut, MsgOut))
exampleServerWithProcess MsgIn
msg = IO (ReadHandle, Handle)
-> ((ReadHandle, Handle) -> IO ())
-> ((ReadHandle, Handle)
    -> IO (Either NodeIPCError (MsgOut, MsgOut)))
-> IO (Either NodeIPCError (MsgOut, MsgOut))
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (ReadHandle, Handle)
acquire (ReadHandle, Handle) -> IO ()
restore (MsgIn
-> (ReadHandle, Handle)
-> IO (Either NodeIPCError (MsgOut, MsgOut))
action MsgIn
msg)
  where
    acquire :: IO (ReadHandle, Handle)
    acquire :: IO (ReadHandle, Handle)
acquire = do
        (FD
rFd, FD
wFd) <- IO (FD, FD)
createPipeFd
        -- Set the write file descriptor to the envrionment variable
        -- the client will look this up, and use it to talk the server
        String -> String -> IO ()
setEnv String
"NODE_CHANNEL_FD" (FD -> String
forall a b. (Show a, ConvertText String b) => a -> b
show FD
wFd)
        ReadHandle
readHandle  <- Handle -> ReadHandle
ReadHandle (Handle -> ReadHandle) -> IO Handle -> IO ReadHandle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FD -> IO Handle
fdToHandle FD
rFd
        -- Since closeFd only exists in 'unix' library,
        -- the only way to close this Fd is to convert it into Handle and apply
        -- hClose to it
        Handle
writeHandle <- FD -> IO Handle
fdToHandle FD
wFd
        (ReadHandle, Handle) -> IO (ReadHandle, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReadHandle
readHandle, Handle
writeHandle)

    restore :: (ReadHandle, Handle) -> IO ()
    restore :: (ReadHandle, Handle) -> IO ()
restore ((ReadHandle Handle
rHandle), Handle
wHandle) = do
        Handle -> IO ()
hClose Handle
rHandle
        Handle -> IO ()
hClose Handle
wHandle
        String -> IO ()
unsetEnv String
"NODE_CHANNEL_FD"

    action :: MsgIn
           -> (ReadHandle, Handle)
           -> IO (Either NodeIPCError (MsgOut, MsgOut))
    action :: MsgIn
-> (ReadHandle, Handle)
-> IO (Either NodeIPCError (MsgOut, MsgOut))
action MsgIn
msgin (ReadHandle
readHandle, Handle
_) = do
        CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (Either NodeIPCError (MsgOut, MsgOut)))
-> IO (Either NodeIPCError (MsgOut, MsgOut))
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess (String -> [String] -> CreateProcess
proc String
"stack" [String
"exec", String
"node-ipc", String
"haskell"])
            { std_in :: StdStream
std_in = StdStream
CreatePipe } ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> IO (Either NodeIPCError (MsgOut, MsgOut)))
 -> IO (Either NodeIPCError (MsgOut, MsgOut)))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (Either NodeIPCError (MsgOut, MsgOut)))
-> IO (Either NodeIPCError (MsgOut, MsgOut))
forall a b. (a -> b) -> a -> b
$
                \Maybe Handle
mStdIn Maybe Handle
_ Maybe Handle
_ ProcessHandle
_ ->
                    case Maybe Handle
mStdIn of
                      Maybe Handle
Nothing ->
                        Text -> IO (Either NodeIPCError (MsgOut, MsgOut))
forall a. HasCallStack => Text -> a
panic Text
"Cardano.Shell.NodeIPC.ServerExample.exampleServerWithProcess: Nothing"
                      Just Handle
stdIn -> do
                        WriteHandle -> MsgIn -> IO ()
forall (m :: * -> *) msg.
(MonadIO m, ToJSON msg) =>
WriteHandle -> msg -> m ()
sendMessage (Handle -> WriteHandle
WriteHandle Handle
stdIn) MsgIn
msgin
                        (MsgOut, MsgOut) -> Either NodeIPCError (MsgOut, MsgOut)
forall a b. b -> Either a b
Right ((MsgOut, MsgOut) -> Either NodeIPCError (MsgOut, MsgOut))
-> IO (MsgOut, MsgOut) -> IO (Either NodeIPCError (MsgOut, MsgOut))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadHandle -> IO (MsgOut, MsgOut)
receieveMessages ReadHandle
readHandle


-- | Read message wigh given 'ReadHandle'
receieveMessages :: ReadHandle -> IO (MsgOut, MsgOut)
receieveMessages :: ReadHandle -> IO (MsgOut, MsgOut)
receieveMessages ReadHandle
serverReadHandle = do
    let readServerMessage :: IO MsgOut
        readServerMessage :: IO MsgOut
readServerMessage = ReadHandle -> IO MsgOut
forall (m :: * -> *) msg.
(MonadIO m, MonadThrow m, FromJSON msg) =>
ReadHandle -> m msg
readMessage ReadHandle
serverReadHandle
    MsgOut
started <- IO MsgOut
readServerMessage -- Started
    MsgOut
reply   <- IO MsgOut
readServerMessage -- Reply
    (MsgOut, MsgOut) -> IO (MsgOut, MsgOut)
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgOut
started, MsgOut
reply)