{-# LANGUAGE LambdaCase #-}

{-| This module introduces, low-level message handler that is used to communicate
between Daedalus and Cardano-node
-}

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

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

-- | Read-only handle
newtype ReadHandle = ReadHandle
    { ReadHandle -> Handle
getReadHandle :: Handle
    }

-- | Write-only handle
newtype WriteHandle = WriteHandle
    { WriteHandle -> Handle
getWriteHandle :: Handle
    }

-- | Send JSON message with given 'WriteHandle'
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") -- What's with 1 and 0?
    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





-- | Read JSON message with given 'ReadHandle'
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