Jormungandr m with getTipId implementation

exe/wallet/Main.hs

@@ -51,6 +51,8 @@ import Cardano.Wallet.HttpBridge.Compatibility
     ( HttpBridge )
 import Cardano.Wallet.HttpBridge.Environment
     ( KnownNetwork (..), Network (..) )
+import Cardano.Wallet.Network
+    ( defaultRetryPolicy, waitForConnection )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( FromMnemonic (..), KeyToAddress, Passphrase (..) )
 import Cardano.Wallet.Primitive.Mnemonic
@@ -351,6 +353,7 @@ execHttpBridge args _ = do
         <- args `parseArg` longOption "bridge-port"
     db <- MVar.newDBLayer
     nw <- HttpBridge.newNetworkLayer @n bridgePort
+    waitForConnection nw defaultRetryPolicy
     let tl = HttpBridge.newTransactionLayer @n
     wallet <- newWalletLayer @_ @(HttpBridge n) db nw tl
     let settings = Warp.defaultSettings

lib/core/cardano-wallet-core.cabal

@@ -55,6 +55,7 @@ library
     , persistent-sqlite
     , persistent-template
     , resourcet
+    , retry
     , servant
     , servant-server
     , split

lib/core/src/Cardano/Wallet/Network.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -8,6 +9,10 @@ module Cardano.Wallet.Network
     -- * Interface
       NetworkLayer (..)
 
+    -- * Helpers
+    , waitForConnection
+    , defaultRetryPolicy
+
     -- * Errors
     , ErrNetworkUnreachable(..)
     , ErrNetworkTip(..)
@@ -19,14 +24,17 @@ import Prelude
 import Cardano.Wallet.Primitive.Types
     ( Block (..), BlockHeader (..), Hash (..), SlotId (..), Tx, TxWitness )
 import Control.Exception
-    ( Exception )
+    ( Exception, throwIO )
 import Control.Monad.Trans.Except
-    ( ExceptT )
+    ( ExceptT, runExceptT )
+import Control.Retry
 import Data.Text
     ( Text )
 import GHC.Generics
     ( Generic )
 
+import qualified Data.Text.IO as TIO
+
 data NetworkLayer t m = NetworkLayer
     { nextBlocks :: SlotId -> ExceptT ErrNetworkUnreachable m [Block]
         -- ^ Gets some blocks from the node. It will not necessarily return all
@@ -67,3 +75,31 @@ data ErrPostTx
     deriving (Generic, Show, Eq)
 
 instance Exception ErrPostTx
+
+-- | Wait until 'networkTip networkLayer' succeeds according to a given
+-- retry policy. Throws an exception otherwise.
+waitForConnection
+    :: NetworkLayer t IO
+    -> RetryPolicyM IO
+    -> IO ()
+waitForConnection nw policy = do
+    r <- retrying policy shouldRetry (const $ runExceptT (networkTip nw))
+    case r of
+        Right _ -> return ()
+        Left e -> throwIO e
+  where
+
+    shouldRetry _ = \case
+        Right _ -> do
+            return False
+        Left (ErrNetworkTipNetworkUnreachable _) -> do
+             TIO.putStrLn "[INFO] waiting for connection to the node..."
+             return True
+        Left _ -> return True
+
+defaultRetryPolicy :: Monad m => RetryPolicyM m
+defaultRetryPolicy =
+    limitRetriesByCumulativeDelay (20 * second)
+        (constantDelay (1 * second))
+  where
+    second = 1000*1000

lib/http-bridge/cardano-wallet-http-bridge.cabal

@@ -151,6 +151,7 @@ test-suite integration
     , http-types
     , memory
     , process
+    , retry
     , template-haskell
     , text
     , text-class

lib/http-bridge/test/integration/Cardano/Wallet/HttpBridge/NetworkSpec.hs

@@ -18,6 +18,8 @@ import Cardano.Wallet.Network
     , ErrNetworkUnreachable (..)
     , ErrPostTx (..)
     , NetworkLayer (..)
+    , defaultRetryPolicy
+    , waitForConnection
     )
 import Cardano.Wallet.Primitive.Types
     ( Address (..)
@@ -39,10 +41,20 @@ import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
     ( runExceptT, withExceptT )
+import Control.Retry
+    ( constantDelay, limitRetries )
 import Data.Text.Class
     ( toText )
 import Test.Hspec
-    ( Spec, afterAll, beforeAll, describe, it, shouldReturn, shouldSatisfy )
+    ( Spec
+    , afterAll
+    , beforeAll
+    , describe
+    , it
+    , shouldReturn
+    , shouldSatisfy
+    , shouldThrow
+    )
 
 import qualified Cardano.Wallet.HttpBridge.Network as HttpBridge
 import qualified Data.Text as T
@@ -143,6 +155,19 @@ spec = do
                     "Transaction failed verification: transaction has more \
                     \witnesses than inputs"
             runExceptT (postTx bridge signed) `shouldReturn` err
+
+    describe "waitForConnection" $ do
+        it "times out after a short while" $ do
+            nw <- newNetworkLayer
+            let policy = constantDelay (1 * second) <> limitRetries 2
+            waitForConnection nw policy `shouldThrow` \case
+                ErrNetworkTipNetworkUnreachable _ -> True
+                _ -> False
+
+        it "returns when the network becomes available" $ do
+            (handle, nw) <- startBridge
+            (waitForConnection nw defaultRetryPolicy) `shouldReturn` ()
+            closeBridge (handle, nw)
   where
     pkWitness :: TxWitness
     pkWitness = PublicKeyWitness "O\a\142a\166\180\SO\205\&3I8\160)\224F?\157\252\ACK\DC2\EOT\ESC\184\201\170\218\217\ETX\201\ESCn\SYN\206\179O\n\236\185\235T\163\190o\SI'r\228\241\150yL\218\NAK R2\162\211\144\209\129lr\225" $ Hash "Go%&7\248\149\194\202\231\210\143-\212f.\135\174\254\186\193^\212?\136\SO;\ACK\a\211\DC1\b\223\159\161\179&\189[\231\217\179\143JOW\194iv5\EMr\197\ETX\158p\DC4=\145\128\n/\255\NUL"
@@ -177,7 +202,7 @@ spec = do
         HttpBridge.newNetworkLayer @'Testnet port
     closeBridge (handle, _) = do
         cancel handle
-        threadDelay 1000000
+        threadDelay $ 1 * second
     startBridge = do
         handle <- async $ launch
             [ Command "cardano-http-bridge"
@@ -189,5 +214,6 @@ spec = do
                 Inherit
             ]
         bridge <- newNetworkLayer
-        threadDelay 1000000
+        threadDelay $ 1 * second
         return (handle, bridge)
+    second = 1000*1000

lib/jormungandr/cardano-wallet-jormungandr.cabal

@@ -39,15 +39,21 @@ library
     , bytestring
     , cardano-wallet-core
     , cborg
+    , exceptions
+    , http-client
     , memory
     , servant
+    , servant-client
+    , servant-client-core
     , text
     , text-class
+    , transformers
   hs-source-dirs:
       src
   exposed-modules:
       Cardano.Wallet.Jormungandr.Api
       Cardano.Wallet.Jormungandr.Binary
+      Cardano.Wallet.Jormungandr.Network
       Cardano.Wallet.Jormungandr.Compatibility
       Cardano.Wallet.Jormungandr.Environment
       Cardano.Wallet.Jormungandr.Transaction

lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api.hs

@@ -14,11 +14,10 @@ module Cardano.Wallet.Jormungandr.Api
     ( Api
     , GetBlock
     , GetTipId
-    , GetBlockDecendantIds
+    , GetBlockDescendantIds
     , PostSignedTx
-    , BlockId
+    , BlockId (..)
     , api
-    , SignedTx
     ) where
 
 import Prelude
@@ -36,8 +35,7 @@ import Data.Proxy
 import Data.Text.Encoding
     ( decodeUtf8 )
 import Servant.API
-    ( (:<|>)
-    , (:>)
+    ( (:>)
     , Accept (..)
     , Capture
     , Get
@@ -56,8 +54,7 @@ import qualified Servant.API.ContentTypes as Servant
 api :: Proxy Api
 api = Proxy
 
-type Api =
-    GetBlock :<|> GetTipId :<|> GetBlockDecendantIds :<|> PostSignedTx
+type Api = GetTipId
 
 
 -- | Retrieve a block by its id.
@@ -68,21 +65,22 @@ type GetBlock
     :> Capture "blockHeaderHash" BlockId
     :> Get '[JormungandrBinary] Block
 
--- | Retrieve 'n' decendants of a given block, sorted from closest to
+-- | Retrieve 'n' descendants of a given block, sorted from closest to
 -- farthest.
 --
--- There might also exist fewer than 'n' decendants.
+-- There might also exist fewer than 'n' descendants.
 --
 -- For n=3 we might have:
 --
 -- > [genesis] ... -- [b] -- [b+1] -- [b+2] -- [b+3] -- ... -- [tip]
 -- >                   \       \                  \
--- >                  parent    +--- decendants ---+
-type GetBlockDecendantIds
+-- >                  parent    +--- descendants ---+
+type GetBlockDescendantIds
     = "api"
     :> "v0"
     :> "block"
     :> Capture "blockId" BlockId
+    :> "next_id"
     :> QueryParam "count" Int
     :> Get '[JormungandrBinary] [BlockId]
 
@@ -130,7 +128,6 @@ instance Accept JormungandrBinary where
 instance FromBinary a => MimeUnrender JormungandrBinary a where
     mimeUnrender _ bs = Right $ runGet get bs
 
-
 data Hex
 
 -- | Represents data rendered to hexadecimal text.

lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- |
+-- Copyright: © 2018-2019 IOHK
+-- License: MIT
+--
+--
+--
+-- This module allows the wallet to retrieve blocks from a known @Jormungandr@
+-- node. This is done by providing a @NetworkLayer@ with some logic building on
+-- top of an underlying @JormungandrLayer@ HTTP client.
+module Cardano.Wallet.Jormungandr.Network
+    ( JormungandrLayer (..)
+    , mkJormungandrLayer
+
+    -- * Re-export
+    , BaseUrl (..)
+    , newManager
+    , defaultManagerSettings
+    , Scheme (..)
+    ) where
+
+import Prelude
+
+import Cardano.Wallet.Jormungandr.Api
+    ( BlockId, GetTipId, api )
+import Cardano.Wallet.Network
+    ( ErrNetworkUnreachable (..) )
+import Control.Exception
+    ( Exception )
+import Control.Monad.Catch
+    ( throwM )
+import Control.Monad.Trans.Except
+    ( ExceptT (..) )
+import Data.Proxy
+    ( Proxy (..) )
+import Network.HTTP.Client
+    ( Manager, defaultManagerSettings, newManager )
+import Servant.Client
+    ( BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM )
+import Servant.Client.Core
+    ( ServantError (..) )
+import Servant.Links
+    ( Link, safeLink )
+
+-- TODO: Implement a NetworkLayer
+
+{-------------------------------------------------------------------------------
+                            Jormungandr Client
+-------------------------------------------------------------------------------}
+
+-- | Endpoints of the jormungandr REST API.
+newtype JormungandrLayer m = JormungandrLayer
+    { getTipId
+        :: ExceptT ErrNetworkUnreachable m BlockId
+    }
+
+-- | Construct a 'JormungandrLayer'-client
+--
+-- >>> mgr <- newManager defaultManagerSettings
+-- >>> j = mkJormungandrLayer mgr (BaseUrl Http "localhost" 8080 "")
+-- >>> runExceptT $ getTipId j
+-- Right (BlockId (Hash {getHash = "26c640a3de09b74398c14ca0a137ec78"}))
+mkJormungandrLayer
+    :: Manager -> BaseUrl -> JormungandrLayer IO
+mkJormungandrLayer mgr baseUrl = JormungandrLayer
+    { getTipId = ExceptT $ do
+        let ctx = safeLink api (Proxy @GetTipId)
+        run cGetTipId >>= defaultHandler ctx
+    }
+  where
+    run :: ClientM a -> IO (Either ServantError a)
+    run query = runClientM query (mkClientEnv mgr baseUrl)
+
+    defaultHandler
+        :: Link
+        -> Either ServantError a
+        -> IO (Either ErrNetworkUnreachable a)
+    defaultHandler ctx = \case
+        Right c -> return $ Right c
+
+        -- The node has not started yet or has exited.
+        -- This could be recovered from by either waiting for the node
+        -- initialise, or restarting the node.
+        Left (ConnectionError e) ->
+            return $ Left $ ErrNetworkUnreachable e
+
+        -- Other errors (status code, decode failure, invalid content type
+        -- headers). These are considered to be programming errors, so crash.
+        Left e -> do
+            throwM (ErrUnexpectedNetworkFailure ctx e)
+
+    cGetTipId = client api
+
+data ErrUnexpectedNetworkFailure
+    = ErrUnexpectedNetworkFailure Link ServantError
+    deriving (Show)
+
+instance Exception ErrUnexpectedNetworkFailure