From 43b8aa2cf35543eff2c52e1aa958ee608bb2eca4 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 26 Jun 2019 15:55:47 +0200 Subject: [PATCH 1/4] re-start restoration workers when restarting the application --- lib/core/src/Cardano/Wallet/Api/Server.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index b7e3419659a..d7e9200ed44 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -24,7 +24,7 @@ module Cardano.Wallet.Api.Server import Prelude import Cardano.BM.Trace - ( Trace ) + ( Trace, logWarning ) import Cardano.Wallet ( ErrAdjustForFee (..) , ErrCoinSelection (..) @@ -81,7 +81,7 @@ import Control.Exception import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Except - ( ExceptT, withExceptT ) + ( ExceptT, runExceptT, withExceptT ) import Data.Aeson ( (.=) ) import Data.Functor @@ -107,7 +107,7 @@ import Data.Text.Class import Data.Time ( UTCTime ) import Fmt - ( pretty ) + ( pretty, (+|), (+||), (|+), (||+) ) import Network.HTTP.Media.RenderHeader ( renderHeader ) import Network.HTTP.Types.Header @@ -165,6 +165,7 @@ start -> WalletLayer (SeqState t) t -> IO () start settings trace socket wl = do + withWorkers trace wl logSettings <- newApiLoggerSettings <&> obfuscateKeys (const sensitive) Warp.runSettingsSocket settings socket $ handleRawError handler @@ -187,6 +188,21 @@ start settings trace socket wl = do , "mnemonic_second_factor" ] +-- | Restart restoration workers for existing wallets. This is crucial to keep +-- on syncing wallets after the application has restarted! +withWorkers + :: (DefineTx t) + => Trace IO Text + -> WalletLayer s t + -> IO () +withWorkers trace w = do + W.listWallets w >>= mapM_ worker + where + worker wid = runExceptT (W.restoreWallet w wid) >>= \case + Right () -> return () + Left e -> logWarning trace $ + "Wallet has suddenly vanished: "+| wid |+": "+|| e ||+"" + -- | Run an action with a TCP socket bound to a port specified by the `Listen` -- parameter. withListeningSocket From f0d9edf5732ab9767aea2263a0425e5018dc6ad6 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 27 Jun 2019 14:17:23 +0200 Subject: [PATCH 2/4] relax a bit the constraints on 'request' and only require what's strictly needed --- .../integration/Test/Integration/Framework/DSL.hs | 14 ++++++++++---- .../Test/Integration/Framework/Request.hs | 12 +++++++++--- lib/http-bridge/test/integration/Main.hs | 13 +++---------- 3 files changed, 22 insertions(+), 17 deletions(-) diff --git a/lib/core/test/integration/Test/Integration/Framework/DSL.hs b/lib/core/test/integration/Test/Integration/Framework/DSL.hs index 4a92c217e65..0f1229f48a8 100644 --- a/lib/core/test/integration/Test/Integration/Framework/DSL.hs +++ b/lib/core/test/integration/Test/Integration/Framework/DSL.hs @@ -155,6 +155,8 @@ import GHC.TypeLits ( Symbol ) import Language.Haskell.TH.Quote ( QuasiQuoter ) +import Network.HTTP.Client + ( Manager ) import Network.HTTP.Types.Method ( Method ) import Network.Wai.Handler.Warp @@ -319,8 +321,10 @@ expectListSizeEqual l (_, res) = case res of -- | Expects wallet from the request to eventually reach the given state or -- beyond expectEventually - :: (MonadIO m, MonadCatch m, MonadFail m, Ord a, Show a) - => Context t + :: (MonadIO m, MonadCatch m, MonadFail m) + => (Ord a, Show a) + => (HasType (Text, Manager) ctx) + => ctx -> Lens' ApiWallet a -> a -> (HTTP.Status, Either RequestException ApiWallet) @@ -347,8 +351,10 @@ expectEventually ctx getter target (_, res) = case res of -- | Same as `expectEventually` but work directly on ApiWallet -- , not response from the API expectEventually' - :: (MonadIO m, MonadCatch m, MonadFail m, Ord a, Show a) - => Context t + :: (MonadIO m, MonadCatch m, MonadFail m) + => (Ord a, Show a) + => (HasType (Text, Manager) ctx) + => ctx -> Lens' ApiWallet a -> a -> ApiWallet diff --git a/lib/core/test/integration/Test/Integration/Framework/Request.hs b/lib/core/test/integration/Test/Integration/Framework/Request.hs index b72fa5f580a..6b3c5ca04a6 100644 --- a/lib/core/test/integration/Test/Integration/Framework/Request.hs +++ b/lib/core/test/integration/Test/Integration/Framework/Request.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -30,6 +31,10 @@ import Data.Aeson ( FromJSON ) import Data.ByteString.Lazy ( ByteString ) +import Data.Generics.Internal.VL.Lens + ( (^.) ) +import Data.Generics.Product.Typed + ( HasType, typed ) import Data.Proxy ( Proxy (..) ) import Data.Text @@ -132,12 +137,13 @@ data Headers -- | Makes a request to the API and decodes the response. request - :: forall a m t. + :: forall a m s. ( FromJSON a , MonadIO m , MonadCatch m + , HasType (Text, Manager) s ) - => Context t + => s -> (Method, Text) -- ^ HTTP method and request path -> Headers @@ -146,7 +152,7 @@ request -- ^ Request body -> m (HTTP.Status, Either RequestException a) request ctx (verb, path) reqHeaders body = do - let (base, manager) = _manager ctx + let (base, manager) = ctx ^. typed @(Text, Manager) req <- parseRequest $ T.unpack $ base <> path let io = handleResponse <$> liftIO (httpLbs (prepareReq req) manager) catch io handleException diff --git a/lib/http-bridge/test/integration/Main.hs b/lib/http-bridge/test/integration/Main.hs index ab7372be495..204f91518b2 100644 --- a/lib/http-bridge/test/integration/Main.hs +++ b/lib/http-bridge/test/integration/Main.hs @@ -42,6 +42,8 @@ import Data.Aeson ( Value (..), (.:) ) import Data.Function ( (&) ) +import Data.Functor.Identity + ( Identity (..) ) import Data.Generics.Internal.VL.Lens ( (^.) ) import Data.Generics.Product.Typed @@ -265,16 +267,7 @@ main = do waitForCluster :: String -> IO () waitForCluster addr = do manager <- newManager defaultManagerSettings - let ctx = Context - { _cluster = undefined - , _logs = undefined - , _faucet = undefined - , _target = undefined - , _db = undefined - , _port = undefined - , _feeEstimator = undefined - , _manager = ("http://" <> T.pack addr, manager) - } + let ctx = Identity ("http://" <> T.pack addr, manager) let err = "waitForCluster: unexpected positive response from Api" request @Value ctx ("GET", "/api/v1/node-info") Default Empty >>= \case (_, Left _) -> From a47e0c997abaece54572f0e5ccfda706b8aaaf9a Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 27 Jun 2019 14:17:46 +0200 Subject: [PATCH 3/4] add helper function to wait for the server to have started --- .../Test/Integration/Framework/DSL.hs | 21 ++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/lib/core/test/integration/Test/Integration/Framework/DSL.hs b/lib/core/test/integration/Test/Integration/Framework/DSL.hs index 0f1229f48a8..3d979ae6aed 100644 --- a/lib/core/test/integration/Test/Integration/Framework/DSL.hs +++ b/lib/core/test/integration/Test/Integration/Framework/DSL.hs @@ -70,6 +70,7 @@ module Test.Integration.Framework.DSL , faucetAmt , faucetUtxoAmt , proc' + , waitForServer -- * Endpoints , getWalletEp @@ -123,6 +124,8 @@ import Control.Monad.Fail ( MonadFail (..) ) import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Control.Retry + ( capDelay, constantDelay, retrying ) import Crypto.Hash ( Blake2b_160, Digest, digestFromByteString ) import Data.Aeson @@ -164,7 +167,7 @@ import Network.Wai.Handler.Warp import Numeric.Natural ( Natural ) import System.Command - ( CmdResult, command ) + ( CmdResult, Stderr, Stdout, command ) import System.Directory ( doesPathExist ) import System.Exit @@ -711,6 +714,22 @@ tearDown ctx = do Left e -> error $ "deleteAllWallets: Cannot return wallets: " <> show e Right s -> s +-- | Wait a booting wallet server to has started. Wait up to 30s or fail. +waitForServer + :: (HasType Port ctx) + => ctx + -> IO () +waitForServer ctx = void $ retrying + (capDelay (30*oneSecond) $ constantDelay oneSecond) + -- NOTE + -- We still bind the output and error streams to some custom handles because + -- if we don't, the library defaults to `stdout` and `stderr` which can get + -- quite noisy. + (\_ (e, _ :: Stderr, _ :: Stdout) -> pure $ e == ExitFailure 1) + (const $ listWalletsViaCLI ctx) + where + oneSecond = 1000000 + unsafeCreateDigest :: Text -> Digest Blake2b_160 unsafeCreateDigest s = fromMaybe (error $ "unsafeCreateDigest failed to create digest from: " <> show s) From 808f5206d9bffb3504937f4a6bf2fbf9fd7b1fac Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 27 Jun 2019 14:20:20 +0200 Subject: [PATCH 4/4] add integration test about restoration worker --- .../test/integration/Cardano/LauncherSpec.hs | 51 ++++++++++++++++++- 1 file changed, 49 insertions(+), 2 deletions(-) diff --git a/lib/http-bridge/test/integration/Cardano/LauncherSpec.hs b/lib/http-bridge/test/integration/Cardano/LauncherSpec.hs index d9572ef611e..70b3e16471b 100644 --- a/lib/http-bridge/test/integration/Cardano/LauncherSpec.hs +++ b/lib/http-bridge/test/integration/Cardano/LauncherSpec.hs @@ -1,11 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + module Cardano.LauncherSpec ( spec ) where import Prelude +import Cardano.Wallet.Api.Types + ( ApiWallet ) +import Cardano.Wallet.Primitive.Types + ( WalletState (..) ) +import Control.Exception + ( finally ) import Control.Monad ( forM_ ) +import Data.Proxy + ( Proxy (..) ) +import Data.Text.Class + ( toText ) +import Network.HTTP.Client + ( defaultManagerSettings, newManager ) +import System.Command + ( Stdout (..) ) import System.Directory ( removeDirectory ) import System.Exit @@ -24,8 +42,15 @@ import Test.Hspec import Test.Hspec.Expectations.Lifted ( shouldReturn ) import Test.Integration.Framework.DSL - ( expectPathEventuallyExist, proc' ) - + ( createWalletViaCLI + , expectEventually' + , expectPathEventuallyExist + , expectValidJSON + , generateMnemonicsViaCLI + , proc' + , state + , waitForServer + ) import qualified Data.Text.IO as TIO @@ -59,6 +84,28 @@ spec = do TIO.hGetContents o >>= TIO.putStrLn TIO.hGetContents e >>= TIO.putStrLn + it "LAUNCH - Restoration workers restart" $ withTempDir $ \d -> do + let port = 8088 :: Int -- Arbitrary but known. + let baseUrl = "http://localhost:" <> toText port <> "/" + ctx <- (port,) . (baseUrl,) <$> newManager defaultManagerSettings + let args = ["launch", "--port", show port, "--state-dir", d] + let process = proc' "cardano-wallet" args + wallet <- withCreateProcess process $ \_ (Just o) (Just e) ph -> do + Stdout m <- generateMnemonicsViaCLI [] + waitForServer ctx + let pwd = "passphrase" + (_, out, _) <- createWalletViaCLI ctx ["n"] m "\n" pwd + terminateProcess ph + TIO.hGetContents o >>= TIO.putStrLn + TIO.hGetContents e >>= TIO.putStrLn + expectValidJSON (Proxy @ApiWallet) out + withCreateProcess process $ \_ (Just o) (Just e) ph -> do + waitForServer ctx + expectEventually' ctx state Ready wallet `finally` do + terminateProcess ph + TIO.hGetContents o >>= TIO.putStrLn + TIO.hGetContents e >>= TIO.putStrLn + describe "DaedalusIPC" $ do let tests = [ ["--random-port"]