{-# LANGUAGE LambdaCase #-}
module Cardano.Shell.NodeIPC.Message
( sendMessage
, sendMessageByteString
, readMessage
, MessageException(..)
, ReadHandle(..)
, WriteHandle(..)
) where
import Cardano.Prelude
import Control.Exception.Safe (MonadThrow, throwM)
import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode)
import Data.Binary.Get (getWord32le, getWord64le, runGet)
import Data.Binary.Put (putLazyByteString, putWord32le, putWord64le,
runPut)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Distribution.System (OS (Windows), buildOS)
import System.IO (hFlush, hGetLine)
import qualified Prelude as P (Show (..))
data MessageException
= DecodeFail BSL.ByteString
instance Show MessageException where
show :: MessageException -> String
show (DecodeFail ByteString
blob) = String
"Failed to decode given blob: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BSLC.unpack ByteString
blob
instance Exception MessageException
newtype ReadHandle = ReadHandle
{ ReadHandle -> Handle
getReadHandle :: Handle
}
newtype WriteHandle = WriteHandle
{ WriteHandle -> Handle
getWriteHandle :: Handle
}
sendMessage :: (MonadIO m, ToJSON msg) => WriteHandle -> msg -> m ()
sendMessage :: WriteHandle -> msg -> m ()
sendMessage WriteHandle
writeHandle msg
cmd = WriteHandle -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
WriteHandle -> ByteString -> m ()
sendMessageByteString WriteHandle
writeHandle (msg -> ByteString
forall a. ToJSON a => a -> ByteString
encode msg
cmd)
sendMessageByteString :: (MonadIO m) => WriteHandle -> BSL.ByteString -> m ()
sendMessageByteString :: WriteHandle -> ByteString -> m ()
sendMessageByteString (WriteHandle Handle
hndl) ByteString
byteString = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
OS -> ByteString -> IO ()
send OS
buildOS (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
byteString
Handle -> IO ()
hFlush Handle
hndl
where
send :: OS -> BSL.ByteString -> IO ()
send :: OS -> ByteString -> IO ()
send OS
Windows ByteString
blob = Word32 -> Word32 -> ByteString -> IO ()
sendWindowsMessage Word32
1 Word32
0 (ByteString
blob ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
send OS
_ ByteString
blob = ByteString -> IO ()
sendLinuxMessage ByteString
blob
sendWindowsMessage :: Word32 -> Word32 -> BSL.ByteString -> IO ()
sendWindowsMessage :: Word32 -> Word32 -> ByteString -> IO ()
sendWindowsMessage Word32
int1 Word32
int2 ByteString
blob' =
Handle -> ByteString -> IO ()
BSLC.hPut Handle
hndl (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ [Put] -> Put
forall a. Monoid a => [a] -> a
mconcat
[ Word32 -> Put
putWord32le Word32
int1
, Word32 -> Put
putWord32le Word32
int2
, Word64 -> Put
putWord64le (Word64 -> Put) -> Word64 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> Int64 -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length ByteString
blob'
, ByteString -> Put
putLazyByteString ByteString
blob'
]
sendLinuxMessage :: BSL.ByteString -> IO ()
sendLinuxMessage :: ByteString -> IO ()
sendLinuxMessage = Handle -> ByteString -> IO ()
BSLC.hPutStrLn Handle
hndl
readMessage :: (MonadIO m, MonadThrow m, FromJSON msg) => ReadHandle -> m msg
readMessage :: ReadHandle -> m msg
readMessage (ReadHandle Handle
hndl) = do
ByteString
encodedMessage <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ OS -> IO ByteString
readMessageFromHandle OS
buildOS
(String -> m msg) -> (msg -> m msg) -> Either String msg -> m msg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\String
_ -> MessageException -> m msg
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (MessageException -> m msg) -> MessageException -> m msg
forall a b. (a -> b) -> a -> b
$ ByteString -> MessageException
DecodeFail ByteString
encodedMessage)
msg -> m msg
forall (m :: * -> *) a. Monad m => a -> m a
return
(ByteString -> Either String msg
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
encodedMessage)
where
readMessageFromHandle :: OS -> IO BSL.ByteString
readMessageFromHandle :: OS -> IO ByteString
readMessageFromHandle = \case
OS
Windows -> IO ByteString
windowsReadMessage
OS
_ -> IO ByteString
linuxReadMessage
windowsReadMessage :: IO BSL.ByteString
windowsReadMessage :: IO ByteString
windowsReadMessage = do
Word32
_ <- Handle -> IO Word32
readInt32 Handle
hndl
Word32
_ <- Handle -> IO Word32
readInt32 Handle
hndl
Word64
size <- Handle -> IO Word64
readInt64 Handle
hndl
Handle -> Int -> IO ByteString
BSL.hGet Handle
hndl (Int -> IO ByteString) -> Int -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
size
linuxReadMessage :: IO BSL.ByteString
linuxReadMessage :: IO ByteString
linuxReadMessage = do
String
line <- Handle -> IO String
hGetLine Handle
hndl
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSLC.pack String
line
readInt64 :: Handle -> IO Word64
readInt64 :: Handle -> IO Word64
readInt64 Handle
hnd = do
ByteString
bs <- Handle -> Int -> IO ByteString
BSL.hGet Handle
hnd Int
8
Word64 -> IO Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> IO Word64) -> Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$ Get Word64 -> ByteString -> Word64
forall a. Get a -> ByteString -> a
runGet Get Word64
getWord64le ByteString
bs
readInt32 :: Handle -> IO Word32
readInt32 :: Handle -> IO Word32
readInt32 Handle
hnd = do
ByteString
bs <- Handle -> Int -> IO ByteString
BSL.hGet Handle
hnd Int
4
Word32 -> IO Word32
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> IO Word32) -> Word32 -> IO Word32
forall a b. (a -> b) -> a -> b
$ Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32le ByteString
bs