{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
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)
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)
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 ]
daedalusIPC
:: Int
-> 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
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)
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