[GH-78] Generalize node IPC so it can be extended. (#89)

Author: ksaric

app/NodeIPC/Main.hs

@@ -3,9 +3,10 @@ module Main
     ) where
 
 import           Cardano.Prelude
-import           Cardano.Shell.NodeIPC (Port (..), startNodeJsIPC)
+import           Cardano.Shell.NodeIPC (Port (..), ProtocolDuration (..),
+                                        startNodeJsIPC)
 
 main :: IO ()
 main = do
     let port = Port 8090
-    startNodeJsIPC port
+    startNodeJsIPC SingleMessage port

src/Cardano/Shell/NodeIPC.hs

@@ -11,6 +11,7 @@ module Cardano.Shell.NodeIPC
     , ReadHandle(..)
     , WriteHandle(..)
      -- * IPC protocol
+    , ProtocolDuration (..)
     , startNodeJsIPC
     , startIPC
      -- ** Exceptions
@@ -36,8 +37,8 @@ import           Cardano.Shell.NodeIPC.Example (exampleWithFD,
                                                 getReadWriteHandles)
 import           Cardano.Shell.NodeIPC.Lib (MessageSendFailure (..), MsgIn (..),
                                             MsgOut (..), NodeIPCException (..),
-                                            Port (..), isHandleClosed,
-                                            isIPCException,
+                                            Port (..), ProtocolDuration (..),
+                                            isHandleClosed, isIPCException,
                                             isNodeChannelCannotBeFound,
                                             isUnreadableHandle,
                                             isUnwritableHandle, startIPC,

src/Cardano/Shell/NodeIPC/Example.hs

@@ -30,7 +30,7 @@ import           System.Posix.Process (exitImmediately, forkProcess)
 import           System.Process (createPipe)
 
 import           Cardano.Shell.NodeIPC.Lib (MsgIn (..), MsgOut (..), Port (..),
-                                            startIPC)
+                                            ProtocolDuration (..), startIPC)
 import           Cardano.Shell.NodeIPC.Message (ReadHandle (..),
                                                 WriteHandle (..), readMessage,
                                                 sendMessage)
@@ -87,7 +87,7 @@ ipcServer clientWriteHandle msgin = do
     (serverReadHandle, serverWriteHandle) <- getReadWriteHandles
     -- Send message to server
     sendMessage serverWriteHandle msgin
-    startIPC serverReadHandle clientWriteHandle nodePort
+    startIPC SingleMessage serverReadHandle clientWriteHandle nodePort
 
 -- | Read message wigh given 'ReadHandle'
 receieveMessages :: ReadHandle -> IO (MsgOut, MsgOut)

src/Cardano/Shell/NodeIPC/Lib.hs

@@ -3,16 +3,16 @@
 <https://github.com/input-output-hk/cardano-shell/blob/develop/specs/CardanoShellSpec.pdf>
 -}
 
-{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE LambdaCase             #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
 
 module Cardano.Shell.NodeIPC.Lib
     ( startNodeJsIPC
     , startIPC
     , Port (..)
+    , ProtocolDuration (..)
     -- * Testing
     , getIPCHandle
     , MsgIn(..)
@@ -52,6 +52,14 @@ import           Cardano.Shell.NodeIPC.Message (MessageException,
 
 import qualified Prelude as P (Show (..))
 
+-- | The way the IPC protocol works.
+data ProtocolDuration
+    = SingleMessage
+    -- ^ Responds to a single message and exits
+    | MultiMessage
+    -- ^ Runs forever responding to messages
+    deriving (Eq, Show)
+
 -- | Message expecting from Daedalus
 data MsgIn
     = QueryPort
@@ -120,7 +128,13 @@ instance ToJSON MessageSendFailure where
 -- (e.g @8090@)
 newtype Port = Port
     { getPort :: Word16
-    } deriving Show
+    } deriving (Eq, Show, Generic)
+
+instance FromJSON Port where
+    parseJSON = genericParseJSON opts
+
+instance ToJSON Port where
+    toEncoding = genericToEncoding opts
 
 instance Arbitrary Port where
     arbitrary = Port <$> arbitrary
@@ -162,44 +176,58 @@ getIPCHandle = do
             Right fd -> liftIO $ fdToHandle fd
 
 -- | Start IPC with given 'ReadHandle', 'WriteHandle' and 'Port'
-startIPC :: forall m. (MonadIO m) => ReadHandle -> WriteHandle -> Port -> m ()
-startIPC readHandle writeHandle port = liftIO $ void $ ipcListener readHandle writeHandle port
+startIPC :: forall m. (MonadIO m) => ProtocolDuration -> ReadHandle -> WriteHandle -> Port -> m ()
+startIPC protocolDuration readHandle writeHandle port = liftIO $ void $ ipcListener protocolDuration readHandle writeHandle port
 
 -- | Start IPC with NodeJS
 --
 -- This only works if NodeJS spawns the Haskell executable as child process
 -- (See @server.js@ as an example)
-startNodeJsIPC :: forall m. (MonadIO m) => Port -> m ()
-startNodeJsIPC port = do
-    handle <- liftIO $ getIPCHandle
-    let readHandle = ReadHandle handle
+startNodeJsIPC :: forall m. (MonadIO m) => ProtocolDuration -> Port -> m ()
+startNodeJsIPC protocolDuration port = do
+    handle          <- liftIO $ getIPCHandle
+    let readHandle  = ReadHandle handle
     let writeHandle = WriteHandle handle
-    liftIO $ void $ ipcListener readHandle writeHandle port
+    liftIO $ void $ ipcListener protocolDuration readHandle writeHandle port
+
+-- | Function for handling the protocol
+handleIPCProtocol :: forall m. (MonadIO m) => Port -> MsgIn -> m MsgOut
+handleIPCProtocol (Port port) = \case
+    QueryPort          -> pure (ReplyPort port)
+    Ping               -> pure Pong
+    MessageInFailure f -> pure $ MessageOutFailure 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 :: forall m . (MonadIO m, MonadCatch m, MonadMask m) => ReadHandle -> WriteHandle -> Port -> m ()
-ipcListener readHandle@(ReadHandle rHndl) writeHandle@(WriteHandle wHndl) (Port port) =
-    do
-        checkHandles readHandle writeHandle
-        catches handleMsgIn [Handler handler, Handler handleMsgError]
-    `finally`
-    shutdown
+ipcListener
+    :: forall m. (MonadIO m, MonadCatch m, MonadMask m)
+    => ProtocolDuration
+    -> ReadHandle
+    -> WriteHandle
+    -> Port
+    -> m ()
+ipcListener protocolDuration readHandle@(ReadHandle rHndl) writeHandle@(WriteHandle wHndl) port = do
+    checkHandles readHandle writeHandle
+    handleMsgIn `catches` [Handler handler, Handler handleMsgError] `finally` shutdown
   where
     handleMsgIn :: m ()
     handleMsgIn = do
         liftIO $ hSetNewlineMode rHndl noNewlineTranslation
-        send Started
-        msgIn <- readMessage readHandle
-        case msgIn of
-            QueryPort          -> send (ReplyPort port)
-            Ping               -> send Pong
-            -- TODO:Handle them nicely
-            MessageInFailure _ -> return ()
+        send Started -- Send the message first time the IPC is up!
+
+        let frequencyFunction = case protocolDuration of
+                                    SingleMessage -> void
+                                    MultiMessage  -> forever
+
+        -- Fetch message and respond to it
+        frequencyFunction $ do
+            msgIn               <- readMessage readHandle        -- Read message
+            messageByteString   <- handleIPCProtocol port msgIn  -- Respond
+            sendMessage writeHandle messageByteString            -- Write to client/server
 
     send :: MsgOut -> m ()
     send = sendMessage writeHandle

src/Cardano/Shell/NodeIPC/Message.hs

@@ -6,6 +6,7 @@ between Daedalus and Cardano-node
 
 module Cardano.Shell.NodeIPC.Message
     ( sendMessage
+    , sendMessageByteString
     , readMessage
     , MessageException(..)
     , ReadHandle(..)
@@ -47,8 +48,11 @@ newtype WriteHandle = WriteHandle
 
 -- | Send JSON message with given 'WriteHandle'
 sendMessage :: (MonadIO m, ToJSON msg) => WriteHandle -> msg -> m ()
-sendMessage (WriteHandle hndl) cmd = liftIO $ do
-    send buildOS $ encode cmd
+sendMessage writeHandle cmd = sendMessageByteString writeHandle (encode cmd)
+
+sendMessageByteString :: (MonadIO m) => WriteHandle -> BSL.ByteString -> m ()
+sendMessageByteString (WriteHandle hndl) byteString = liftIO $ do
+    send buildOS $ byteString
     hFlush hndl
   where
     send :: OS -> BSL.ByteString -> IO ()
@@ -66,6 +70,10 @@ sendMessage (WriteHandle hndl) cmd = liftIO $ do
     sendLinuxMessage :: BSL.ByteString -> IO ()
     sendLinuxMessage = BSLC.hPutStrLn hndl
 
+
+
+
+
 -- | Read JSON message with given 'ReadHandle'
 readMessage :: (MonadIO m, MonadThrow m, FromJSON msg) => ReadHandle -> m msg
 readMessage (ReadHandle hndl) = do

test/NodeIPCSpec.hs

@@ -21,10 +21,11 @@ import           Test.QuickCheck.Monadic (assert, monadicIO, run)
 import           Cardano.Shell.NodeIPC (MessageException,
                                         MessageSendFailure (..), MsgIn (..),
                                         MsgOut (..), NodeIPCException (..),
-                                        Port (..), ReadHandle (..),
-                                        WriteHandle (..), exampleWithFD,
-                                        exampleWithProcess, getReadWriteHandles,
-                                        isHandleClosed, isIPCException,
+                                        Port (..), ProtocolDuration (..),
+                                        ReadHandle (..), WriteHandle (..),
+                                        exampleWithFD, exampleWithProcess,
+                                        getReadWriteHandles, isHandleClosed,
+                                        isIPCException,
                                         isNodeChannelCannotBeFound,
                                         isUnreadableHandle, isUnwritableHandle,
                                         readMessage, sendMessage, startIPC,
@@ -77,23 +78,23 @@ nodeIPCSpec = do
                 eResult <- run $ try $ do
                     (readHandle, writeHandle) <- getReadWriteHandles
                     closedReadHandle <- (\(ReadHandle hndl) -> hClose hndl >> return (ReadHandle hndl)) readHandle
-                    startIPC closedReadHandle writeHandle port
+                    startIPC SingleMessage closedReadHandle writeHandle port
                 assert $ isLeft (eResult :: Either NodeIPCException ())
                 whenLeft eResult $ \exception -> assert $ isHandleClosed exception
 
             it "should throw NodeIPCException when unreadable handle is given" $ monadicIO $ do
                 eResult <- run $ try $ do
                     (readHandle, writeHandle) <- getReadWriteHandles
                     let (unReadableHandle, _) = swapHandles readHandle writeHandle
-                    startIPC unReadableHandle writeHandle port
+                    startIPC SingleMessage unReadableHandle writeHandle port
                 assert $ isLeft (eResult :: Either NodeIPCException ())
                 whenLeft eResult $ \exception -> assert $ isUnreadableHandle exception
 
             it "should throw NodeIPCException when unwritable handle is given" $ monadicIO $ do
                 eResult <- run $ try $ do
                     (readHandle, writeHandle) <- getReadWriteHandles
                     let (_, unWritableHandle) = swapHandles readHandle writeHandle
-                    startIPC readHandle unWritableHandle port
+                    startIPC SingleMessage readHandle unWritableHandle port
                 assert $ isLeft (eResult :: Either NodeIPCException ())
                 whenLeft eResult $ \exception -> assert $ isUnwritableHandle exception
 
@@ -120,7 +121,7 @@ nodeIPCSpec = do
                     handlesClosed <- run $ do
                         (clientReadHandle, clientWriteHandle) <- getReadWriteHandles
                         (serverReadHandle, serverWriteHandle) <- getReadWriteHandles
-                        as <- async $ startIPC serverReadHandle clientWriteHandle port
+                        as <- async $ startIPC SingleMessage serverReadHandle clientWriteHandle port
                         let readClientMessage = readMessage clientReadHandle
                             sendServer        = sendMessage serverWriteHandle
                         _ <- readClientMessage
@@ -143,7 +144,7 @@ nodeIPCSpec = do
 
     describe "startNodeJsIPC" $
         it "should throw NodeIPCException when it is not spawned by NodeJS process" $ monadicIO $ do
-            eResult <- run $ try $ startNodeJsIPC port
+            eResult <- run $ try $ startNodeJsIPC SingleMessage port
             assert $ isLeft (eResult :: Either NodeIPCException ())
             whenLeft eResult $ \exception -> assert $ isNodeChannelCannotBeFound exception
   where
@@ -165,7 +166,7 @@ nodeIPCSpec = do
         (clientReadHandle, clientWriteHandle) <- getReadWriteHandles
         (serverReadHandle, _)                 <- getReadWriteHandles
 
-        as <- async $ startIPC serverReadHandle clientWriteHandle port
+        as <- async $ startIPC SingleMessage serverReadHandle clientWriteHandle port
         (_ :: MsgOut) <- readMessage clientReadHandle
         return (as, serverReadHandle, clientWriteHandle)
 
@@ -187,7 +188,11 @@ testStartNodeIPC port msg = do
 
     -- Start the server
     (_, responses) <-
-        startIPC serverReadHandle clientWriteHandle port
+        startIPC
+            SingleMessage
+            serverReadHandle
+            clientWriteHandle
+            port
         `concurrently`
         do
             -- Use these functions so you don't pass the wrong handle by mistake