Skip to content

Commit

Permalink
Try #810:
Browse files Browse the repository at this point in the history
  • Loading branch information
@iohk-bors
iohk-bors[bot] authored Oct 11, 2019
2 parents 0c64924 + 096eb15 commit 9b4c8e7
Show file tree
Hide file tree
Showing 9 changed files with 163 additions and 67 deletions.
56 changes: 35 additions & 21 deletions lib/core/src/Cardano/Wallet/Api/Server.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,8 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- |
-- Copyright: © 2018-2019 IOHK
-- License: Apache-2.0
Expand Down Expand Up @@ -103,10 +105,14 @@ import Cardano.Wallet.Network
( ErrNetworkUnavailable (..), NetworkLayer )
import Cardano.Wallet.Primitive.AddressDerivation
( KeyToAddress (..), WalletKey (..), digest, publicKey )
import Cardano.Wallet.Primitive.AddressDerivation.Random
( RndKey )
import Cardano.Wallet.Primitive.AddressDerivation.Sequential
( SeqKey (..), generateKeyFromSeed )
import Cardano.Wallet.Primitive.AddressDiscovery
( IsOurs )
import Cardano.Wallet.Primitive.AddressDiscovery.Random
( RndState )
import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
( SeqState (..), defaultAddressPoolGap, mkSeqState )
import Cardano.Wallet.Primitive.Fee
Expand Down Expand Up @@ -235,22 +241,21 @@ data Listen

-- | Start the application server, using the given settings and a bound socket.
start
:: forall ctx s t k.
( DefineTx t
, KeyToAddress t k
, EncodeAddress t
:: forall t .
( Buildable (ErrValidateSelection t)
, DefineTx t
, DecodeAddress t
, Buildable (ErrValidateSelection t)
, k ~ SeqKey
, s ~ SeqState t
, ctx ~ ApiLayer s t k
, EncodeAddress t
, KeyToAddress t RndKey
, KeyToAddress t SeqKey
)
=> Warp.Settings
-> Trace IO Text
-> Socket
-> ctx
-> ApiLayer (RndState t) t RndKey
-> ApiLayer (SeqState t) t SeqKey
-> IO ()
start settings trace socket ctx = do
start settings trace socket rndCtx seqCtx = do
logSettings <- newApiLoggerSettings <&> obfuscateKeys (const sensitive)
Warp.runSettingsSocket settings socket
$ handleRawError (curry handler)
Expand All @@ -259,7 +264,7 @@ start settings trace socket ctx = do
where
-- | A Servant server for our wallet API
server :: Server (Api t)
server = coreApiServer ctx :<|> compatibilityApiServer ctx
server = coreApiServer seqCtx :<|> compatibilityApiServer rndCtx seqCtx

application :: Application
application = serve (Proxy @("v2" :> Api t)) server
Expand Down Expand Up @@ -631,15 +636,22 @@ listPools _ctx = throwError err501
==============================================================================-}

compatibilityApiServer
:: ctx
:: forall t .
( Buildable (ErrValidateSelection t)
, DefineTx t
, KeyToAddress t RndKey
, KeyToAddress t SeqKey
)
=> ApiLayer (RndState t) t RndKey
-> ApiLayer (SeqState t) t SeqKey
-> Server (CompatibilityApi t)
compatibilityApiServer ctx =
deleteByronWallet ctx
:<|> getByronWallet ctx
:<|> getByronWalletMigrationInfo ctx
:<|> listByronWallets ctx
:<|> migrateByronWallet ctx
:<|> postByronWallet ctx
compatibilityApiServer rndCtx seqCtx =
deleteByronWallet rndCtx
:<|> getByronWallet rndCtx
:<|> getByronWalletMigrationInfo rndCtx
:<|> listByronWallets rndCtx
:<|> migrateByronWallet rndCtx seqCtx
:<|> postByronWallet rndCtx

deleteByronWallet
:: ctx
Expand All @@ -660,14 +672,16 @@ getByronWalletMigrationInfo
getByronWalletMigrationInfo _ _ = throwError err501

migrateByronWallet
:: ctx
:: rndCtx
-> seqCtx
-> ApiT WalletId
-- ^ Source wallet (Byron)
-> ApiT WalletId
-- ^ Target wallet (new-style)
-> ApiMigrateByronWalletData
-> Handler NoContent
migrateByronWallet _ctx _sourceWid _targetWid _migrateData = throwError err501
migrateByronWallet _rndCtx _seqCtx _sourceWid _targetWid _migrateData =
throwError err501

listByronWallets
:: ctx
Expand Down
3 changes: 1 addition & 2 deletions lib/core/test/unit/Cardano/WalletSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -395,8 +395,7 @@ data WalletLayerFixture = WalletLayerFixture
}

setupFixture
:: forall ctx. (ctx ~ WalletLayer DummyState DummyTarget SeqKey)
=> (WalletId, WalletName, DummyState)
:: (WalletId, WalletName, DummyState)
-> IO WalletLayerFixture
setupFixture (wid, wname, wstate) = do
let nl = error "NetworkLayer"
Expand Down
22 changes: 14 additions & 8 deletions lib/http-bridge/exe/cardano-wallet-http-bridge.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -65,10 +65,10 @@ import Cardano.Wallet.HttpBridge.Network
( HttpBridgeBackend (..), HttpBridgeConfig (..) )
import Cardano.Wallet.Primitive.AddressDerivation
( KeyToAddress )
import Cardano.Wallet.Primitive.AddressDerivation.Random
( RndKey )
import Cardano.Wallet.Primitive.AddressDerivation.Sequential
( SeqKey )
import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
( SeqState )
import Cardano.Wallet.Version
( showVersion, version )
import Control.Applicative
Expand Down Expand Up @@ -144,8 +144,10 @@ cmdLaunch dataDir = command "launch" $ info (helper <*> cmd) $ mempty
Right Testnet -> exec @(HttpBridge 'Testnet) args
Right Mainnet -> exec @(HttpBridge 'Mainnet) args
exec
:: forall t k n s. (t ~ HttpBridge n, s ~ SeqState t, k ~ SeqKey)
=> (KeyToAddress t k, KnownNetwork n)
:: forall t n. (t ~ HttpBridge n)
=> ( KeyToAddress t RndKey
, KeyToAddress t SeqKey
, KnownNetwork n)
=> LaunchArgs
-> IO ()
exec (LaunchArgs network listen (Port nodePort) mStateDir verbosity) = do
Expand All @@ -156,7 +158,7 @@ cmdLaunch dataDir = command "launch" $ info (helper <*> cmd) $ mempty
setupDirectory (logInfo tr) stateDir
setupDirectory (logInfo tr) databaseDir
logInfo tr $ "Running as v" <> T.pack (showVersion version)
exitWith =<< serveWallet @t @k @n @s
exitWith =<< serveWallet @t @n
(cfg, sb, tr)
(Just databaseDir)
listen
Expand Down Expand Up @@ -191,15 +193,19 @@ cmdServe = command "serve" $ info (helper <*> cmd) $ mempty
Testnet -> exec @(HttpBridge 'Testnet) args
Mainnet -> exec @(HttpBridge 'Mainnet) args
exec
:: forall t k n s. (t ~ HttpBridge n, s ~ SeqState t, k ~ SeqKey)
=> (KeyToAddress t k, KnownNetwork n)
:: forall t n.
( t ~ HttpBridge n
, KeyToAddress t RndKey
, KeyToAddress t SeqKey
, KnownNetwork n
)
=> ServeArgs
-> IO ()
exec (ServeArgs _ listen (Port nodePort) databaseDir verbosity) = do
(cfg, sb, tr) <- initTracer (verbosityToMinSeverity verbosity) "serve"
whenJust databaseDir $ setupDirectory (logInfo tr)
logInfo tr $ "Running as v" <> T.pack (showVersion version)
exitWith =<< serveWallet @t @k @n @s
exitWith =<< serveWallet @t @n
(cfg, sb, tr)
databaseDir
listen
Expand Down
50 changes: 40 additions & 10 deletions lib/http-bridge/src/Cardano/Wallet/HttpBridge.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -36,6 +36,8 @@ import Cardano.Wallet.DaedalusIPC
( daedalusIPC )
import Cardano.Wallet.DB
( DBFactory (..) )
import Cardano.Wallet.DB.Sqlite
( PersistState )
import Cardano.Wallet.HttpBridge.Compatibility
( HttpBridge )
import Cardano.Wallet.HttpBridge.Environment
Expand All @@ -49,15 +51,23 @@ import Cardano.Wallet.Network
import Cardano.Wallet.Network.Ports
( PortNumber )
import Cardano.Wallet.Primitive.AddressDerivation
( KeyToAddress )
( KeyToAddress, PersistKey )
import Cardano.Wallet.Primitive.AddressDerivation.Random
( RndKey )
import Cardano.Wallet.Primitive.AddressDerivation.Sequential
( SeqKey )
import Cardano.Wallet.Primitive.AddressDiscovery
( IsOurs )
import Cardano.Wallet.Primitive.AddressDiscovery.Random
( RndState )
import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
( SeqState )
import Cardano.Wallet.Primitive.Types
( Block )
import Control.Concurrent.Async
( race_ )
import Control.DeepSeq
( NFData )
import Data.Function
( (&) )
import Data.Text
Expand All @@ -79,8 +89,11 @@ import qualified Network.Wai.Handler.Warp as Warp

-- | The @cardano-wallet-http-bridge@ main function.
serveWallet
:: forall t k n s a. (t ~ HttpBridge n, s ~ SeqState t, k ~ SeqKey)
=> (KeyToAddress t k, KnownNetwork n)
:: forall t n a. (t ~ HttpBridge n)
=> ( KeyToAddress t RndKey
, KeyToAddress t SeqKey
, KnownNetwork n
)
=> (CM.Configuration, Switchboard Text, Trace IO Text)
-- ^ Logging config.
-> Maybe FilePath
Expand All @@ -105,18 +118,20 @@ serveWallet (cfg, sb, tr) databaseDir listen bridge mAction = do
Right (bridgePort, nl) -> do
waitForService "http-bridge" (sb, tr) (Port $ fromEnum bridgePort) $
waitForNetwork nl defaultRetryPolicy
wl <- newApiLayer nl
wlRnd <- newApiLayer nl
wlSeq <- newApiLayer nl
let mkCallback action apiPort =
action (fromIntegral apiPort) bridgePort nl
withServer wl (mkCallback <$> mAction)
withServer wlRnd wlSeq (mkCallback <$> mAction)
pure ExitSuccess
Left e -> handleNetworkStartupError e
where
withServer
:: ApiLayer s t k
:: ApiLayer (RndState t) t RndKey
-> ApiLayer (SeqState t) t SeqKey
-> Maybe (Int -> IO a)
-> IO ()
withServer api action = do
withServer apiRnd apiSeq action = do
Server.withListeningSocket listen $ \(port, socket) -> do
let tracerIPC = appendName "daedalus-ipc" tr
let tracerApi = appendName "api" tr
Expand All @@ -125,12 +140,20 @@ serveWallet (cfg, sb, tr) databaseDir listen bridge mAction = do
let settings = Warp.defaultSettings
& setBeforeMainLoop beforeMainLoop
let ipcServer = daedalusIPC tracerIPC port
let apiServer = Server.start settings tracerApi socket api
let apiServer = Server.start settings tracerApi socket apiRnd apiSeq
let withAction = maybe id (\cb -> race_ (cb port)) action
withAction $ race_ ipcServer apiServer

newApiLayer
:: NetworkLayer IO t (Block Tx)
:: forall s k .
( IsOurs s
, KeyToAddress (HttpBridge n) k
, NFData s
, PersistKey k
, PersistState s
, Show s
)
=> NetworkLayer IO t (Block Tx)
-> IO (ApiLayer s t k)
newApiLayer nl = do
let g0 = staticBlockchainParameters nl
Expand All @@ -139,7 +162,14 @@ serveWallet (cfg, sb, tr) databaseDir listen bridge mAction = do
Server.newApiLayer tr g0 nl tl dbFactory wallets

dbFactory
:: DBFactory IO s t k
:: forall s k .
( IsOurs s
, NFData s
, PersistKey k
, PersistState s
, Show s
)
=> DBFactory IO s t k
dbFactory =
Sqlite.mkDBFactory cfg tr databaseDir

Expand Down
Loading

0 comments on commit 9b4c8e7

Please sign in to comment.