Merge pull request #486 from input-output-hk/KtorZ/fix-restoration-wo…

…rkers

re-start restoration workers when restarting the application

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

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
@@ -155,14 +158,16 @@ 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
     ( Port )
 import Numeric.Natural
     ( Natural )
 import System.Command
-    ( CmdResult, command )
+    ( CmdResult, Stderr, Stdout, command )
 import System.Directory
     ( doesPathExist )
 import System.Exit
@@ -319,8 +324,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 +354,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
@@ -705,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)

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

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"]

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 _) ->