Skip to content
Permalink
Browse files

wire up jörmungandrl postSignedTx

  • Loading branch information...
Anviking committed Jun 16, 2019
1 parent 712b1e7 commit a853362b68b2d2db89882dafe1e49f5aa952aa38
@@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

@@ -23,7 +24,7 @@ module Cardano.Wallet.Jormungandr.Api
import Prelude

import Cardano.Wallet.Jormungandr.Binary
( FromBinary (..), runGet )
( FromBinary (..), ToBinary (..), runGet, runPut )
import Cardano.Wallet.Primitive.Types
( Block, Hash (..), Tx, TxWitness )
import Data.Binary.Get
@@ -40,6 +41,7 @@ import Servant.API
, Accept (..)
, Capture
, Get
, MimeRender (..)
, MimeUnrender (..)
, NoContent
, Post
@@ -55,7 +57,7 @@ import qualified Servant.API.ContentTypes as Servant
api :: Proxy Api
api = Proxy

type Api = GetTipId :<|> GetBlock :<|> GetBlockDescendantIds
type Api = GetTipId :<|> GetBlock :<|> GetBlockDescendantIds :<|> PostSignedTx


-- | Retrieve a block by its id.
@@ -122,6 +124,9 @@ instance Accept JormungandrBinary where
instance FromBinary a => MimeUnrender JormungandrBinary a where
mimeUnrender _ bs = Right $ runGet get bs

instance forall a. ToBinary a => MimeRender JormungandrBinary a where
mimeRender _ a = runPut $ put a

data Hex

-- | Represents data rendered to hexadecimal text.
@@ -1,5 +1,6 @@
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
@@ -33,6 +34,7 @@ module Cardano.Wallet.Jormungandr.Binary

-- * Classes
, FromBinary (..)
, ToBinary (..)

-- * Legacy Decoders
, decodeLegacyAddress
@@ -485,6 +487,13 @@ instance FromBinary W.Block where
instance FromBinary a => FromBinary [a] where
get = whileM (not <$> isEmpty) get


class ToBinary a where
put :: a -> Put

instance ToBinary (Tx, [TxWitness]) where
put = putTransaction

{-------------------------------------------------------------------------------
Legacy Decoders
-------------------------------------------------------------------------------}
@@ -34,17 +34,24 @@ module Cardano.Wallet.Jormungandr.Network
import Prelude

import Cardano.Wallet.Jormungandr.Api
( BlockId (..), GetBlock, GetBlockDescendantIds, GetTipId, api )
( BlockId (..)
, GetBlock
, GetBlockDescendantIds
, GetTipId
, PostSignedTx
, api
)
import Cardano.Wallet.Jormungandr.Compatibility
( Jormungandr )
import Cardano.Wallet.Network
( ErrGetBlock (..)
, ErrNetworkTip (..)
, ErrNetworkUnreachable (..)
, ErrPostTx (..)
, NetworkLayer (..)
)
import Cardano.Wallet.Primitive.Types
( Block (..), BlockHeader (..), Hash (..) )
( Block (..), BlockHeader (..), Hash (..), Tx (..), TxWitness (..) )
import Control.Arrow
( left )
import Control.Exception
@@ -60,7 +67,7 @@ import Data.Proxy
import Network.HTTP.Client
( Manager, defaultManagerSettings, newManager )
import Network.HTTP.Types.Status
( status400 )
( status400, status500 )
import Servant.API
( (:<|>) (..) )
import Servant.Client
@@ -69,6 +76,7 @@ import Servant.Client
, Scheme (..)
, client
, mkClientEnv
, responseBody
, responseStatusCode
, runClientM
)
@@ -77,6 +85,9 @@ import Servant.Client.Core
import Servant.Links
( Link, safeLink )

import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Encoding as T

-- | Creates a new 'NetworkLayer' connecting to an underlying 'Jormungandr'
-- backend target.
newNetworkLayer
@@ -138,6 +149,9 @@ data JormungandrLayer m = JormungandrLayer
:: Hash "BlockHeader"
-> Word
-> ExceptT ErrGetDescendants m [Hash "BlockHeader"]
, postSignedTx
:: (Tx, [TxWitness])
-> ExceptT ErrPostTx m ()
}

-- | Construct a 'JormungandrLayer'-client
@@ -185,6 +199,20 @@ mkJormungandrLayer mgr baseUrl = JormungandrLayer
(BlockId parentId)
(Just count)
left ErrGetDescendantsNetworkUnreachable <$> defaultHandler ctx x
, postSignedTx = \tx -> ExceptT $ do
let e0 = "?"
run (const () <$> cPostSignedTx tx) >>= \case
Left (FailureResponse e)
| responseStatusCode e == status400 -> do
let msg = T.decodeUtf8 $ BL.toStrict $ responseBody e
return $ Left $ ErrPostTxBadRequest msg
Left (FailureResponse e)
| responseStatusCode e == status500 && responseBody e == e0 -> do
let msg = T.decodeUtf8 $ BL.toStrict $ responseBody e
return $ Left $ ErrPostTxProtocolFailure msg
x -> do
let ctx = safeLink api (Proxy @PostSignedTx)
left ErrPostTxNetworkUnreachable <$> defaultHandler ctx x
}
where
run :: ClientM a -> IO (Either ServantError a)
@@ -211,6 +239,7 @@ mkJormungandrLayer mgr baseUrl = JormungandrLayer
cGetTipId
:<|> cGetBlock
:<|> cGetBlockDescendantIds
:<|> cPostSignedTx
= client api

data ErrUnexpectedNetworkFailure

0 comments on commit a853362

Please sign in to comment.
You can’t perform that action at this time.