{-| Node IPC module. For details please read the spec:

<https://github.com/input-output-hk/cardano-shell/blob/develop/specs/CardanoShellSpec.pdf>
-}

{-# 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
    -- * Testing
    , getIPCHandle
    , getHandleFromEnv
    , MsgIn(..)
    , MsgOut(..)
    , NodeIPCError(..)
    , MessageSendFailure(..)
    -- * Predicates
    , 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 (..))

-- | When using pipes, __the write doesn't block, but the read blocks__!
-- As a consequence, we eiter need to use IDs to keep track of the client/server pair,
-- or (read) block so we know which message pair arrived.
-- This might seems an overkill for this task, but it's actually required if we
-- want to reason about it and test it properly.
--
-- >>> (readEnd, writeEnd) <- createPipe
--
-- >>> replicateM 100 $ sendMessage (WriteHandle writeEnd) Cardano.Shell.NodeIPC.Ping
-- [(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),(),()]
--
-- >>> mesg <- replicateM 100 ((readMessage (ReadHandle readEnd)) :: IO MsgIn)
--
-- >>> mesg <- (readMessage (ReadHandle readEnd)) :: IO MsgIn
--
--
-- Blocked!

-- | The way the IPC protocol works - it either responds to a single
-- __IPC__ message or it remains in a loop responding to multiple messages.
data ProtocolDuration
    = SingleMessage
    -- ^ Responds to a single message and exits
    | MultiMessage
    -- ^ Runs forever responding to messages
    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)


-- We look at the messages from the perspective of the client.
--
-- @MsgIn@ ---> CLIENT --> @MsgOut@
--

-- | Message from the server being sent to the client.
data MsgIn
    = QueryPort
    -- ^ Ask which port to use
    | Ping
    -- ^ Ping
    | Shutdown
    -- ^ Shutdown message from the server
    | 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
        -- , return Shutdown
        ]

-- | Message which is send out from Cardano-node
data MsgOut
    = Started
    -- ^ Notify Daedalus that the node has started
    | ReplyPort Word16
    -- ^ Reply of QueryPort
    | Pong
    -- ^ Reply of Ping
    | ShutdownInitiated
    -- ^ Reply of shutdown
    | 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)

-- | Message that can be used to let the other know the that exception had occured
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

-- | Port that is used to communicate between Cardano-node and Daedalus
-- (e.g @8090@)
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

-- | Exception thrown from Node IPC protocol
data NodeIPCError
    = NodeChannelNotFound Text
    -- ^ Node channel was not found
    | UnableToParseNodeChannel Text
    -- ^ Unable to parse given 'Text' as File descriptor
    | IPCError
    -- ^ Exception thrown when there's something wrong with IPC
    | HandleClosed Handle
    -- ^ Given handle is closed therefore cannot be used
    | HandleEOF Handle
    -- ^ Given handle End Of File
    | UnreadableHandle Handle
    -- ^ Given handle cannot be used to read
    | UnwritableHandle Handle
    -- ^ Given handle cannot be used to write
    | 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"

-- | Acquire a Handle that can be used for IPC from Environment
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"

-- | Start IPC with given 'ReadHandle', 'WriteHandle' and 'Port'
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

-- | Start IPC with NodeJS
--
-- This only works if NodeJS spawns the Haskell executable as child process
-- (See @server.js@ as an example)
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

-- | Function for handling the protocol
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
    -- Send message, flush buffer, shutdown. Since it's complicated to reason with another
    -- thread that shuts down the program after some time, we do it immediately.
    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

-- | Start IPC listener with given Handles and Port
--
-- When the listener recieves 'Ping' it will return 'Pong'.
--
-- If it recieves 'QueryPort', then the listener
-- responds with 'ReplyPort' with 'Port',
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 -- Send the message first time the IPC is up!

        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

        -- Fetch message and respond to it
        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        -- Read message
            MsgOut
messageByteString   <- Port -> MsgIn -> IO MsgOut
handleIPCProtocol Port
port MsgIn
msgIn  -- Respond
            WriteHandle -> MsgOut -> IO ()
forall (m :: * -> *) msg.
(MonadIO m, ToJSON msg) =>
WriteHandle -> msg -> m ()
sendMessage WriteHandle
writeHandle MsgOut
messageByteString            -- Write to client/server

    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


-- | Check if given two handles are usable (i.e. Handle is open, can be used to read/write)
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
    -- | Utility function for checking a handle.
    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

-- | Client side IPC protocol.
clientIPCListener
    :: ProtocolDuration
    -> ClientHandles
    -> Port
    -- ^ This is really making things confusing. A Port is here,
    -- but it's determined on the client side, not before.
    -> 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

-- | The set of handles for the server, the halves of one pipe.
data ServerHandles = ServerHandles
    { ServerHandles -> ReadHandle
getServerReadHandle  :: !ReadHandle
    , ServerHandles -> WriteHandle
getServerWriteHandle :: !WriteHandle
    }

-- | The set of handles for the client, the halves of one pipe.
data ClientHandles = ClientHandles
    { ClientHandles -> ReadHandle
getClientReadHandle  :: !ReadHandle
    , ClientHandles -> WriteHandle
getClientWriteHandle :: !WriteHandle
    }

-- | This is a __blocking call__ that sends the message to the client
-- and returns it's response, __after the client response arrives__.
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

    -- First check if the handles are valid!
    ReadHandle -> WriteHandle -> ExceptT NodeIPCError IO ()
checkHandles ReadHandle
readHandle WriteHandle
writeHandle

    -- Then send message and __block__ read.
    WriteHandle -> MsgIn -> ExceptT NodeIPCError IO ()
forall (m :: * -> *) msg.
(MonadIO m, ToJSON msg) =>
WriteHandle -> msg -> m ()
sendMessage WriteHandle
writeHandle MsgIn
msgIn

    -- Check if the handle is at End Of Line, we need to do this
    -- here since we @hIsEOF@ __blocks__ as well.
    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

    -- Read message
    ReadHandle -> ExceptT NodeIPCError IO MsgOut
forall (m :: * -> *) msg.
(MonadIO m, MonadThrow m, FromJSON msg) =>
ReadHandle -> m msg
readMessage ReadHandle
readHandle

-- | A bracket function that can be useful.
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

-- | Close the pipe handles.
closeFullDuplexAnonPipesHandles :: (ServerHandles, ClientHandles) -> IO ()
closeFullDuplexAnonPipesHandles :: (ServerHandles, ClientHandles) -> IO ()
closeFullDuplexAnonPipesHandles (ServerHandles
serverHandles, ClientHandles
clientHandles) = do
    -- close the server side
    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)

    -- close the client side
    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)

-- | Creation of a two-way communication between the server and the client.
-- Full-duplex (two-way) communication normally requires two anonymous pipes.
-- TODO(KS): Bracket this!
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)

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


-- | Test 'startIPC'
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

    -- Start the server
    (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
            -- Use these functions so you don't pass the wrong handle by mistake
            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

            -- Communication starts here
            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

--------------------------------------------------------------------------------
-- Placeholder
--------------------------------------------------------------------------------

-- | Use this until we find suitable logging library
logError :: Text -> IO ()
logError :: Text -> IO ()
logError Text
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

--------------------------------------------------------------------------------
-- Predicates
--------------------------------------------------------------------------------

-- | Checks if given 'NodeIPCError' is 'IPCError'
isIPCError :: NodeIPCError -> Bool
isIPCError :: NodeIPCError -> Bool
isIPCError NodeIPCError
IPCError = Bool
True
isIPCError NodeIPCError
_        = Bool
False

-- | Checks if given 'NodeIPCError' is 'HandleClosed'
isHandleClosed :: NodeIPCError -> Bool
isHandleClosed :: NodeIPCError -> Bool
isHandleClosed (HandleClosed Handle
_) = Bool
True
isHandleClosed NodeIPCError
_                = Bool
False

-- | Checks if given 'NodeIPCError' is 'UnreadableHandle'
isUnreadableHandle :: NodeIPCError -> Bool
isUnreadableHandle :: NodeIPCError -> Bool
isUnreadableHandle (UnreadableHandle Handle
_) = Bool
True
isUnreadableHandle NodeIPCError
_                    = Bool
False

-- | Checks if given 'NodeIPCError' is 'UnwritableHandle'
isUnwritableHandle :: NodeIPCError -> Bool
isUnwritableHandle :: NodeIPCError -> Bool
isUnwritableHandle (UnwritableHandle Handle
_) = Bool
True
isUnwritableHandle NodeIPCError
_                    = Bool
False

-- | Checks if given 'NodeIPCError' is 'NodeChannelNotFound'
isNodeChannelCannotBeFound :: NodeIPCError -> Bool
isNodeChannelCannotBeFound :: NodeIPCError -> Bool
isNodeChannelCannotBeFound (NodeChannelNotFound Text
_) = Bool
True
isNodeChannelCannotBeFound NodeIPCError
_                       = Bool
False