Reorganize some definitions
Create Type/Query.purs with FFI module
Create Type/Query.purs with FFI module
import Prelude
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader.Trans (ReaderT, ask)
import Data.Argonaut as Json
import Data.Either(Either(..), either, isRight)
import Data.Foldable (foldl)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Control.Monad.Reader.Trans (ask)
import Data.Either (Either(..))
import Effect (Effect)
import Effect.Aff (Aff, Canceler(..), makeAff)
import Effect.Aff (Canceler(..), makeAff)
import Effect.Aff.Class (liftAff)
import Effect.Class (liftEffect)
import Effect.Console (log)
import Effect.Exception (Error, error)
import Effect.Ref as Ref
import Types.JsonWsp (Address, JsonWspResponse, UtxoQR, mkUtxosAtQuery, parseJsonWspResponse)
import Effect.Exception (Error)
import Types.JsonWsp (Address, UtxoQR, mkUtxosAtQuery)
import Types.Query
( QueryM
, _stringify
, _wsSend
, listeners
, underlyingWebSocket
)
-- This module defines an Aff interface for Ogmios Websocket Queries
-- Since WebSockets do not define a mechanism for linking request/response
-- Or for verifying that the connection is live, those concerns are addressed
-- here
--------------------------------------------------------------------------------
-- Websocket Basics
--------------------------------------------------------------------------------
foreign import _mkWebSocket :: Url -> Effect WebSocket
foreign import _onWsConnect :: WebSocket -> (Effect Unit) -> Effect Unit
foreign import _onWsMessage :: WebSocket -> (String -> Effect Unit) -> Effect Unit
foreign import _onWsError :: WebSocket -> (String -> Effect Unit) -> Effect Unit
foreign import _wsSend :: WebSocket -> String -> Effect Unit
foreign import _wsClose :: WebSocket -> Effect Unit
foreign import _stringify :: forall a. a -> Effect String
foreign import _wsWatch :: WebSocket -> Effect Unit -> Effect Unit
data WebSocket
type Url = String
--------------------------------------------------------------------------------
-- Queries
--------------------------------------------------------------------------------
-- when we add multiple query backends or wallets,
-- we just need to extend this type
type QueryConfig = { ws :: OgmiosWebSocket }
type QueryM a = ReaderT QueryConfig Aff a
-- the first query type in the QueryM/Aff interface
utxosAt :: Address -> QueryM UtxoQR
utxosAt addr = do
body <- liftEffect $ mkUtxosAtQuery { utxo: [ addr ] }
let id = body.mirror.id
let
id = body.mirror.id
sBody <- liftEffect $ _stringify body
config <- ask
-- not sure there's an easy way to factor this out unfortunately
let
let
affFunc :: (Either Error UtxoQR -> Effect Unit) -> Effect Canceler
affFunc cont = do
let
affFunc cont = do
let
ls = listeners config.ws
ws = underlyingWebSocket config.ws
ls.utxo.addMessageListener id
(\result -> do
ls.utxo.removeMessageListener id
(allowError cont) $ result
)
ls.utxo.addMessageListener id
$ \result -> do
ls.utxo.removeMessageListener id
(allowError cont) $ result
_wsSend ws sBody
pure $ Canceler $ \err -> do
liftEffect $ ls.utxo.removeMessageListener id
liftEffect $ throwError $ err
pure $ Canceler
$ \err -> do
liftEffect $ ls.utxo.removeMessageListener id
liftEffect $ throwError $ err
liftAff $ makeAff $ affFunc
allowError :: (Either Error UtxoQR -> Effect Unit) -> UtxoQR -> Effect Unit
allowError func = func <<< Right
--------------------------------------------------------------------------------
-- OgmiosWebSocket Setup and PrimOps
--------------------------------------------------------------------------------
-- don't export this constructor
-- type-safe websocket which has automated req/res dispatch and websocket
-- failure handling
data OgmiosWebSocket = OgmiosWebSocket WebSocket Listeners
-- smart-constructor for OgmiosWebSocket in Aff Context
-- (prevents sending messages before the websocket opens, etc)
mkOgmiosWebSocket'
:: Url
-> (Either Error OgmiosWebSocket -> Effect Unit)
-> Effect Canceler
mkOgmiosWebSocket' url cb = do
utxoQueryDispatchIdMap <- createMutableDispatch
let md = (messageDispatch utxoQueryDispatchIdMap)
ws <- _mkWebSocket url
_onWsConnect ws $ do
_wsWatch ws (removeAllListeners utxoQueryDispatchIdMap)
_onWsMessage ws (defaultMessageListener md)
_onWsError ws defaultErrorListener
cb $ Right $ OgmiosWebSocket ws { utxo: mkListenerSet utxoQueryDispatchIdMap }
pure $ Canceler $ \err -> liftEffect $ cb $ Left $ err
-- makeAff
-- :: forall a
-- . ((Either Error a -> Effect Unit) -> Effect Canceler)
-- -> Aff a
mkOgmiosWebSocketAff :: Url -> Aff OgmiosWebSocket
mkOgmiosWebSocketAff url = makeAff (mkOgmiosWebSocket' url)
-- getter
underlyingWebSocket :: OgmiosWebSocket -> WebSocket
underlyingWebSocket (OgmiosWebSocket ws _) = ws
-- getter
listeners :: OgmiosWebSocket -> Listeners
listeners (OgmiosWebSocket _ ls) = ls
-- interface required for adding/removing listeners
type Listeners =
{ utxo :: ListenerSet UtxoQR
}
-- convenience type for adding additional query types later
type ListenerSet a =
{ addMessageListener :: String -> (a -> Effect Unit) -> Effect Unit
, removeMessageListener :: String -> Effect Unit
, dispatchIdMap :: DispatchIdMap a
}
-- we manipluate closures to make the DispatchIdMap updateable using these
-- methods, this can be picked up by a query or cancellation function
mkListenerSet :: forall a. DispatchIdMap a -> ListenerSet a
mkListenerSet dim =
{ addMessageListener:
\id -> \func -> do
idMap <- Ref.read dim
Ref.write (Map.insert id func idMap) dim
, removeMessageListener:
\id -> do
idMap <- Ref.read dim
Ref.write (Map.delete id idMap) dim
, dispatchIdMap: dim
}
removeAllListeners :: DispatchIdMap UtxoQR -> Effect Unit
removeAllListeners dim = do
log "error hit, removing all listeners"
Ref.write Map.empty dim
-------------------------------------------------------------------------------
-- Dispatch Setup
--------------------------------------------------------------------------------
-- A function which accepts some unparsed Json, and checks it against one or
-- more possible types to perform an appropriate effect (such as supplying the
-- parsed result to an async fiber/Aff listener)
type WebsocketDispatch = String -> Effect (Either Json.JsonDecodeError (Effect Unit))
-- A mutable queue of requests
type DispatchIdMap a = Ref.Ref (Map.Map String (a -> Effect Unit))
-- an immutable queue of response type handlers
messageDispatch :: DispatchIdMap UtxoQR -> Array WebsocketDispatch
module Types.Query
( QueryConfig
, QueryM
, Url
, WebSocket
, OgmiosWebSocket
, _stringify
, _wsSend
, listeners
, underlyingWebSocket
, mkOgmiosWebSocketAff
) where
import Prelude
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader.Trans (ReaderT)
import Data.Argonaut as Json
import Data.Either (Either(..), either, isRight)
import Data.Foldable (foldl)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Aff (Aff, Canceler(..), makeAff)
import Effect.Class (liftEffect)
import Effect.Console (log)
import Effect.Exception (Error, error)
import Effect.Ref as Ref
import Types.JsonWsp
( JsonWspResponse
, UtxoQR
, parseJsonWspResponse
)
-------------------------------------------------------------------------------
-- Query types
-------------------------------------------------------------------------------
-- when we add multiple query backends or wallets,
-- we just need to extend this type
type QueryConfig
= { ws :: OgmiosWebSocket }
type QueryM a
= ReaderT QueryConfig Aff a
--------------------------------------------------------------------------------
-- Websocket Basics
--------------------------------------------------------------------------------
foreign import _mkWebSocket :: Url -> Effect WebSocket
foreign import _onWsConnect :: WebSocket -> (Effect Unit) -> Effect Unit
foreign import _onWsMessage ::
WebSocket ->
(String -> Effect Unit) ->
Effect Unit
foreign import _onWsError :: WebSocket -> (String -> Effect Unit) -> Effect Unit
foreign import _wsSend :: WebSocket -> String -> Effect Unit
foreign import _wsClose :: WebSocket -> Effect Unit
foreign import _stringify :: forall a. a -> Effect String
foreign import _wsWatch :: WebSocket -> Effect Unit -> Effect Unit
data WebSocket
type Url
= String
--------------------------------------------------------------------------------
-- OgmiosWebSocket Setup and PrimOps
--------------------------------------------------------------------------------
-- don't export this constructor
-- type-safe websocket which has automated req/res dispatch and websocket
-- failure handling
data OgmiosWebSocket
= OgmiosWebSocket WebSocket Listeners
-- smart-constructor for OgmiosWebSocket in Aff Context
-- (prevents sending messages before the websocket opens, etc)
mkOgmiosWebSocket' ::
Url ->
(Either Error OgmiosWebSocket -> Effect Unit) ->
Effect Canceler
mkOgmiosWebSocket' url cb = do
utxoQueryDispatchIdMap <- createMutableDispatch
let
md = (messageDispatch utxoQueryDispatchIdMap)
ws <- _mkWebSocket url
_onWsConnect ws
$ do
_wsWatch ws (removeAllListeners utxoQueryDispatchIdMap)
_onWsMessage ws (defaultMessageListener md)
_onWsError ws defaultErrorListener
cb $ Right $ OgmiosWebSocket ws { utxo: mkListenerSet utxoQueryDispatchIdMap }
pure $ Canceler $ \err -> liftEffect $ cb $ Left $ err
-- makeAff
-- :: forall a
-- . ((Either Error a -> Effect Unit) -> Effect Canceler)
-- -> Aff a
mkOgmiosWebSocketAff :: Url -> Aff OgmiosWebSocket
mkOgmiosWebSocketAff url = makeAff (mkOgmiosWebSocket' url)
-- getter
underlyingWebSocket :: OgmiosWebSocket -> WebSocket
underlyingWebSocket (OgmiosWebSocket ws _) = ws
-- getter
listeners :: OgmiosWebSocket -> Listeners
listeners (OgmiosWebSocket _ ls) = ls
-- interface required for adding/removing listeners
type Listeners
= { utxo :: ListenerSet UtxoQR
}
-- convenience type for adding additional query types later
type ListenerSet a
= { addMessageListener :: String -> (a -> Effect Unit) -> Effect Unit
, removeMessageListener :: String -> Effect Unit
, dispatchIdMap :: DispatchIdMap a
}
-- we manipluate closures to make the DispatchIdMap updateable using these
-- methods, this can be picked up by a query or cancellation function
mkListenerSet :: forall a. DispatchIdMap a -> ListenerSet a
mkListenerSet dim =
{ addMessageListener:
\id -> \func -> do
idMap <- Ref.read dim
Ref.write (Map.insert id func idMap) dim
, removeMessageListener:
\id -> do
idMap <- Ref.read dim
Ref.write (Map.delete id idMap) dim
, dispatchIdMap: dim
}
removeAllListeners :: DispatchIdMap UtxoQR -> Effect Unit
removeAllListeners dim = do
log "error hit, removing all listeners"
Ref.write Map.empty dim
-------------------------------------------------------------------------------
-- Dispatch Setup
--------------------------------------------------------------------------------
-- A function which accepts some unparsed Json, and checks it against one or
-- more possible types to perform an appropriate effect (such as supplying the
-- parsed result to an async fiber/Aff listener)
type WebsocketDispatch
= String -> Effect (Either Json.JsonDecodeError (Effect Unit))
-- A mutable queue of requests
type DispatchIdMap a
= Ref.Ref (Map.Map String (a -> Effect Unit))
-- an immutable queue of response type handlers
messageDispatch :: DispatchIdMap UtxoQR -> Array WebsocketDispatch
messageDispatch dim =
[ utxoQueryDispatch dim
]
-- each query type will have a corresponding ref that lives in ReaderT config or similar
-- for utxoQueryDispatch, the `a` parameter will be `UtxoQR` or similar
-- the add and remove listener functions will know to grab the correct mutable dispatch, if one exists.
createMutableDispatch :: forall a. Effect (DispatchIdMap a)
createMutableDispatch = Ref.new Map.empty
-- we parse out the utxo query result, then check if we're expecting a result
-- with the provided id, if we are then we dispatch to the effect that is
-- waiting on this result
utxoQueryDispatch ::
Ref.Ref (Map.Map String (UtxoQR -> Effect Unit)) ->
String ->
Effect (Either Json.JsonDecodeError (Effect Unit))
utxoQueryDispatch ref str = do
let
parsed' = parseJsonWspResponse =<< Json.parseJson str
case parsed' of
(Left err) -> pure $ Left err
(Right res) -> afterParse res
where
afterParse ::
JsonWspResponse UtxoQR ->
Effect (Either Json.JsonDecodeError (Effect Unit))
afterParse parsed = do
let
(id :: String) = parsed.reflection.id
idMap <- Ref.read ref
let
(mAction :: Maybe (UtxoQR -> Effect Unit)) = Map.lookup id idMap
case mAction of
Nothing ->
pure
$ ( Left
( Json.TypeMismatch
import Control.Monad.Reader.Trans (runReaderT)
import TestM (TestPlanM)
import Mote (group, test)
import Ogmios (mkOgmiosWebSocketAff, utxosAt)
import Ogmios (utxosAt)
import Types.Query (mkOgmiosWebSocketAff)
testnet_addr :: String
testnet_addr =
3852: cardano-tracer: init RTView r=deepfire a=denisshevchenko This is pre-MVP for RTView. 3880: Old peers tracing was erroneously called in new tracing r=deepfire a=jutaro /nix/store/qaplqccmisqy8n7ai65nssafzkxyyc7p-cabal-install-exe-cabal-3.6.2.0/bin/cabal --project-file=/home/deepfire/cardano-node/.nix-shell-cabal.project run exe:cardano-node -- +RTS -sghc-rts-report.txt -RTS run --config config.json --database-path run/current/node-0/db-testnet --topology topology.json --host-addr 127.0.0.1 --port 30000 --socket-path node.socket +RTS -N2 -I0 -A16m -qg -qb --disable-delayed-os-memory-return -RTS cardano-node: ExceptionInLinkedThread (ThreadId 11) The name ""peersFromNodeKernel"" is already taken by a metric. CallStack (from HasCallStack): error, called at ./System/Metrics.hs:214:5 in ekg-core-0.1.1.7-FjoslY1tzknIAl90c73kOZ:System.Metrics 3882: Fix datum in tx and ref scripts r=Jimbo4350 a=ch1bo (Couldn't reopen https://github.com/input-output-hk/cardano-node/pull/3881, so created this one) :snowflake: Add a roundtrip property `TxBodyContent -> TxBody -> TxBodyContent` This helped in fixing the :bug: and uncover the two additional gaps in the code. I'm not 100% happy with the current implementation of the property though! I needed to accept two exceptions to the general `===`: 1. `SimpleScriptV1` reference scripts may become `SimpleScriptV2` 2. A `TxOutDatumHash` + a matching `ScriptData` may become a `TxOutDatumTx` :snowflake: Resolve datum hash + matching datum in transaction to `TxOutDatumInTx`, fixes #3866 :snowflake: Add missing script languages to `scriptLanguageSupportedInEra` for `BabbageEra` :snowflake: Allow scripts in any language as refeference scripts Co-authored-by: Denis Shevchenko <[email protected]> Co-authored-by: Kosyrev Serge <[email protected]> Co-authored-by: Yupanqui <[email protected]> Co-authored-by: Sebastian Nagel <[email protected]>
- you're no exception, patroni!