From 503482150d21fe9b682c7bbc884f4b950d3d7230 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Fri, 24 May 2019 15:45:01 +0200 Subject: [PATCH] Add Jormungandr client --- .../cardano-wallet-jormungandr.cabal | 17 +- .../src/Cardano/Wallet/Network/Jormungandr.hs | 161 ++++++++++++++++++ .../Cardano/Wallet/Network/Jormungandr/Api.hs | 8 +- .../Cardano/Wallet/Network/JormungandrSpec.hs | 68 ++++++++ lib/jormungandr/test/integration/Main.hs | 2 + 5 files changed, 253 insertions(+), 3 deletions(-) create mode 100644 lib/jormungandr/src/Cardano/Wallet/Network/Jormungandr.hs create mode 100644 lib/jormungandr/test/integration/Cardano/Wallet/Network/JormungandrSpec.hs diff --git a/lib/jormungandr/cardano-wallet-jormungandr.cabal b/lib/jormungandr/cardano-wallet-jormungandr.cabal index 8dc921b66b6..0484ef0412f 100644 --- a/lib/jormungandr/cardano-wallet-jormungandr.cabal +++ b/lib/jormungandr/cardano-wallet-jormungandr.cabal @@ -38,6 +38,15 @@ library , cardano-wallet-core , servant , memory + , exceptions + , http-media + , http-client + , http-types + , transformers + , cryptonite + , cardano-crypto + , servant-client + , servant-client-core , text , text-class hs-source-dirs: @@ -45,6 +54,7 @@ library exposed-modules: Cardano.Environment.Jormungandr Cardano.Wallet.Binary.Jormungandr + Cardano.Wallet.Network.Jormungandr Cardano.Wallet.Network.Jormungandr.Api Cardano.Wallet.Compatibility.Jormungandr Cardano.Wallet.Transaction.Jormungandr @@ -99,8 +109,13 @@ test-suite integration build-depends: async , base + , bytestring , cardano-wallet-jormungandr + , cardano-wallet-core , cardano-wallet-launcher + , text-class + , text + , transformers , hspec type: exitcode-stdio-1.0 @@ -110,4 +125,4 @@ test-suite integration Main.hs other-modules: Cardano.LauncherSpec - + Cardano.Wallet.Network.JormungandrSpec diff --git a/lib/jormungandr/src/Cardano/Wallet/Network/Jormungandr.hs b/lib/jormungandr/src/Cardano/Wallet/Network/Jormungandr.hs new file mode 100644 index 00000000000..b5a10bea8c7 --- /dev/null +++ b/lib/jormungandr/src/Cardano/Wallet/Network/Jormungandr.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +-- | +-- Copyright: © 2018-2019 IOHK +-- License: MIT +-- +-- +-- A @NetworkLayer@ supporting jormungandr as a chain producer. + +module Cardano.Wallet.Network.Jormungandr + ( Jormungandr (..) + , mkNetworkLayer + , newNetworkLayer + , mkJormungandr + + -- * Re-export + , BaseUrl (..) + , newManager + , defaultManagerSettings + , Scheme (..) + ) where + +import Prelude + +import Cardano.Wallet.Network + ( ErrNetworkTip (..) + , ErrNetworkUnreachable (..) + , ErrPostTx (..) + , NetworkLayer (..) + ) +import Cardano.Wallet.Network.Jormungandr.Api + ( BlockId, GetBlock, GetTipId, SignedTx, api ) +import Cardano.Wallet.Primitive.Types + ( Block ) +import Control.Arrow + ( left ) +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 Network.HTTP.Types.Status + ( status404 ) +import Servant.API + ( (:<|>) (..) ) +import Servant.Client + ( BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM ) +import Servant.Client.Core + ( ServantError (..), responseStatusCode ) +import Servant.Links + ( Link, safeLink ) + +-- | Constructs a network layer with the given @Jormungandr@ client. +mkNetworkLayer :: Monad m => Jormungandr m -> NetworkLayer m +mkNetworkLayer _httpBridge = NetworkLayer + { nextBlocks = undefined + , networkTip = undefined + , postTx = undefined + } + +-- | Creates a jormungandr 'NetworkLayer' using the given connection +-- settings. +newNetworkLayer + :: Int -> IO (NetworkLayer IO) +newNetworkLayer port = mkNetworkLayer <$> newHttpBridge port + where + newHttpBridge = undefined + +{------------------------------------------------------------------------------- + Jormungandr Client +-------------------------------------------------------------------------------} + +-- | Endpoints of the jormungandr REST API. +data Jormungandr m = HttpBridge + { getBlock + :: BlockId -> ExceptT ErrNetworkUnreachable m Block + , getTipId + :: ExceptT ErrNetworkTip m BlockId + , getDecendantIds + :: BlockId -> Int -> ExceptT ErrGetDecendants m [BlockId] + , postSignedTx + :: SignedTx -> ExceptT ErrPostTx m () + } + +-- | Error while trying to get decendants +data ErrGetDecendants + = ErrGetDecendantsNetworkUnreachable ErrNetworkUnreachable + | ErrGetDecendantsParentNotFound + deriving (Show, Eq) + +instance Exception ErrGetDecendants + +-- | Construct a Jormungandr-client +-- +-- >>> mgr <- newManager defaultManagerSettings +-- >>> j = mkJormungandr mgr (BaseUrl Http "localhost" 8080 "") +-- >>> runExceptT $ getTipId j +-- Right (BlockId (Hash {getHash = "26c640a3de09b74398c14ca0a137ec78"})) +mkJormungandr + :: Manager -> BaseUrl -> Jormungandr IO +mkJormungandr mgr baseUrl = HttpBridge + { getBlock = \hash -> ExceptT $ do + let ctx = safeLink api (Proxy @GetBlock) hash + run (cGetBlock hash) >>= defaultHandler ctx + + , getTipId = ExceptT $ do + run cGetTipId >>= \case + Left (FailureResponse e) | responseStatusCode e == status404 -> + return $ Left ErrNetworkTipNotFound + x -> do + let ctx = safeLink api (Proxy @GetTipId) + left ErrNetworkTipNetworkUnreachable <$> defaultHandler ctx x + + , getDecendantIds = undefined + , postSignedTx = undefined + } + 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) + + cGetBlock + :<|> cGetTipId + :<|> _cGetBlockDecendantIds + :<|> _cPostSignedTx + = client api + +data ErrUnexpectedNetworkFailure + = ErrUnexpectedNetworkFailure Link ServantError + deriving (Show) + +instance Exception ErrUnexpectedNetworkFailure diff --git a/lib/jormungandr/src/Cardano/Wallet/Network/Jormungandr/Api.hs b/lib/jormungandr/src/Cardano/Wallet/Network/Jormungandr/Api.hs index fa67df32e69..728165db620 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Network/Jormungandr/Api.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Network/Jormungandr/Api.hs @@ -17,7 +17,7 @@ module Cardano.Wallet.Network.Jormungandr.Api , GetTipId , GetBlockDecendantIds , PostSignedTx - , BlockId + , BlockId (..) , api , SignedTx ) where @@ -41,6 +41,7 @@ import Servant.API , (:>) , Capture , Get + , MimeRender (..) , MimeUnrender (..) , NoContent , Post @@ -99,7 +100,7 @@ type PostSignedTx data SignedTx newtype BlockId = BlockId (Hash "block") - deriving Show + deriving (Show, Eq) instance ToHttpApiData BlockId where toUrlPiece (BlockId (Hash bytes)) = decodeUtf8 $ convertToBase Base16 bytes @@ -114,3 +115,6 @@ instance MimeUnrender PlainText BlockId where -- Orphan instance instance FromBinary a => MimeUnrender OctetStream a where mimeUnrender _ bs = Right $ runGet get bs + +instance MimeRender OctetStream SignedTx where + mimeRender _ _bs = undefined diff --git a/lib/jormungandr/test/integration/Cardano/Wallet/Network/JormungandrSpec.hs b/lib/jormungandr/test/integration/Cardano/Wallet/Network/JormungandrSpec.hs new file mode 100644 index 00000000000..9168f96bd6a --- /dev/null +++ b/lib/jormungandr/test/integration/Cardano/Wallet/Network/JormungandrSpec.hs @@ -0,0 +1,68 @@ +module Cardano.Wallet.Network.JormungandrSpec + ( spec + ) where + +import Prelude + +import Cardano.Launcher + ( Command (..), StdStream (..), launch ) +import Cardano.Wallet.Network.Jormungandr + ( BaseUrl (..) + , Scheme (Http) + , defaultManagerSettings + , getBlock + , getTipId + , mkJormungandr + , newManager + ) +import Cardano.Wallet.Network.Jormungandr.Api + ( BlockId (..) ) +import Cardano.Wallet.Primitive.Types + ( Block (..), Hash (..) ) +import Control.Concurrent + ( threadDelay ) +import Control.Concurrent.Async + ( async, cancel ) +import Control.Monad.Trans.Except + ( runExceptT ) +import Test.Hspec + ( Spec, afterAll, beforeAll, describe, it, shouldBe ) + +import qualified Data.ByteString as BS + +spec :: Spec +spec = do + describe "Happy paths" + $ beforeAll startNode $ afterAll closeNode $ do + it "get tip (should be genesis)" $ \(_, client) -> do + (BlockId (Hash tipHash)) <- run $ getTipId client + tipHash `shouldBe` genesisHash + (BS.length tipHash) `shouldBe` 32 + + it "get block (genesis)" $ \(_, client) -> do + b <- run $ getBlock client (BlockId $ Hash genesisHash) + length (transactions b) `shouldBe` 1 + + where + genesisHash = "&\198@\163\222\t\183C\152\193L\160\161\&7\236x\245\229\EOT\175\177\167\131\190\b\b/\174\212\177:\179" + + run x = (either undefined id) <$> runExceptT x + + closeNode (handle, _) = do + cancel handle + threadDelay 1000000 + + startNode = do + handle <- async $ launch $ return $ Command + "jormungandr" + [ "--genesis-block", dir ++ "/block-0.bin" + , "--config", dir ++ "/node.config" + , "--secret", dir ++ "/secret.yaml" + ] (return ()) + Inherit + manager <- newManager defaultManagerSettings + let client = mkJormungandr manager (BaseUrl Http "localhost" 8080 "") + threadDelay 1000000 + return (handle, client) + + dir = "test/data/jormungandr" diff --git a/lib/jormungandr/test/integration/Main.hs b/lib/jormungandr/test/integration/Main.hs index 1686adc13af..a3dacd7c8af 100644 --- a/lib/jormungandr/test/integration/Main.hs +++ b/lib/jormungandr/test/integration/Main.hs @@ -9,6 +9,7 @@ import Test.Hspec ( describe, hspec ) import qualified Cardano.LauncherSpec as Launcher +import qualified Cardano.Wallet.Network.JormungandrSpec as Network main :: IO () main = do @@ -20,3 +21,4 @@ main = do hspec $ do describe "Cardano.LauncherSpec" Launcher.spec + describe "Cardano.Wallet.Network.JormunganrSpec" Network.spec