{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cardano.Shell.NodeIPC.Lib
( startNodeJsIPC
, startIPC
, Port (..)
, ProtocolDuration (..)
, handleIPCProtocol
, clientIPCListener
, testStartNodeIPC
, ServerHandles (..)
, ClientHandles (..)
, closeFullDuplexAnonPipesHandles
, createFullDuplexAnonPipesHandles
, bracketFullDuplexAnonPipesHandles
, serverReadWrite
, getIPCHandle
, getHandleFromEnv
, MsgIn(..)
, MsgOut(..)
, NodeIPCError(..)
, MessageSendFailure(..)
, isIPCError
, isHandleClosed
, isUnreadableHandle
, isUnwritableHandle
, isNodeChannelCannotBeFound
) where
import Cardano.Prelude hiding (Handler, catches, finally, handle)
import Control.Exception.Safe (Handler (..), catches, finally)
import Data.Aeson (FromJSON (parseJSON), ToJSON (toEncoding),
defaultOptions, genericParseJSON,
genericToEncoding)
import Data.Aeson.Types (Options, SumEncoding (ObjectWithSingleField),
sumEncoding)
import qualified Data.Text as Text
import GHC.IO.Handle (hIsEOF, hIsOpen, hIsReadable, hIsWritable)
import GHC.IO.Handle.FD (fdToHandle)
import System.Environment (lookupEnv)
import System.IO (BufferMode (..), hClose, hFlush, hSetBuffering,
hSetNewlineMode, noNewlineTranslation)
import System.IO.Error (IOError, isEOFError)
import System.Process (createPipe)
import Test.QuickCheck (Arbitrary (..), Gen, arbitraryASCIIChar,
choose, elements, listOf1, oneof)
import Cardano.Shell.NodeIPC.Message (MessageException,
ReadHandle (..),
WriteHandle (..), readMessage,
sendMessage)
import Prelude (String)
import qualified Prelude as P (Show (..))
data ProtocolDuration
= SingleMessage
| MultiMessage
deriving (ProtocolDuration -> ProtocolDuration -> Bool
(ProtocolDuration -> ProtocolDuration -> Bool)
-> (ProtocolDuration -> ProtocolDuration -> Bool)
-> Eq ProtocolDuration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProtocolDuration -> ProtocolDuration -> Bool
$c/= :: ProtocolDuration -> ProtocolDuration -> Bool
== :: ProtocolDuration -> ProtocolDuration -> Bool
$c== :: ProtocolDuration -> ProtocolDuration -> Bool
Eq, Int -> ProtocolDuration -> ShowS
[ProtocolDuration] -> ShowS
ProtocolDuration -> String
(Int -> ProtocolDuration -> ShowS)
-> (ProtocolDuration -> String)
-> ([ProtocolDuration] -> ShowS)
-> Show ProtocolDuration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProtocolDuration] -> ShowS
$cshowList :: [ProtocolDuration] -> ShowS
show :: ProtocolDuration -> String
$cshow :: ProtocolDuration -> String
showsPrec :: Int -> ProtocolDuration -> ShowS
$cshowsPrec :: Int -> ProtocolDuration -> ShowS
Show)
data MsgIn
= QueryPort
| Ping
| Shutdown
| MessageInFailure MessageSendFailure
deriving (Int -> MsgIn -> ShowS
[MsgIn] -> ShowS
MsgIn -> String
(Int -> MsgIn -> ShowS)
-> (MsgIn -> String) -> ([MsgIn] -> ShowS) -> Show MsgIn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MsgIn] -> ShowS
$cshowList :: [MsgIn] -> ShowS
show :: MsgIn -> String
$cshow :: MsgIn -> String
showsPrec :: Int -> MsgIn -> ShowS
$cshowsPrec :: Int -> MsgIn -> ShowS
Show, MsgIn -> MsgIn -> Bool
(MsgIn -> MsgIn -> Bool) -> (MsgIn -> MsgIn -> Bool) -> Eq MsgIn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MsgIn -> MsgIn -> Bool
$c/= :: MsgIn -> MsgIn -> Bool
== :: MsgIn -> MsgIn -> Bool
$c== :: MsgIn -> MsgIn -> Bool
Eq, (forall x. MsgIn -> Rep MsgIn x)
-> (forall x. Rep MsgIn x -> MsgIn) -> Generic MsgIn
forall x. Rep MsgIn x -> MsgIn
forall x. MsgIn -> Rep MsgIn x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MsgIn x -> MsgIn
$cfrom :: forall x. MsgIn -> Rep MsgIn x
Generic)
instance Arbitrary MsgIn where
arbitrary :: Gen MsgIn
arbitrary = [Gen MsgIn] -> Gen MsgIn
forall a. [Gen a] -> Gen a
oneof
[ MsgIn -> Gen MsgIn
forall (m :: * -> *) a. Monad m => a -> m a
return MsgIn
QueryPort
, MsgIn -> Gen MsgIn
forall (m :: * -> *) a. Monad m => a -> m a
return MsgIn
Ping
, MessageSendFailure -> MsgIn
MessageInFailure (MessageSendFailure -> MsgIn)
-> Gen MessageSendFailure -> Gen MsgIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen MessageSendFailure
forall a. Arbitrary a => Gen a
arbitrary
]
data MsgOut
= Started
| ReplyPort Word16
| Pong
| ShutdownInitiated
| MessageOutFailure MessageSendFailure
deriving (Int -> MsgOut -> ShowS
[MsgOut] -> ShowS
MsgOut -> String
(Int -> MsgOut -> ShowS)
-> (MsgOut -> String) -> ([MsgOut] -> ShowS) -> Show MsgOut
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MsgOut] -> ShowS
$cshowList :: [MsgOut] -> ShowS
show :: MsgOut -> String
$cshow :: MsgOut -> String
showsPrec :: Int -> MsgOut -> ShowS
$cshowsPrec :: Int -> MsgOut -> ShowS
Show, MsgOut -> MsgOut -> Bool
(MsgOut -> MsgOut -> Bool)
-> (MsgOut -> MsgOut -> Bool) -> Eq MsgOut
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MsgOut -> MsgOut -> Bool
$c/= :: MsgOut -> MsgOut -> Bool
== :: MsgOut -> MsgOut -> Bool
$c== :: MsgOut -> MsgOut -> Bool
Eq, (forall x. MsgOut -> Rep MsgOut x)
-> (forall x. Rep MsgOut x -> MsgOut) -> Generic MsgOut
forall x. Rep MsgOut x -> MsgOut
forall x. MsgOut -> Rep MsgOut x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MsgOut x -> MsgOut
$cfrom :: forall x. MsgOut -> Rep MsgOut x
Generic)
data MessageSendFailure
= ParseError Text
| GeneralFailure
deriving (Int -> MessageSendFailure -> ShowS
[MessageSendFailure] -> ShowS
MessageSendFailure -> String
(Int -> MessageSendFailure -> ShowS)
-> (MessageSendFailure -> String)
-> ([MessageSendFailure] -> ShowS)
-> Show MessageSendFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageSendFailure] -> ShowS
$cshowList :: [MessageSendFailure] -> ShowS
show :: MessageSendFailure -> String
$cshow :: MessageSendFailure -> String
showsPrec :: Int -> MessageSendFailure -> ShowS
$cshowsPrec :: Int -> MessageSendFailure -> ShowS
Show, MessageSendFailure -> MessageSendFailure -> Bool
(MessageSendFailure -> MessageSendFailure -> Bool)
-> (MessageSendFailure -> MessageSendFailure -> Bool)
-> Eq MessageSendFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageSendFailure -> MessageSendFailure -> Bool
$c/= :: MessageSendFailure -> MessageSendFailure -> Bool
== :: MessageSendFailure -> MessageSendFailure -> Bool
$c== :: MessageSendFailure -> MessageSendFailure -> Bool
Eq, (forall x. MessageSendFailure -> Rep MessageSendFailure x)
-> (forall x. Rep MessageSendFailure x -> MessageSendFailure)
-> Generic MessageSendFailure
forall x. Rep MessageSendFailure x -> MessageSendFailure
forall x. MessageSendFailure -> Rep MessageSendFailure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MessageSendFailure x -> MessageSendFailure
$cfrom :: forall x. MessageSendFailure -> Rep MessageSendFailure x
Generic)
instance Arbitrary MessageSendFailure where
arbitrary :: Gen MessageSendFailure
arbitrary = [Gen MessageSendFailure] -> Gen MessageSendFailure
forall a. [Gen a] -> Gen a
oneof
[ Text -> MessageSendFailure
ParseError (Text -> MessageSendFailure) -> Gen Text -> Gen MessageSendFailure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
genSafeText
, MessageSendFailure -> Gen MessageSendFailure
forall (m :: * -> *) a. Monad m => a -> m a
return MessageSendFailure
GeneralFailure
]
instance Arbitrary MsgOut where
arbitrary :: Gen MsgOut
arbitrary = do
Text
safeText <- Gen Text
genSafeText
Word16
randomPort <- (Word16, Word16) -> Gen Word16
forall a. Random a => (a, a) -> Gen a
choose (Word16
1000,Word16
10000)
[MsgOut] -> Gen MsgOut
forall a. [a] -> Gen a
elements
[ MsgOut
Started
, Word16 -> MsgOut
ReplyPort Word16
randomPort
, MsgOut
Pong
, MessageSendFailure -> MsgOut
MessageOutFailure (MessageSendFailure -> MsgOut) -> MessageSendFailure -> MsgOut
forall a b. (a -> b) -> a -> b
$ Text -> MessageSendFailure
ParseError Text
safeText
]
genSafeText :: Gen Text
genSafeText :: Gen Text
genSafeText = String -> Text
Text.pack (String -> Text) -> Gen String -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Char -> Gen String
forall a. Gen a -> Gen [a]
listOf1 Gen Char
arbitraryASCIIChar
opts :: Options
opts :: Options
opts = Options
defaultOptions { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
ObjectWithSingleField }
instance ToJSON MsgIn where
toEncoding :: MsgIn -> Encoding
toEncoding = Options -> MsgIn -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
opts
instance FromJSON MsgIn where
parseJSON :: Value -> Parser MsgIn
parseJSON = Options -> Value -> Parser MsgIn
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts
instance ToJSON MsgOut where
toEncoding :: MsgOut -> Encoding
toEncoding = Options -> MsgOut -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
opts
instance FromJSON MsgOut where
parseJSON :: Value -> Parser MsgOut
parseJSON = Options -> Value -> Parser MsgOut
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts
instance FromJSON MessageSendFailure where
parseJSON :: Value -> Parser MessageSendFailure
parseJSON = Options -> Value -> Parser MessageSendFailure
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts
instance ToJSON MessageSendFailure where
toEncoding :: MessageSendFailure -> Encoding
toEncoding = Options -> MessageSendFailure -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
opts
newtype Port = Port
{ Port -> Word16
getPort :: Word16
} deriving (Port -> Port -> Bool
(Port -> Port -> Bool) -> (Port -> Port -> Bool) -> Eq Port
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Port -> Port -> Bool
$c/= :: Port -> Port -> Bool
== :: Port -> Port -> Bool
$c== :: Port -> Port -> Bool
Eq, Int -> Port -> ShowS
[Port] -> ShowS
Port -> String
(Int -> Port -> ShowS)
-> (Port -> String) -> ([Port] -> ShowS) -> Show Port
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Port] -> ShowS
$cshowList :: [Port] -> ShowS
show :: Port -> String
$cshow :: Port -> String
showsPrec :: Int -> Port -> ShowS
$cshowsPrec :: Int -> Port -> ShowS
Show, (forall x. Port -> Rep Port x)
-> (forall x. Rep Port x -> Port) -> Generic Port
forall x. Rep Port x -> Port
forall x. Port -> Rep Port x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Port x -> Port
$cfrom :: forall x. Port -> Rep Port x
Generic)
instance FromJSON Port where
parseJSON :: Value -> Parser Port
parseJSON = Options -> Value -> Parser Port
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts
instance ToJSON Port where
toEncoding :: Port -> Encoding
toEncoding = Options -> Port -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
opts
instance Arbitrary Port where
arbitrary :: Gen Port
arbitrary = Word16 -> Port
Port (Word16 -> Port) -> Gen Word16 -> Gen Port
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word16
forall a. Arbitrary a => Gen a
arbitrary
data NodeIPCError
= NodeChannelNotFound Text
| UnableToParseNodeChannel Text
| IPCError
| HandleClosed Handle
| HandleEOF Handle
| UnreadableHandle Handle
| UnwritableHandle Handle
| NoStdIn
deriving (NodeIPCError -> NodeIPCError -> Bool
(NodeIPCError -> NodeIPCError -> Bool)
-> (NodeIPCError -> NodeIPCError -> Bool) -> Eq NodeIPCError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeIPCError -> NodeIPCError -> Bool
$c/= :: NodeIPCError -> NodeIPCError -> Bool
== :: NodeIPCError -> NodeIPCError -> Bool
$c== :: NodeIPCError -> NodeIPCError -> Bool
Eq)
instance Show NodeIPCError where
show :: NodeIPCError -> String
show = \case
NodeChannelNotFound Text
envName ->
String
"Environment variable cannot be found: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
envName
UnableToParseNodeChannel Text
err ->
String
"Unable to parse file descriptor: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
err
NodeIPCError
IPCError ->
String
"IOError has occured"
HandleClosed Handle
h ->
String
"Given handle is closed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Handle -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Handle
h
HandleEOF Handle
h ->
String
"Given handle is at EOF: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Handle -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Handle
h
UnreadableHandle Handle
h ->
String
"Unable to read with given handle: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Handle -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Handle
h
UnwritableHandle Handle
h ->
String
"Unable to write with given handle: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Handle -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Handle
h
NodeIPCError
NoStdIn -> String
"createProcess returned Nothing when creating pipes for the subprocess"
getHandleFromEnv :: String -> IO (Either NodeIPCError Handle)
getHandleFromEnv :: String -> IO (Either NodeIPCError Handle)
getHandleFromEnv String
envName = ExceptT NodeIPCError IO Handle -> IO (Either NodeIPCError Handle)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT NodeIPCError IO Handle -> IO (Either NodeIPCError Handle))
-> ExceptT NodeIPCError IO Handle
-> IO (Either NodeIPCError Handle)
forall a b. (a -> b) -> a -> b
$ do
Maybe String
mFdstring <- IO (Maybe String) -> ExceptT NodeIPCError IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> ExceptT NodeIPCError IO (Maybe String))
-> IO (Maybe String) -> ExceptT NodeIPCError IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
envName
case Maybe String
mFdstring of
Maybe String
Nothing -> NodeIPCError -> ExceptT NodeIPCError IO Handle
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NodeIPCError -> ExceptT NodeIPCError IO Handle)
-> NodeIPCError -> ExceptT NodeIPCError IO Handle
forall a b. (a -> b) -> a -> b
$ Text -> NodeIPCError
NodeChannelNotFound (Text -> NodeIPCError) -> Text -> NodeIPCError
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertText a b => a -> b
toS String
envName
Just String
fdstring ->
case String -> Either String FD
forall a. Read a => String -> Either String a
readEither String
fdstring of
Left String
err -> NodeIPCError -> ExceptT NodeIPCError IO Handle
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NodeIPCError -> ExceptT NodeIPCError IO Handle)
-> NodeIPCError -> ExceptT NodeIPCError IO Handle
forall a b. (a -> b) -> a -> b
$ Text -> NodeIPCError
UnableToParseNodeChannel (Text -> NodeIPCError) -> Text -> NodeIPCError
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertText a b => a -> b
toS String
err
Right FD
fd -> IO Handle -> ExceptT NodeIPCError IO Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FD -> IO Handle
fdToHandle FD
fd)
getIPCHandle :: IO (Either NodeIPCError Handle)
getIPCHandle :: IO (Either NodeIPCError Handle)
getIPCHandle = String -> IO (Either NodeIPCError Handle)
getHandleFromEnv String
"NODE_CHANNEL_FD"
startIPC
:: ProtocolDuration
-> ReadHandle
-> WriteHandle
-> Port
-> IO (Either NodeIPCError ())
startIPC :: ProtocolDuration
-> ReadHandle -> WriteHandle -> Port -> IO (Either NodeIPCError ())
startIPC ProtocolDuration
protocolDuration ReadHandle
readHandle WriteHandle
writeHandle Port
port =
ExceptT NodeIPCError IO () -> IO (Either NodeIPCError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT NodeIPCError IO () -> IO (Either NodeIPCError ()))
-> ExceptT NodeIPCError IO () -> IO (Either NodeIPCError ())
forall a b. (a -> b) -> a -> b
$ ProtocolDuration
-> ReadHandle -> WriteHandle -> Port -> ExceptT NodeIPCError IO ()
ipcListener ProtocolDuration
protocolDuration ReadHandle
readHandle WriteHandle
writeHandle Port
port
startNodeJsIPC
:: ProtocolDuration
-> Port
-> IO (Either NodeIPCError ())
startNodeJsIPC :: ProtocolDuration -> Port -> IO (Either NodeIPCError ())
startNodeJsIPC ProtocolDuration
protocolDuration Port
port = do
Either NodeIPCError Handle
eHandle <- IO (Either NodeIPCError Handle)
getIPCHandle
Either NodeIPCError Handle -> IO (Either NodeIPCError ())
runIPCListener Either NodeIPCError Handle
eHandle
where
runIPCListener :: Either NodeIPCError Handle -> IO (Either NodeIPCError ())
runIPCListener :: Either NodeIPCError Handle -> IO (Either NodeIPCError ())
runIPCListener (Left NodeIPCError
nodeIPCError) = Either NodeIPCError () -> IO (Either NodeIPCError ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either NodeIPCError () -> IO (Either NodeIPCError ()))
-> (NodeIPCError -> Either NodeIPCError ())
-> NodeIPCError
-> IO (Either NodeIPCError ())
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NodeIPCError -> Either NodeIPCError ()
forall a b. a -> Either a b
Left (NodeIPCError -> IO (Either NodeIPCError ()))
-> NodeIPCError -> IO (Either NodeIPCError ())
forall a b. (a -> b) -> a -> b
$ NodeIPCError
nodeIPCError
runIPCListener (Right Handle
handle) = do
let readHandle :: ReadHandle
readHandle = Handle -> ReadHandle
ReadHandle Handle
handle
let writeHandle :: WriteHandle
writeHandle = Handle -> WriteHandle
WriteHandle Handle
handle
IO (Either NodeIPCError ()) -> IO (Either NodeIPCError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either NodeIPCError ()) -> IO (Either NodeIPCError ()))
-> IO (Either NodeIPCError ()) -> IO (Either NodeIPCError ())
forall a b. (a -> b) -> a -> b
$ ExceptT NodeIPCError IO () -> IO (Either NodeIPCError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT NodeIPCError IO () -> IO (Either NodeIPCError ()))
-> ExceptT NodeIPCError IO () -> IO (Either NodeIPCError ())
forall a b. (a -> b) -> a -> b
$ ProtocolDuration
-> ReadHandle -> WriteHandle -> Port -> ExceptT NodeIPCError IO ()
ipcListener ProtocolDuration
protocolDuration ReadHandle
readHandle WriteHandle
writeHandle Port
port
handleIPCProtocol :: Port -> MsgIn -> IO MsgOut
handleIPCProtocol :: Port -> MsgIn -> IO MsgOut
handleIPCProtocol (Port Word16
port) = \case
MsgIn
QueryPort -> MsgOut -> IO MsgOut
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word16 -> MsgOut
ReplyPort Word16
port)
MsgIn
Ping -> MsgOut -> IO MsgOut
forall (f :: * -> *) a. Applicative f => a -> f a
pure MsgOut
Pong
MsgIn
Shutdown -> MsgOut -> IO MsgOut
forall (m :: * -> *) a. Monad m => a -> m a
return MsgOut
ShutdownInitiated IO MsgOut -> IO MsgOut -> IO MsgOut
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExitCode -> IO MsgOut
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
22)
MessageInFailure MessageSendFailure
f -> MsgOut -> IO MsgOut
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgOut -> IO MsgOut) -> MsgOut -> IO MsgOut
forall a b. (a -> b) -> a -> b
$ MessageSendFailure -> MsgOut
MessageOutFailure MessageSendFailure
f
ipcListener
:: ProtocolDuration
-> ReadHandle
-> WriteHandle
-> Port
-> ExceptT NodeIPCError IO ()
ipcListener :: ProtocolDuration
-> ReadHandle -> WriteHandle -> Port -> ExceptT NodeIPCError IO ()
ipcListener ProtocolDuration
protocolDuration readHandle :: ReadHandle
readHandle@(ReadHandle Handle
rHndl) writeHandle :: WriteHandle
writeHandle@(WriteHandle Handle
wHndl) Port
port = do
ReadHandle -> WriteHandle -> ExceptT NodeIPCError IO ()
checkHandles ReadHandle
readHandle WriteHandle
writeHandle
ExceptT NodeIPCError IO ()
handleMsgIn ExceptT NodeIPCError IO ()
-> [Handler (ExceptT NodeIPCError IO) ()]
-> ExceptT NodeIPCError IO ()
forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
`catches` [(IOError -> ExceptT NodeIPCError IO ())
-> Handler (ExceptT NodeIPCError IO) ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler IOError -> ExceptT NodeIPCError IO ()
handler, (MessageException -> ExceptT NodeIPCError IO ())
-> Handler (ExceptT NodeIPCError IO) ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler MessageException -> ExceptT NodeIPCError IO ()
handleMsgError]
ExceptT NodeIPCError IO ()
-> ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally`
ExceptT NodeIPCError IO ()
shutdown
where
handleMsgIn :: ExceptT NodeIPCError IO ()
handleMsgIn :: ExceptT NodeIPCError IO ()
handleMsgIn = do
IO () -> ExceptT NodeIPCError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT NodeIPCError IO ())
-> IO () -> ExceptT NodeIPCError IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
rHndl NewlineMode
noNewlineTranslation
MsgOut -> ExceptT NodeIPCError IO ()
send MsgOut
Started
let frequencyFunction :: IO a -> IO ()
frequencyFunction = case ProtocolDuration
protocolDuration of
ProtocolDuration
SingleMessage -> IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
ProtocolDuration
MultiMessage -> IO a -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever
IO () -> ExceptT NodeIPCError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT NodeIPCError IO ())
-> IO () -> ExceptT NodeIPCError IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO ()
frequencyFunction (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
MsgIn
msgIn <- ReadHandle -> IO MsgIn
forall (m :: * -> *) msg.
(MonadIO m, MonadThrow m, FromJSON msg) =>
ReadHandle -> m msg
readMessage ReadHandle
readHandle
MsgOut
messageByteString <- Port -> MsgIn -> IO MsgOut
handleIPCProtocol Port
port MsgIn
msgIn
WriteHandle -> MsgOut -> IO ()
forall (m :: * -> *) msg.
(MonadIO m, ToJSON msg) =>
WriteHandle -> msg -> m ()
sendMessage WriteHandle
writeHandle MsgOut
messageByteString
send :: MsgOut -> ExceptT NodeIPCError IO ()
send :: MsgOut -> ExceptT NodeIPCError IO ()
send = WriteHandle -> MsgOut -> ExceptT NodeIPCError IO ()
forall (m :: * -> *) msg.
(MonadIO m, ToJSON msg) =>
WriteHandle -> msg -> m ()
sendMessage WriteHandle
writeHandle
shutdown :: ExceptT NodeIPCError IO ()
shutdown :: ExceptT NodeIPCError IO ()
shutdown = do
IO () -> ExceptT NodeIPCError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT NodeIPCError IO ())
-> IO () -> ExceptT NodeIPCError IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
hClose Handle
rHndl
Handle -> IO ()
hClose Handle
wHndl
Handle -> IO ()
hFlush Handle
stdout
NodeIPCError -> ExceptT NodeIPCError IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError NodeIPCError
IPCError
handleMsgError :: MessageException -> ExceptT NodeIPCError IO ()
handleMsgError :: MessageException -> ExceptT NodeIPCError IO ()
handleMsgError MessageException
err = do
IO () -> ExceptT NodeIPCError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT NodeIPCError IO ())
-> IO () -> ExceptT NodeIPCError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
logError Text
"Unexpected message"
MsgOut -> ExceptT NodeIPCError IO ()
send (MsgOut -> ExceptT NodeIPCError IO ())
-> MsgOut -> ExceptT NodeIPCError IO ()
forall a b. (a -> b) -> a -> b
$ MessageSendFailure -> MsgOut
MessageOutFailure (MessageSendFailure -> MsgOut) -> MessageSendFailure -> MsgOut
forall a b. (a -> b) -> a -> b
$ Text -> MessageSendFailure
ParseError (Text -> MessageSendFailure) -> Text -> MessageSendFailure
forall a b. (a -> b) -> a -> b
$ MessageException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show MessageException
err
handler :: IOError -> ExceptT NodeIPCError IO ()
handler :: IOError -> ExceptT NodeIPCError IO ()
handler IOError
err =
Bool -> ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IOError -> Bool
isEOFError IOError
err) (ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ())
-> ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT NodeIPCError IO ()
shutdown
checkHandles :: ReadHandle -> WriteHandle -> ExceptT NodeIPCError IO ()
checkHandles :: ReadHandle -> WriteHandle -> ExceptT NodeIPCError IO ()
checkHandles (ReadHandle Handle
rHandle) (WriteHandle Handle
wHandle) = do
Handle
-> (Handle -> IO Bool)
-> NodeIPCError
-> ExceptT NodeIPCError IO ()
checkHandle Handle
rHandle Handle -> IO Bool
hIsOpen (Handle -> NodeIPCError
HandleClosed Handle
rHandle)
Handle
-> (Handle -> IO Bool)
-> NodeIPCError
-> ExceptT NodeIPCError IO ()
checkHandle Handle
wHandle Handle -> IO Bool
hIsOpen (Handle -> NodeIPCError
HandleClosed Handle
wHandle)
Handle
-> (Handle -> IO Bool)
-> NodeIPCError
-> ExceptT NodeIPCError IO ()
checkHandle Handle
rHandle Handle -> IO Bool
hIsReadable (Handle -> NodeIPCError
UnreadableHandle Handle
rHandle)
Handle
-> (Handle -> IO Bool)
-> NodeIPCError
-> ExceptT NodeIPCError IO ()
checkHandle Handle
wHandle Handle -> IO Bool
hIsWritable (Handle -> NodeIPCError
UnwritableHandle Handle
wHandle)
where
checkHandle :: Handle -> (Handle -> IO Bool) -> NodeIPCError -> ExceptT NodeIPCError IO ()
checkHandle :: Handle
-> (Handle -> IO Bool)
-> NodeIPCError
-> ExceptT NodeIPCError IO ()
checkHandle Handle
handle Handle -> IO Bool
pre NodeIPCError
exception = do
Bool
result <- IO Bool -> ExceptT NodeIPCError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT NodeIPCError IO Bool)
-> IO Bool -> ExceptT NodeIPCError IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
pre Handle
handle
Bool -> ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
result) (ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ())
-> ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ()
forall a b. (a -> b) -> a -> b
$ NodeIPCError -> ExceptT NodeIPCError IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError NodeIPCError
exception
clientIPCListener
:: ProtocolDuration
-> ClientHandles
-> Port
-> IO (Either NodeIPCError ())
clientIPCListener :: ProtocolDuration
-> ClientHandles -> Port -> IO (Either NodeIPCError ())
clientIPCListener ProtocolDuration
duration ClientHandles
clientHandles Port
port =
ExceptT NodeIPCError IO () -> IO (Either NodeIPCError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT NodeIPCError IO () -> IO (Either NodeIPCError ()))
-> ExceptT NodeIPCError IO () -> IO (Either NodeIPCError ())
forall a b. (a -> b) -> a -> b
$ ProtocolDuration
-> ReadHandle -> WriteHandle -> Port -> ExceptT NodeIPCError IO ()
ipcListener
ProtocolDuration
duration
(ClientHandles -> ReadHandle
getClientReadHandle ClientHandles
clientHandles)
(ClientHandles -> WriteHandle
getClientWriteHandle ClientHandles
clientHandles)
Port
port
data ServerHandles = ServerHandles
{ ServerHandles -> ReadHandle
getServerReadHandle :: !ReadHandle
, ServerHandles -> WriteHandle
getServerWriteHandle :: !WriteHandle
}
data ClientHandles = ClientHandles
{ ClientHandles -> ReadHandle
getClientReadHandle :: !ReadHandle
, ClientHandles -> WriteHandle
getClientWriteHandle :: !WriteHandle
}
serverReadWrite :: ServerHandles -> MsgIn -> IO (Either NodeIPCError MsgOut)
serverReadWrite :: ServerHandles -> MsgIn -> IO (Either NodeIPCError MsgOut)
serverReadWrite ServerHandles
serverHandles MsgIn
msgIn = ExceptT NodeIPCError IO MsgOut -> IO (Either NodeIPCError MsgOut)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT NodeIPCError IO MsgOut -> IO (Either NodeIPCError MsgOut))
-> ExceptT NodeIPCError IO MsgOut
-> IO (Either NodeIPCError MsgOut)
forall a b. (a -> b) -> a -> b
$ do
let readHandle :: ReadHandle
readHandle = ServerHandles -> ReadHandle
getServerReadHandle ServerHandles
serverHandles
let writeHandle :: WriteHandle
writeHandle = ServerHandles -> WriteHandle
getServerWriteHandle ServerHandles
serverHandles
ReadHandle -> WriteHandle -> ExceptT NodeIPCError IO ()
checkHandles ReadHandle
readHandle WriteHandle
writeHandle
WriteHandle -> MsgIn -> ExceptT NodeIPCError IO ()
forall (m :: * -> *) msg.
(MonadIO m, ToJSON msg) =>
WriteHandle -> msg -> m ()
sendMessage WriteHandle
writeHandle MsgIn
msgIn
ExceptT NodeIPCError IO Bool
-> ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> ExceptT NodeIPCError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT NodeIPCError IO Bool)
-> (ReadHandle -> IO Bool)
-> ReadHandle
-> ExceptT NodeIPCError IO Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Handle -> IO Bool
hIsEOF (Handle -> IO Bool)
-> (ReadHandle -> Handle) -> ReadHandle -> IO Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ReadHandle -> Handle
getReadHandle (ReadHandle -> ExceptT NodeIPCError IO Bool)
-> ReadHandle -> ExceptT NodeIPCError IO Bool
forall a b. (a -> b) -> a -> b
$ ReadHandle
readHandle) (ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ())
-> ExceptT NodeIPCError IO () -> ExceptT NodeIPCError IO ()
forall a b. (a -> b) -> a -> b
$
NodeIPCError -> ExceptT NodeIPCError IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (NodeIPCError -> ExceptT NodeIPCError IO ())
-> (ReadHandle -> NodeIPCError)
-> ReadHandle
-> ExceptT NodeIPCError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Handle -> NodeIPCError
HandleEOF (Handle -> NodeIPCError)
-> (ReadHandle -> Handle) -> ReadHandle -> NodeIPCError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ReadHandle -> Handle
getReadHandle (ReadHandle -> ExceptT NodeIPCError IO ())
-> ReadHandle -> ExceptT NodeIPCError IO ()
forall a b. (a -> b) -> a -> b
$ ReadHandle
readHandle
ReadHandle -> ExceptT NodeIPCError IO MsgOut
forall (m :: * -> *) msg.
(MonadIO m, MonadThrow m, FromJSON msg) =>
ReadHandle -> m msg
readMessage ReadHandle
readHandle
bracketFullDuplexAnonPipesHandles
:: ((ServerHandles, ClientHandles) -> IO ())
-> IO ()
bracketFullDuplexAnonPipesHandles :: ((ServerHandles, ClientHandles) -> IO ()) -> IO ()
bracketFullDuplexAnonPipesHandles (ServerHandles, ClientHandles) -> IO ()
computationToRun =
IO (ServerHandles, ClientHandles)
-> ((ServerHandles, ClientHandles) -> IO ())
-> ((ServerHandles, ClientHandles) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
IO (ServerHandles, ClientHandles)
createFullDuplexAnonPipesHandles
(ServerHandles, ClientHandles) -> IO ()
closeFullDuplexAnonPipesHandles
(ServerHandles, ClientHandles) -> IO ()
computationToRun
closeFullDuplexAnonPipesHandles :: (ServerHandles, ClientHandles) -> IO ()
closeFullDuplexAnonPipesHandles :: (ServerHandles, ClientHandles) -> IO ()
closeFullDuplexAnonPipesHandles (ServerHandles
serverHandles, ClientHandles
clientHandles) = do
Handle -> IO ()
hClose (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ ReadHandle -> Handle
getReadHandle (ServerHandles -> ReadHandle
getServerReadHandle ServerHandles
serverHandles)
Handle -> IO ()
hClose (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ WriteHandle -> Handle
getWriteHandle (ServerHandles -> WriteHandle
getServerWriteHandle ServerHandles
serverHandles)
Handle -> IO ()
hClose (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ ReadHandle -> Handle
getReadHandle (ClientHandles -> ReadHandle
getClientReadHandle ClientHandles
clientHandles)
Handle -> IO ()
hClose (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ WriteHandle -> Handle
getWriteHandle (ClientHandles -> WriteHandle
getClientWriteHandle ClientHandles
clientHandles)
createFullDuplexAnonPipesHandles :: IO (ServerHandles, ClientHandles)
createFullDuplexAnonPipesHandles :: IO (ServerHandles, ClientHandles)
createFullDuplexAnonPipesHandles = do
(ReadHandle
clientReadHandle, WriteHandle
clientWriteHandle) <- IO (ReadHandle, WriteHandle)
getReadWriteHandles
(ReadHandle
serverReadHandle, WriteHandle
serverWriteHandle) <- IO (ReadHandle, WriteHandle)
getReadWriteHandles
let serverHandles :: ServerHandles
serverHandles = ReadHandle -> WriteHandle -> ServerHandles
ServerHandles ReadHandle
clientReadHandle WriteHandle
serverWriteHandle
let clientHandles :: ClientHandles
clientHandles = ReadHandle -> WriteHandle -> ClientHandles
ClientHandles ReadHandle
serverReadHandle WriteHandle
clientWriteHandle
(ServerHandles, ClientHandles) -> IO (ServerHandles, ClientHandles)
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerHandles
serverHandles, ClientHandles
clientHandles)
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)
testStartNodeIPC :: (ToJSON msg) => Port -> msg -> IO (MsgOut, MsgOut)
testStartNodeIPC :: Port -> msg -> IO (MsgOut, MsgOut)
testStartNodeIPC Port
port msg
msg = do
(ReadHandle
clientReadHandle, WriteHandle
clientWriteHandle) <- IO (ReadHandle, WriteHandle)
getReadWriteHandles
(ReadHandle
serverReadHandle, WriteHandle
serverWriteHandle) <- IO (ReadHandle, WriteHandle)
getReadWriteHandles
(Either NodeIPCError ()
_, (MsgOut, MsgOut)
responses) <-
ProtocolDuration
-> ReadHandle -> WriteHandle -> Port -> IO (Either NodeIPCError ())
startIPC
ProtocolDuration
SingleMessage
ReadHandle
serverReadHandle
WriteHandle
clientWriteHandle
Port
port
IO (Either NodeIPCError ())
-> IO (MsgOut, MsgOut)
-> IO (Either NodeIPCError (), (MsgOut, MsgOut))
forall a b. IO a -> IO b -> IO (a, b)
`concurrently`
do
let readClientMessage :: IO MsgOut
readClientMessage :: IO MsgOut
readClientMessage = ReadHandle -> IO MsgOut
forall (m :: * -> *) msg.
(MonadIO m, MonadThrow m, FromJSON msg) =>
ReadHandle -> m msg
readMessage ReadHandle
clientReadHandle
let sendServer :: (ToJSON msg) => msg -> IO ()
sendServer :: msg -> IO ()
sendServer = WriteHandle -> msg -> IO ()
forall (m :: * -> *) msg.
(MonadIO m, ToJSON msg) =>
WriteHandle -> msg -> m ()
sendMessage WriteHandle
serverWriteHandle
MsgOut
started <- IO MsgOut
readClientMessage
msg -> IO ()
forall msg. ToJSON msg => msg -> IO ()
sendServer msg
msg
MsgOut
response <- IO MsgOut
readClientMessage
(MsgOut, MsgOut) -> IO (MsgOut, MsgOut)
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgOut
started, MsgOut
response)
(MsgOut, MsgOut) -> IO (MsgOut, MsgOut)
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgOut, MsgOut)
responses
logError :: Text -> IO ()
logError :: Text -> IO ()
logError Text
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
isIPCError :: NodeIPCError -> Bool
isIPCError :: NodeIPCError -> Bool
isIPCError NodeIPCError
IPCError = Bool
True
isIPCError NodeIPCError
_ = Bool
False
isHandleClosed :: NodeIPCError -> Bool
isHandleClosed :: NodeIPCError -> Bool
isHandleClosed (HandleClosed Handle
_) = Bool
True
isHandleClosed NodeIPCError
_ = Bool
False
isUnreadableHandle :: NodeIPCError -> Bool
isUnreadableHandle :: NodeIPCError -> Bool
isUnreadableHandle (UnreadableHandle Handle
_) = Bool
True
isUnreadableHandle NodeIPCError
_ = Bool
False
isUnwritableHandle :: NodeIPCError -> Bool
isUnwritableHandle :: NodeIPCError -> Bool
isUnwritableHandle (UnwritableHandle Handle
_) = Bool
True
isUnwritableHandle NodeIPCError
_ = Bool
False
isNodeChannelCannotBeFound :: NodeIPCError -> Bool
isNodeChannelCannotBeFound :: NodeIPCError -> Bool
isNodeChannelCannotBeFound (NodeChannelNotFound Text
_) = Bool
True
isNodeChannelCannotBeFound NodeIPCError
_ = Bool
False