{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- 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.
--
-- See <https://nodejs.org/api/child_process.html#child_process_child_process_spawn_command_args_options>
-- for more information about the message protocol.

module Cardano.Shell.DaedalusIPC
    ( daedalusIPC
    ) where

import           Cardano.Prelude

import           Cardano.Shell.NodeIPC.General (NodeChannelError (..),
                                                NodeChannelFinished (..),
                                                runNodeChannel,
                                                setupNodeChannel)
import           Control.Concurrent (threadDelay)
import           Control.Monad (forever)
import           Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object,
                             withObject, (.:), (.=))
import           Data.Text (Text)

-- | Messages sent from Daedalus -> cardano-wallet
data MsgIn = QueryPort
    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)

-- | Messages sent from cardano-wallet -> Daedalus
data MsgOut = Started | ReplyPort Int | ParseError Text
    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)

instance FromJSON MsgIn where
    parseJSON :: Value -> Parser MsgIn
parseJSON = String -> (Object -> Parser MsgIn) -> Value -> Parser MsgIn
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"MsgIn" ((Object -> Parser MsgIn) -> Value -> Parser MsgIn)
-> (Object -> Parser MsgIn) -> Value -> Parser MsgIn
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
        ([()]
_ :: [()]) <- Object
v Object -> Text -> Parser [()]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"QueryPort"
        MsgIn -> Parser MsgIn
forall (f :: * -> *) a. Applicative f => a -> f a
pure MsgIn
QueryPort

instance ToJSON MsgOut where
    toJSON :: MsgOut -> Value
toJSON MsgOut
Started        = [Pair] -> Value
object [ Text
"Started" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Array -> Value
Array Array
forall a. Monoid a => a
mempty ]
    toJSON (ReplyPort Int
p)  = [Pair] -> Value
object [ Text
"ReplyPort" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
p ]
    toJSON (ParseError Text
e) = [Pair] -> Value
object [ Text
"ParseError" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
e ]

-- | Start up the Daedalus IPC process. It's called 'daedalusIPC', but this
-- could be any nodejs program that needs to start cardano-wallet. All it does
-- is reply with a port number when asked, using a very nodejs-specific IPC
-- method.
--
-- If the IPC channel was successfully set up, this function won't return until
-- the parent process exits. Otherwise, it will return immediately. Before
-- returning, it will log an message about why it has exited.
--
-- TODO(KS): If you want to use TRACE here, you need to provide the trace functions
-- as params OR provide a record of trace functions.
daedalusIPC
    :: Int
    -- ^ Port number to send to Daedalus
    -> IO ()
daedalusIPC :: Int -> IO ()
daedalusIPC Int
port = IO (Either NodeChannelError NodeChannel)
setupNodeChannel IO (Either NodeChannelError NodeChannel)
-> (Either NodeChannelError NodeChannel -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right NodeChannel
chan -> do
        Text -> IO ()
putTextLn Text
"Daedalus IPC server starting"
        (Either Text MsgIn -> IO (Maybe MsgOut))
-> ((MsgOut -> IO ()) -> IO ())
-> NodeChannel
-> IO (Either NodeChannelFinished ())
forall msgin msgout a.
(FromJSON msgin, ToJSON msgout) =>
(Either Text msgin -> IO (Maybe msgout))
-> ((msgout -> IO ()) -> IO a)
-> NodeChannel
-> IO (Either NodeChannelFinished a)
runNodeChannel (Maybe MsgOut -> IO (Maybe MsgOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe MsgOut -> IO (Maybe MsgOut))
-> (Either Text MsgIn -> Maybe MsgOut)
-> Either Text MsgIn
-> IO (Maybe MsgOut)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either Text MsgIn -> Maybe MsgOut
msg) (MsgOut -> IO ()) -> IO ()
action NodeChannel
chan IO (Either NodeChannelFinished ())
-> (Either NodeChannelFinished () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left (NodeChannelFinished IOError
err) ->
                Text -> IO ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Daedalus IPC finished for this reason: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOError -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show IOError
err
            Right () -> Text -> IO ()
putTextLn Text
"Unreachable code"
    Left NodeChannelError
NodeChannelDisabled -> do
        Text -> IO ()
putTextLn Text
"Daedalus IPC is not enabled."
        IO ()
forall b. IO b
sleep
    Left (NodeChannelBadFD Text
err) ->
        Text -> IO ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Problem starting Daedalus IPC: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Text
err
  where
    -- How to respond to an incoming message, or when there is an incoming
    -- message that couldn't be parsed.
    msg :: Either Text MsgIn -> Maybe MsgOut
msg (Right MsgIn
QueryPort) = MsgOut -> Maybe MsgOut
forall a. a -> Maybe a
Just (Int -> MsgOut
ReplyPort Int
port)
    msg (Left Text
e)          = MsgOut -> Maybe MsgOut
forall a. a -> Maybe a
Just (Text -> MsgOut
ParseError Text
e)

    -- What to do in context of runNodeChannel
    action :: (MsgOut -> IO ()) -> IO ()
    action :: (MsgOut -> IO ()) -> IO ()
action MsgOut -> IO ()
send = MsgOut -> IO ()
send MsgOut
Started IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall b. IO b
sleep

    sleep :: IO b
sleep = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound