{-# LANGUAGE UndecidableInstances #-}

module Hydra.Client where

import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Control.Concurrent.Async (link)
import Control.Concurrent.Class.MonadSTM (newTBQueueIO, readTBQueue, writeTBQueue)
import Control.Exception (Handler (Handler), IOException, catches)
import Data.Aeson (eitherDecodeStrict, encode)
import Hydra.API.ClientInput (ClientInput)
import Hydra.API.HTTPServer (DraftCommitTxRequest (..), DraftCommitTxResponse (..))
import Hydra.API.ServerOutput (TimedServerOutput)
import Hydra.Cardano.Api.Prelude (
  AsType (AsPaymentKey, AsSigningKey),
  PaymentKey,
  SigningKey,
 )
import Hydra.Cardano.Api.Tx (signTx)
import Hydra.Chain.CardanoClient (submitTransaction)
import Hydra.Chain.Direct.Util (readFileTextEnvelopeThrow)
import Hydra.Ledger.Cardano (Tx)
import Hydra.Network (Host (Host, hostname, port))
import Hydra.TUI.Options (Options (..))
import Network.HTTP.Req (defaultHttpConfig, responseBody, runReq)
import Network.HTTP.Req qualified as Req
import Network.WebSockets (ConnectionException, receiveData, runClient, sendBinaryData)

data HydraEvent tx
  = ClientConnected
  | ClientDisconnected
  | Update (TimedServerOutput tx)
  | Tick UTCTime
  deriving stock ((forall x. HydraEvent tx -> Rep (HydraEvent tx) x)
-> (forall x. Rep (HydraEvent tx) x -> HydraEvent tx)
-> Generic (HydraEvent tx)
forall x. Rep (HydraEvent tx) x -> HydraEvent tx
forall x. HydraEvent tx -> Rep (HydraEvent tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (HydraEvent tx) x -> HydraEvent tx
forall tx x. HydraEvent tx -> Rep (HydraEvent tx) x
$cfrom :: forall tx x. HydraEvent tx -> Rep (HydraEvent tx) x
from :: forall x. HydraEvent tx -> Rep (HydraEvent tx) x
$cto :: forall tx x. Rep (HydraEvent tx) x -> HydraEvent tx
to :: forall x. Rep (HydraEvent tx) x -> HydraEvent tx
Generic)

deriving stock instance Eq (TimedServerOutput tx) => Eq (HydraEvent tx)
deriving stock instance Show (TimedServerOutput tx) => Show (HydraEvent tx)

-- | Handle to interact with Hydra node
data Client tx m = Client
  { forall tx (m :: * -> *). Client tx m -> ClientInput tx -> m ()
sendInput :: ClientInput tx -> m ()
  -- ^ Send some input to the server.
  , forall tx (m :: * -> *). Client tx m -> SigningKey PaymentKey
sk :: SigningKey PaymentKey
  , forall tx (m :: * -> *). Client tx m -> UTxO -> m ()
externalCommit :: UTxO.UTxO -> m ()
  }

-- | Callback for receiving server outputs.
type ClientCallback tx m = HydraEvent tx -> m ()

-- | A type tying both receiving output and sending input into a /Component/.
type ClientComponent tx m a = ClientCallback tx m -> (Client tx m -> m a) -> m a

-- | Provide a component to interact with Hydra node.
withClient ::
  (ToJSON (ClientInput tx), FromJSON (TimedServerOutput tx)) =>
  Options ->
  ClientComponent tx IO a
withClient :: forall tx a.
(ToJSON (ClientInput tx), FromJSON (TimedServerOutput tx)) =>
Options -> ClientComponent tx IO a
withClient Options{hydraNodeHost :: Options -> Host
hydraNodeHost = Host{Text
$sel:hostname:Host :: Host -> Text
hostname :: Text
hostname, PortNumber
$sel:port:Host :: Host -> PortNumber
port :: PortNumber
port}, String
cardanoSigningKey :: String
cardanoSigningKey :: Options -> String
cardanoSigningKey, NetworkId
cardanoNetworkId :: NetworkId
cardanoNetworkId :: Options -> NetworkId
cardanoNetworkId, SocketPath
cardanoNodeSocket :: SocketPath
cardanoNodeSocket :: Options -> SocketPath
cardanoNodeSocket} ClientCallback tx IO
callback Client tx IO -> IO a
action = do
  SigningKey PaymentKey
sk <- IO (SigningKey PaymentKey)
readExternalSk
  TBQueue (ClientInput tx)
q <- Natural -> IO (TBQueue IO (ClientInput tx))
forall a. Natural -> IO (TBQueue IO a)
forall (m :: * -> *) a. MonadSTM m => Natural -> m (TBQueue m a)
newTBQueueIO Natural
10
  IO () -> (Async IO () -> IO a) -> IO a
forall a b. IO a -> (Async IO a -> IO b) -> IO b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (IO () -> IO ()
reconnect (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (ClientInput tx) -> IO ()
client TBQueue (ClientInput tx)
q) ((Async IO () -> IO a) -> IO a) -> (Async IO () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Async IO ()
thread -> do
    -- NOTE(SN): if message formats are not compatible, this will terminate the TUI
    -- with a quite cryptic message (to users)
    Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
Async IO ()
thread -- Make sure it does not silently die
    Client tx IO -> IO a
action (Client tx IO -> IO a) -> Client tx IO -> IO a
forall a b. (a -> b) -> a -> b
$
      Client
        { sendInput :: ClientInput tx -> IO ()
sendInput = STM () -> IO ()
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM () -> IO ())
-> (ClientInput tx -> STM ()) -> ClientInput tx -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue IO (ClientInput tx) -> ClientInput tx -> STM IO ()
forall a. TBQueue IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> a -> STM m ()
writeTBQueue TBQueue (ClientInput tx)
TBQueue IO (ClientInput tx)
q
        , SigningKey PaymentKey
sk :: SigningKey PaymentKey
sk :: SigningKey PaymentKey
sk
        , externalCommit :: UTxO -> IO ()
externalCommit = SigningKey PaymentKey -> UTxO -> IO ()
externalCommit' SigningKey PaymentKey
sk
        }
 where
  readExternalSk :: IO (SigningKey PaymentKey)
readExternalSk = AsType (SigningKey PaymentKey)
-> String -> IO (SigningKey PaymentKey)
forall a. HasTextEnvelope a => AsType a -> String -> IO a
readFileTextEnvelopeThrow (AsType PaymentKey -> AsType (SigningKey PaymentKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType PaymentKey
AsPaymentKey) String
cardanoSigningKey
  -- TODO(SN): ping thread?
  client :: TBQueue (ClientInput tx) -> IO ()
client TBQueue (ClientInput tx)
q = String -> Int -> String -> ClientApp () -> IO ()
forall a. String -> Int -> String -> ClientApp a -> IO a
runClient (Text -> String
forall a. ToString a => a -> String
toString Text
hostname) (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port) String
"/" (ClientApp () -> IO ()) -> ClientApp () -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
con -> do
    -- REVIEW(SN): is sharing the 'con' fine?
    ClientCallback tx IO
callback HydraEvent tx
forall tx. HydraEvent tx
ClientConnected
    IO Any -> IO Any -> IO ()
forall a b. IO a -> IO b -> IO ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
race_ (Connection -> IO Any
receiveOutputs Connection
con) (TBQueue (ClientInput tx) -> Connection -> IO Any
forall {a} {b}. ToJSON a => TBQueue a -> Connection -> IO b
sendInputs TBQueue (ClientInput tx)
q Connection
con)

  receiveOutputs :: Connection -> IO Any
receiveOutputs Connection
con = IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
    ByteString
msg <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
con
    case ByteString -> Either String (TimedServerOutput tx)
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict ByteString
msg of
      Right TimedServerOutput tx
output -> ClientCallback tx IO
callback ClientCallback tx IO -> ClientCallback tx IO
forall a b. (a -> b) -> a -> b
$ TimedServerOutput tx -> HydraEvent tx
forall tx. TimedServerOutput tx -> HydraEvent tx
Update TimedServerOutput tx
output
      Left String
err -> ClientError -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ClientError -> IO ()) -> ClientError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> ClientError
ClientJSONDecodeError String
err ByteString
msg

  sendInputs :: TBQueue a -> Connection -> IO b
sendInputs TBQueue a
q Connection
con = 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
$ do
    a
input <- STM IO a -> IO a
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO a -> IO a) -> STM IO a -> IO a
forall a b. (a -> b) -> a -> b
$ TBQueue IO a -> STM IO a
forall a. TBQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> STM m a
readTBQueue TBQueue a
TBQueue IO a
q
    Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
con (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
input

  reconnect :: IO () -> IO ()
reconnect IO ()
f =
    IO ()
f
      IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`catches` [ (IOException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOException -> IO ()) -> Handler ())
-> (IOException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(IOException
_ :: IOException) -> IO () -> IO ()
handleDisconnect IO ()
f -- Initially
                , (ConnectionException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ConnectionException -> IO ()) -> Handler ())
-> (ConnectionException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(ConnectionException
_ :: ConnectionException) -> IO () -> IO ()
handleDisconnect IO ()
f -- Later
                ]

  handleDisconnect :: IO () -> IO ()
handleDisconnect IO ()
f =
    ClientCallback tx IO
callback HydraEvent tx
forall tx. HydraEvent tx
ClientDisconnected IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO ()
reconnect IO ()
f

  externalCommit' :: SigningKey PaymentKey -> UTxO -> IO ()
externalCommit' SigningKey PaymentKey
sk UTxO
payload =
    HttpConfig
-> Req (JsonResponse (DraftCommitTxResponse Tx))
-> IO (JsonResponse (DraftCommitTxResponse Tx))
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig Req (JsonResponse (DraftCommitTxResponse Tx))
request
      IO (JsonResponse (DraftCommitTxResponse Tx))
-> (JsonResponse (DraftCommitTxResponse Tx)
    -> DraftCommitTxResponse Tx)
-> IO (DraftCommitTxResponse Tx)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> JsonResponse (DraftCommitTxResponse Tx) -> DraftCommitTxResponse Tx
JsonResponse (DraftCommitTxResponse Tx)
-> HttpResponseBody (JsonResponse (DraftCommitTxResponse Tx))
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody
        IO (DraftCommitTxResponse Tx)
-> (DraftCommitTxResponse Tx -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DraftCommitTxResponse{Tx
commitTx :: Tx
$sel:commitTx:DraftCommitTxResponse :: forall tx. DraftCommitTxResponse tx -> tx
commitTx} ->
          NetworkId -> SocketPath -> Tx -> IO ()
submitTransaction NetworkId
cardanoNetworkId SocketPath
cardanoNodeSocket (Tx -> IO ()) -> Tx -> IO ()
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
sk Tx
commitTx
   where
    request :: Req (JsonResponse (DraftCommitTxResponse Tx))
request =
      POST
-> Url 'Http
-> ReqBodyJson (DraftCommitTxRequest Tx)
-> Proxy (JsonResponse (DraftCommitTxResponse Tx))
-> Option 'Http
-> Req (JsonResponse (DraftCommitTxResponse Tx))
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
Req.req
        POST
Req.POST
        (Text -> Url 'Http
Req.http Text
hostname Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"commit")
        (DraftCommitTxRequest Tx -> ReqBodyJson (DraftCommitTxRequest Tx)
forall a. a -> ReqBodyJson a
Req.ReqBodyJson (DraftCommitTxRequest Tx -> ReqBodyJson (DraftCommitTxRequest Tx))
-> DraftCommitTxRequest Tx -> ReqBodyJson (DraftCommitTxRequest Tx)
forall a b. (a -> b) -> a -> b
$ forall tx. UTxOType tx -> DraftCommitTxRequest tx
SimpleCommitRequest @Tx UTxO
UTxOType Tx
payload)
        Proxy (JsonResponse (DraftCommitTxResponse Tx))
forall a. Proxy (JsonResponse a)
Req.jsonResponse
        (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
Req.port (Int -> Option 'Http) -> Int -> Option 'Http
forall a b. (a -> b) -> a -> b
$ PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port)

data ClientError = ClientJSONDecodeError String ByteString
  deriving stock (ClientError -> ClientError -> Bool
(ClientError -> ClientError -> Bool)
-> (ClientError -> ClientError -> Bool) -> Eq ClientError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientError -> ClientError -> Bool
== :: ClientError -> ClientError -> Bool
$c/= :: ClientError -> ClientError -> Bool
/= :: ClientError -> ClientError -> Bool
Eq, Int -> ClientError -> ShowS
[ClientError] -> ShowS
ClientError -> String
(Int -> ClientError -> ShowS)
-> (ClientError -> String)
-> ([ClientError] -> ShowS)
-> Show ClientError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientError -> ShowS
showsPrec :: Int -> ClientError -> ShowS
$cshow :: ClientError -> String
show :: ClientError -> String
$cshowList :: [ClientError] -> ShowS
showList :: [ClientError] -> ShowS
Show, (forall x. ClientError -> Rep ClientError x)
-> (forall x. Rep ClientError x -> ClientError)
-> Generic ClientError
forall x. Rep ClientError x -> ClientError
forall x. ClientError -> Rep ClientError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ClientError -> Rep ClientError x
from :: forall x. ClientError -> Rep ClientError x
$cto :: forall x. Rep ClientError x -> ClientError
to :: forall x. Rep ClientError x -> ClientError
Generic)
  deriving anyclass (Show ClientError
Typeable ClientError
(Typeable ClientError, Show ClientError) =>
(ClientError -> SomeException)
-> (SomeException -> Maybe ClientError)
-> (ClientError -> String)
-> Exception ClientError
SomeException -> Maybe ClientError
ClientError -> String
ClientError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ClientError -> SomeException
toException :: ClientError -> SomeException
$cfromException :: SomeException -> Maybe ClientError
fromException :: SomeException -> Maybe ClientError
$cdisplayException :: ClientError -> String
displayException :: ClientError -> String
Exception)