module Cardano.Shell.NodeIPC.ServerExample
( exampleWithFD
, exampleServerWithProcess
, 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)
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)
nodePort :: Port
nodePort :: Port
nodePort = Word16 -> Port
Port Word16
8090
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
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
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
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
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
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
MsgOut
reply <- IO MsgOut
readServerMessage
(MsgOut, MsgOut) -> IO (MsgOut, MsgOut)
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgOut
started, MsgOut
reply)