DaedalusIPC clean ups (#213)

* DaedalusIPC: Clean it up a bit

* Add a test program for DaedalusIPC

Author: rvl

app/daedalus-ipc.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Main where
+
+import           Cardano.Prelude
+
+import           Cardano.BM.Configuration.Static (defaultConfigStdout)
+import           Cardano.BM.Setup (setupTrace_)
+import           Cardano.Shell.DaedalusIPC
+
+main :: IO ()
+main = fmap readEither <$> getArgs >>= \case
+  [Right port] -> do
+    c <- defaultConfigStdout
+    (tr, _sb) <- setupTrace_ c "daedalus-ipc"
+    daedalusIPC tr port
+  _ -> do
+    putStrLn ("Usage: daedalus-ipc PORT" :: Text)
+    exitFailure

cardano-shell.cabal

@@ -28,6 +28,7 @@ library
     , Cardano.Shell.Configuration.Lib
     -- NodeIPC
     , Cardano.Shell.NodeIPC
+    , Cardano.Shell.NodeIPC.General
     , Cardano.Shell.DaedalusIPC
     -- Update system
     , CardanoShellSpec
@@ -136,6 +137,28 @@ executable node-ipc
                        -Wredundant-constraints
                        -Wpartial-fields
 
+executable daedalus-ipc
+  main-is: app/daedalus-ipc.hs
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , cardano-shell
+    , cardano-prelude
+    , optparse-applicative
+    , safe-exceptions
+    , iohk-monitoring
+  default-language:    Haskell2010
+  default-extensions:  NoImplicitPrelude
+                       OverloadedStrings
+
+  ghc-options:         -Wall
+                       -Werror
+                       -Wcompat
+                       -Wincomplete-record-updates
+                       -Wincomplete-uni-patterns
+                       -Wredundant-constraints
+                       -Wpartial-fields
+
 executable cardano-launcher
   main-is: Main.hs
   other-modules:

nix/.stack.nix/cardano-shell.nix

@@ -6,6 +6,7 @@
 -- |
 -- Copyright: © 2018-2019 IOHK
 --
+-- Daedalus <-> Wallet child process port discovery protocol.
 -- Provides a mechanism for Daedalus to discover what port the cardano-wallet
 -- server is listening on.
 --
@@ -19,40 +20,21 @@ module Cardano.Shell.DaedalusIPC
 import           Cardano.Prelude
 
 import           Cardano.BM.Trace (Trace, logError, logInfo, logNotice)
+import           Cardano.Shell.NodeIPC.General (NodeChannelError (..),
+                                                NodeChannelFinished (..),
+                                                runNodeChannel,
+                                                setupNodeChannel)
 import           Control.Concurrent (threadDelay)
-import           Control.Concurrent.Async (concurrently_, race)
-import           Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
-import           Control.Exception (IOException, catch, tryJust)
 import           Control.Monad (forever)
-import           Data.Aeson (FromJSON (..), ToJSON (..), Value (..),
-                             eitherDecode, encode, object, withObject, (.:),
-                             (.=))
-import           Data.Bifunctor (first)
-import           Data.Binary.Get (getWord32le, getWord64le, runGet)
-import           Data.Binary.Put (putLazyByteString, putWord32le, putWord64le,
-                                  runPut)
-import           Data.Functor (($>))
-import           Data.Maybe (fromMaybe)
+import           Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object,
+                             withObject, (.:), (.=))
 import           Data.Text (Text)
-import           Data.Word (Word32, Word64)
-
-import           GHC.IO.Handle.FD (fdToHandle)
-import           System.Environment (lookupEnv)
-import           System.Info (arch)
-import           System.IO (Handle, hFlush, hGetLine, hSetNewlineMode,
-                            noNewlineTranslation)
-import           System.IO.Error (IOError, userError)
-import           Text.Read (readEither)
-
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Lazy.Char8 as L8
-import qualified Data.Text as T
-
-----------------------------------------------------------------------------
--- Daedalus <-> Wallet child process port discovery protocol
 
+-- | Messages sent from Daedalus -> cardano-wallet
 data MsgIn = QueryPort
     deriving (Show, Eq)
+
+-- | Messages sent from cardano-wallet -> Daedalus
 data MsgOut = Started | ReplyPort Int | ParseError Text
     deriving (Show, Eq)
 
@@ -80,154 +62,26 @@ daedalusIPC
     -> Int
     -- ^ Port number to send to Daedalus
     -> IO ()
-daedalusIPC trace port = withNodeChannel (pure . msg) action >>= \case
-    Right runServer -> do
-        logInfo trace "Daedalus IPC server starting"
-        runServer >>= \case
+daedalusIPC tr port = setupNodeChannel >>= \case
+    Right chan -> do
+        logInfo tr "Daedalus IPC server starting"
+        runNodeChannel (pure . msg) action chan >>= \case
             Left (NodeChannelFinished err) ->
-                logNotice trace $ "Daedalus IPC finished for this reason: " <> show err
-            Right () -> logError trace "Unreachable code"
+                logNotice tr $ "Daedalus IPC finished for this reason: " <> show err
+            Right () -> logError tr "Unreachable code"
     Left NodeChannelDisabled -> do
-        logInfo trace "Daedalus IPC is not enabled."
+        logInfo tr "Daedalus IPC is not enabled."
         sleep
     Left (NodeChannelBadFD err) ->
-        logError trace $ "Problem starting Daedalus IPC: " <> show err
+        logError tr $ "Problem starting Daedalus IPC: " <> show err
   where
     -- How to respond to an incoming message, or when there is an incoming
     -- message that couldn't be parsed.
     msg (Right QueryPort) = Just (ReplyPort port)
     msg (Left e)          = Just (ParseError e)
 
-    -- What to do in context of withNodeChannel
+    -- What to do in context of runNodeChannel
     action :: (MsgOut -> IO ()) -> IO ()
     action send = send Started >> sleep
 
-    sleep = threadDelay maxBound
-
-----------------------------------------------------------------------------
--- NodeJS child_process IPC protocol
--- https://nodejs.org/api/child_process.html#child_process_child_process_spawn_command_args_options
-
--- | Possible reasons why the node channel can't be set up.
-data NodeChannelError
-    = NodeChannelDisabled
-      -- ^ This process has not been started as a nodejs @'ipc'@ child_process.
-    | NodeChannelBadFD Text
-      -- ^ The @NODE_CHANNEL_FD@ environment variable has an incorrect value.
-    deriving (Show, Eq)
-
--- | The only way a node channel finishes on its own is if there is some error
--- reading or writing to its file descriptor.
-newtype NodeChannelFinished = NodeChannelFinished IOError
-
--- | Communicate with a parent process using a NodeJS-specific protocol. This
--- process must have been spawned with one of @stdio@ array entries set to
--- @'ipc'@.
---
--- If the channel could be set up, then it returns a function for communicating
--- with the parent process.
-withNodeChannel
-    :: (FromJSON msgin, ToJSON msgout)
-    => (Either Text msgin -> IO (Maybe msgout))
-       -- ^ Handler for messages coming from the parent process. Left values are
-       -- for JSON parse errors. The handler can optionally return a reply
-       -- message.
-    -> ((msgout -> IO ()) -> IO a)
-       -- ^ Action to run with the channel. It is passed a function for sending
-       -- messages to the parent process.
-    -> IO (Either NodeChannelError (IO (Either NodeChannelFinished a)))
-withNodeChannel onMsg handleMsg = fmap setup <$> lookupNodeChannel
-  where
-    setup handle = do
-        chan <- newEmptyMVar
-        let ipc = ipcListener handle onMsg chan
-            action' = handleMsg (putMVar chan)
-        race ipc action'
-
--- | Parse the NODE_CHANNEL_FD variable, if it's set, and convert to a
--- 'System.IO.Handle'.
-lookupNodeChannel :: IO (Either NodeChannelError Handle)
-lookupNodeChannel = (fromMaybe "" <$> lookupEnv "NODE_CHANNEL_FD") >>= \case
-    "" -> pure (Left NodeChannelDisabled)
-    var -> case readEither var of
-        Left err -> pure . Left . NodeChannelBadFD $
-           "unable to parse NODE_CHANNEL_FD: " <> T.pack err
-        Right fd -> tryJust handleBadFd (fdToHandle fd)
-  where
-    handleBadFd :: IOException -> Maybe NodeChannelError
-    handleBadFd = Just . NodeChannelBadFD . T.pack . show
-
-ipcListener
-    :: forall msgin msgout. (FromJSON msgin, ToJSON msgout)
-    => Handle
-    -> (Either Text msgin -> IO (Maybe msgout))
-    -> MVar msgout
-    -> IO NodeChannelFinished
-ipcListener handle onMsg chan = NodeChannelFinished <$> do
-    hSetNewlineMode handle noNewlineTranslation
-    (concurrently_ replyLoop sendLoop $> unexpected) `catch` pure
-  where
-    sendLoop, replyLoop :: IO ()
-    replyLoop = forever (recvMsg >>= onMsg >>= maybeSend)
-    sendLoop = forever (takeMVar chan >>= sendMsg)
-
-    recvMsg :: IO (Either Text msgin)
-    recvMsg = first T.pack . eitherDecode <$> readMessage handle
-
-    sendMsg :: msgout -> IO ()
-    sendMsg = sendMessage handle . encode
-
-    maybeSend :: Maybe msgout -> IO ()
-    maybeSend = maybe (pure ()) (putMVar chan)
-
-    unexpected = userError "ipcListener: unreachable code"
-
-readMessage :: Handle -> IO BL.ByteString
-readMessage = if isWindows then windowsReadMessage else posixReadMessage
-
-isWindows :: Bool
-isWindows = arch == "windows"
-
-windowsReadMessage :: Handle -> IO BL.ByteString
-windowsReadMessage handle = do
-    _int1 <- readInt32 handle
-    _int2 <- readInt32 handle
-    size <- readInt64 handle
-    -- logInfo $ "int is: " <> (show [_int1, _int2]) <> " and blob is: " <> (show blob)
-    BL.hGet handle $ fromIntegral size
-  where
-    readInt64 :: Handle -> IO Word64
-    readInt64 hnd = do
-        bs <- BL.hGet hnd 8
-        pure $ runGet getWord64le bs
-
-    readInt32 :: Handle -> IO Word32
-    readInt32 hnd = do
-        bs <- BL.hGet hnd 4
-        pure $ runGet getWord32le bs
-
-posixReadMessage :: Handle -> IO BL.ByteString
-posixReadMessage = fmap L8.pack . hGetLine
-
-sendMessage :: Handle -> BL.ByteString -> IO ()
-sendMessage handle msg = send handle msg >> hFlush handle
-  where
-    send = if isWindows then sendMessageWindows else sendMessagePosix
-
-sendMessageWindows :: Handle -> BL.ByteString -> IO ()
-sendMessageWindows = sendWindowsMessage' 1 0
-
-sendWindowsMessage' :: Word32 -> Word32 -> Handle -> BL.ByteString -> IO ()
-sendWindowsMessage' int1 int2 handle blob =
-    L8.hPut handle $ runPut $ mconcat parts
-  where
-    blob' = blob <> "\n"
-    parts =
-        [ putWord32le int1
-        , putWord32le int2
-        , putWord64le $ fromIntegral $ BL.length blob'
-        , putLazyByteString blob'
-        ]
-
-sendMessagePosix :: Handle -> BL.ByteString -> IO ()
-sendMessagePosix = L8.hPutStrLn
+    sleep = forever $ threadDelay maxBound