Skip to content
Permalink
Browse files

wip nextBlocks

  • Loading branch information...
Anviking committed Jun 12, 2019
1 parent b01eca7 commit 1ac2eca1c17f704a64db7e7d2e3313d281a43378
Showing with 31 additions and 6 deletions.
  1. +31 −6 lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs
@@ -41,17 +41,20 @@ import Cardano.Wallet.Network
, NetworkLayer (..)
)
import Cardano.Wallet.Primitive.Types
( Block (..), Hash (..) )
( Block (..), BlockHeader (..), Hash (..) )
import Control.Arrow
( left )
import Control.Exception
( Exception )
import Control.Monad
( forM )
import Control.Monad.Catch
( throwM )
import Control.Monad.Trans.Except
( ExceptT (..), withExceptT )
import Data.Proxy
( Proxy (..) )
import Debug.Trace
import Network.HTTP.Client
( Manager, defaultManagerSettings, newManager )
import Network.HTTP.Types.Status
@@ -79,14 +82,19 @@ import qualified Data.Text as T
newNetworkLayer
:: forall n. ()
=> BaseUrl
-> (Block, Hash "BlockHeader")
-> IO (NetworkLayer (Jormungandr n) IO)
newNetworkLayer url = do
newNetworkLayer url (block0, block0Hash) = do
mgr <- newManager defaultManagerSettings
return $ mkNetworkLayer $ mkJormungandrLayer mgr url
return $ mkNetworkLayer (mkJormungandrLayer mgr url) (block0, block0Hash)

-- | Wrap a Jormungandr client into a 'NetworkLayer' common interface.
mkNetworkLayer :: Monad m => JormungandrLayer m -> NetworkLayer t m
mkNetworkLayer j = NetworkLayer
mkNetworkLayer
:: Monad m
=> JormungandrLayer m
-> (Block, Hash "BlockHeader")
-> NetworkLayer t m
mkNetworkLayer j (block0, block0Hash) = NetworkLayer
{ networkTip = do
t <- (getTipId j) `mappingError`
ErrNetworkTipNetworkUnreachable
@@ -97,12 +105,29 @@ mkNetworkLayer j = NetworkLayer
ErrNetworkTipNetworkUnreachable e
return $ header b

, nextBlocks = error "nextBlocks to be implemented"
, nextBlocks = \tipHeader ->
if tipHeader == header block0
then getBlocksAfter block0Hash
else tail <$> getBlocksAfter (prevBlockHash tipHeader)



, postTx = error "postTx to be implemented"
}
where
mappingError = flip withExceptT

getBlocksAfter blockHeader = do
let count = 10000
ids <- getDescendantIds j blockHeader count `mappingError` \case
ErrGetDescendantsNetworkUnreachable e ->
ErrGetBlockNetworkUnreachable e
ErrGetDescendantsParentNotFound e ->
ErrGetBlockNotFound . T.pack . show $ e
forM ids getBlock'
where
getBlock' = trace ("getting " <> show blockHeader ) $ getBlock j

{-------------------------------------------------------------------------------
Jormungandr Client
-------------------------------------------------------------------------------}

0 comments on commit 1ac2eca

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