{-# LANGUAGE UndecidableInstances #-}

module Hydra.Client where

import Hydra.Prelude

import Cardano.Binary (serialize')
import Control.Concurrent.Async (link)
import Control.Concurrent.Class.MonadSTM (readTBQueue, writeTBQueue)
import Control.Exception (Handler (Handler), IOException, catches)
import Data.Aeson (encode)
import Hydra.API.ClientInput (ClientInput)
import Hydra.API.HTTPServer (DraftCommitTxRequest (..), DraftCommitTxResponse (..))
import Hydra.API.ServerOutput (ApiEncoding (..), ApiMessage (..))
import Hydra.API.WireFormat (decodeWire)
import Hydra.Cardano.Api (TxId, UTxO)
import Hydra.Cardano.Api.Prelude (
  PaymentKey,
  SigningKey,
 )
import Hydra.Chain.Blockfrost.Client qualified as BF
import Hydra.Chain.CardanoClient (localNodeConnectInfo, submitTransaction)
import Hydra.Chain.ChainState (IsChainState)
import Hydra.Ledger.Cardano (Tx)
import Hydra.Network (Host (Host, hostname, port))
import Hydra.Node.Util (readFileTextEnvelopeThrow)
import Hydra.TUI.Options (Options (..))
import Hydra.Tx.Crypto (signTx)
import Hydra.Tx.Secret (Secret, mkSecret)
import Network.HTTP.Req (defaultHttpConfig, responseBody, runReq)
import Network.HTTP.Req qualified as Req
import Network.WebSockets (Connection, ConnectionException, receiveData, runClient, sendBinaryData)

data HydraEvent tx
  = ClientConnected
  | ClientDisconnected
  | Update (ApiMessage 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 IsChainState tx => Eq (HydraEvent tx)
deriving stock instance IsChainState 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 -> Secret (SigningKey PaymentKey)
sk :: Secret (SigningKey PaymentKey)
  , forall tx (m :: * -> *). Client tx m -> UTxO -> m ()
externalCommit :: UTxO -> m ()
  , forall tx (m :: * -> *). Client tx m -> TxId -> m ()
recoverCommit :: TxId -> 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 ::
  forall tx a.
  IsChainState tx =>
  Options ->
  ClientComponent tx IO a
withClient :: forall tx a. IsChainState 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
fundsSigningKey :: String
fundsSigningKey :: Options -> String
fundsSigningKey, NetworkId
cardanoNetworkId :: NetworkId
cardanoNetworkId :: Options -> NetworkId
cardanoNetworkId, Either String SocketPath
cardanoConnection :: Either String SocketPath
cardanoConnection :: Options -> Either String SocketPath
cardanoConnection, ApiEncoding
apiEncoding :: ApiEncoding
apiEncoding :: Options -> ApiEncoding
apiEncoding} ClientCallback tx IO
callback Client tx IO -> IO a
action = do
  Secret (SigningKey PaymentKey)
sk <- IO (Secret (SigningKey PaymentKey))
readExternalSk
  TBQueue (ClientInput tx)
q <- String -> Natural -> IO (TBQueue IO (ClientInput tx))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> Natural -> m (TBQueue m a)
newLabelledTBQueueIO String
"tui-client-queue" Natural
10
  (String, IO ()) -> (Async IO () -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"client-reconnect", 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 IO ()
Async ()
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
        , Secret (SigningKey PaymentKey)
sk :: Secret (SigningKey PaymentKey)
sk :: Secret (SigningKey PaymentKey)
sk
        , externalCommit :: UTxO -> IO ()
externalCommit = Secret (SigningKey PaymentKey) -> UTxO -> IO ()
externalCommit' Secret (SigningKey PaymentKey)
sk
        , recoverCommit :: TxId -> IO ()
recoverCommit = TxId -> IO ()
recoverCommit'
        }
 where
  readExternalSk :: IO (Secret (SigningKey PaymentKey))
readExternalSk = SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret (SigningKey PaymentKey -> Secret (SigningKey PaymentKey))
-> IO (SigningKey PaymentKey)
-> IO (Secret (SigningKey PaymentKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (SigningKey PaymentKey)
forall a. HasTextEnvelope a => String -> IO a
readFileTextEnvelopeThrow String
fundsSigningKey

  queryString :: String
queryString = case ApiEncoding
apiEncoding of
    ApiEncoding
JsonEncoding -> String
"/?history=yes"
    ApiEncoding
CborEncoding -> String
"/?history=yes&encoding=cbor"

  -- 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
queryString (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
    (String, IO Any) -> (String, IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (String, m b) -> m ()
raceLabelled_ (String
"receive-outputs", Connection -> IO Any
receiveOutputs Connection
con) (String
"send-inputs", TBQueue IO (ClientInput tx) -> ClientApp ()
sendInputs TBQueue (ClientInput tx)
TBQueue IO (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 ApiEncoding -> ByteString -> Either String (ApiMessage tx)
forall a.
(FromJSON a, FromCBOR a) =>
ApiEncoding -> ByteString -> Either String a
decodeWire ApiEncoding
apiEncoding (ByteString -> ByteString
forall l s. LazyStrict l s => s -> l
fromStrict ByteString
msg) :: Either String (ApiMessage tx) of
      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
      Right ApiMessage tx
output -> ClientCallback tx IO
callback ClientCallback tx IO -> ClientCallback tx IO
forall a b. (a -> b) -> a -> b
$ ApiMessage tx -> HydraEvent tx
forall tx. ApiMessage tx -> HydraEvent tx
Update ApiMessage tx
output

  sendInputs :: TBQueue IO (ClientInput tx) -> Connection -> IO ()
  sendInputs :: TBQueue IO (ClientInput tx) -> ClientApp ()
sendInputs TBQueue IO (ClientInput tx)
q Connection
con = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ClientInput tx
input <- STM IO (ClientInput tx) -> IO (ClientInput tx)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (ClientInput tx) -> IO (ClientInput tx))
-> STM IO (ClientInput tx) -> IO (ClientInput tx)
forall a b. (a -> b) -> a -> b
$ TBQueue IO (ClientInput tx) -> STM IO (ClientInput tx)
forall a. TBQueue IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> STM m a
readTBQueue TBQueue IO (ClientInput tx)
q
    case ApiEncoding
apiEncoding of
      ApiEncoding
JsonEncoding -> Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
con (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ClientInput tx -> ByteString
forall a. ToJSON a => a -> ByteString
encode ClientInput tx
input
      ApiEncoding
CborEncoding -> Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
con (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ClientInput tx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' ClientInput tx
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' :: Secret (SigningKey PaymentKey) -> UTxO -> IO ()
externalCommit' Secret (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} ->
          let tx :: Tx
tx =
                -- Don't sign the tx if there's nothing to commit (i.e. empty
                -- commit).
                if UTxO
payload UTxO -> UTxO -> Bool
forall a. Eq a => a -> a -> Bool
== UTxO
forall a. Monoid a => a
mempty
                  then Tx
commitTx
                  else Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
sk Tx
commitTx
           in case Either String SocketPath
cardanoConnection of
                Left String
bfProject -> do
                  Project
prj <- IO Project -> IO Project
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> IO Project) -> IO Project -> IO Project
forall a b. (a -> b) -> a -> b
$ String -> IO Project
BF.projectFromFile String
bfProject
                  IO TxHash -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO TxHash -> IO ()) -> IO TxHash -> IO ()
forall a b. (a -> b) -> a -> b
$ Project -> BlockfrostClientT IO TxHash -> IO TxHash
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
BF.runBlockfrostM Project
prj (BlockfrostClientT IO TxHash -> IO TxHash)
-> BlockfrostClientT IO TxHash -> IO TxHash
forall a b. (a -> b) -> a -> b
$ Tx -> BlockfrostClientT IO TxHash
forall (m :: * -> *). MonadIO m => Tx -> BlockfrostClientT m TxHash
BF.submitTransaction Tx
tx
                Right SocketPath
socketPath ->
                  LocalNodeConnectInfo -> Tx -> IO ()
submitTransaction (NetworkId -> SocketPath -> LocalNodeConnectInfo
localNodeConnectInfo NetworkId
cardanoNetworkId SocketPath
socketPath) Tx
tx
   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)

  recoverCommit' :: TxId -> IO ()
recoverCommit' TxId
txId =
    IO IgnoreResponse -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO IgnoreResponse -> IO ())
-> (Req IgnoreResponse -> IO IgnoreResponse)
-> Req IgnoreResponse
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpConfig -> Req IgnoreResponse -> IO IgnoreResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req IgnoreResponse -> IO ()) -> Req IgnoreResponse -> IO ()
forall a b. (a -> b) -> a -> b
$
      DELETE
-> Url 'Http
-> NoReqBody
-> Proxy IgnoreResponse
-> Option 'Http
-> Req IgnoreResponse
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
        DELETE
Req.DELETE
        (Text -> Url 'Http
Req.http Text
hostname Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"commits" Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: TxId -> Text
forall b a. (Show a, IsString b) => a -> b
show TxId
txId)
        NoReqBody
Req.NoReqBody
        Proxy IgnoreResponse
Req.ignoreResponse
        (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)