Skip to content
Permalink
Browse files

Merge pull request #527 from input-output-hk/paweljakubas/460/slot-le…

…ngth-based-sleep-duration

slot length based sleep duration
  • Loading branch information...
KtorZ committed Jul 12, 2019
2 parents 0706747 + 29b867b commit 137c1061b4d903c782d2c280a51d55292f1e0109
@@ -57,15 +57,15 @@ import Cardano.CLI
import Cardano.Launcher
( Command (Command), StdStream (..) )
import Cardano.Wallet
( WalletLayer )
( BlockchainParameters (..), WalletLayer )
import Cardano.Wallet.Api.Server
( Listen (..) )
import Cardano.Wallet.DaedalusIPC
( daedalusIPC )
import Cardano.Wallet.DB
( DBLayer )
import Cardano.Wallet.HttpBridge.Compatibility
( HttpBridge, Network (..), byronFeePolicy )
( HttpBridge, Network (..), byronFeePolicy, byronSlotLength )
import Cardano.Wallet.HttpBridge.Environment
( KnownNetwork (..) )
import Cardano.Wallet.HttpBridge.Primitive.Types
@@ -279,7 +279,8 @@ cmdServe = command "serve" $ info (helper <*> cmd) $ mempty
newWalletLayer (sb, tracer) db = do
(nl, block0, feePolicy) <- newNetworkLayer (sb, tracer)
let tl = HttpBridge.newTransactionLayer @n
Wallet.newWalletLayer tracer block0 feePolicy db nl tl
let bp = BlockchainParameters block0 feePolicy byronSlotLength
Wallet.newWalletLayer tracer bp db nl tl

newNetworkLayer
:: (Switchboard Text, Trace IO Text)
@@ -60,7 +60,7 @@ import Cardano.CLI
import Cardano.Launcher
( Command (Command), StdStream (..) )
import Cardano.Wallet
( WalletLayer )
( BlockchainParameters (..), WalletLayer )
import Cardano.Wallet.Api.Server
( Listen (..) )
import Cardano.Wallet.DaedalusIPC
@@ -74,24 +74,15 @@ import Cardano.Wallet.Jormungandr.Compatibility
import Cardano.Wallet.Jormungandr.Environment
( KnownNetwork (..), Network (..) )
import Cardano.Wallet.Jormungandr.Network
( ErrGetInitialFeePolicy (..), getBlock, getInitialFeePolicy )
import Cardano.Wallet.Jormungandr.Primitive.Types
( Tx (..) )
( ErrGetBlockchainParams (..), getInitialBlockchainParameters )
import Cardano.Wallet.Network
( ErrGetBlock (..)
, ErrNetworkTip
, NetworkLayer (..)
, defaultRetryPolicy
, waitForConnection
)
( ErrNetworkTip, NetworkLayer (..), defaultRetryPolicy, waitForConnection )
import Cardano.Wallet.Primitive.AddressDerivation
( KeyToAddress )
import Cardano.Wallet.Primitive.AddressDiscovery
( SeqState )
import Cardano.Wallet.Primitive.Fee
( FeePolicy )
import Cardano.Wallet.Primitive.Types
( Block (..), Hash (..) )
( Hash (..) )
import Cardano.Wallet.Version
( showVersion, version )
import Control.Applicative
@@ -340,35 +331,30 @@ cmdServe = command "serve" $ info (helper <*> cmd) $ mempty
-> DBLayer IO s t
-> IO (WalletLayer s t)
newWalletLayer (sb, tracer) db = do
(nl, block0, feePolicy) <- newNetworkLayer (sb, tracer)
(nl, blockchainParams) <- newNetworkLayer (sb, tracer)
let tl = Jormungandr.newTransactionLayer @n block0H
Wallet.newWalletLayer tracer block0 feePolicy db nl tl
Wallet.newWalletLayer tracer blockchainParams db nl tl

newNetworkLayer
:: (Switchboard Text, Trace IO Text)
-> IO (NetworkLayer t IO, Block Tx, FeePolicy)
-> IO (NetworkLayer t IO, BlockchainParameters t)
newNetworkLayer (sb, tracer) = do
let url = BaseUrl Http "localhost" (getPort nodePort) "/api"
mgr <- newManager defaultManagerSettings
let jor = Jormungandr.mkJormungandrLayer mgr url
let nl = Jormungandr.mkNetworkLayer jor
waitForService @ErrNetworkTip "Jörmungandr" (sb, tracer) nodePort $
waitForConnection nl defaultRetryPolicy
block0 <- runExceptT (getBlock jor (coerce block0H)) >>= \case
Right a -> return a
Left (ErrGetBlockNetworkUnreachable _) ->
handleNetworkUnreachable tracer
Left (ErrGetBlockNotFound _) ->
handleGenesisNotFound (sb, tracer)
feePolicy <- runExceptT (getInitialFeePolicy jor (coerce block0H)) >>= \case
blockchainParams <-
runExceptT (getInitialBlockchainParameters jor (coerce block0H)) >>= \case
Right a -> return a
Left (ErrGetInitialFeePolicyNetworkUnreachable _) ->
Left (ErrGetBlockchainParamsNetworkUnreachable _) ->
handleNetworkUnreachable tracer
Left (ErrGetInitialFeePolicyGenesisNotFound _) ->
Left (ErrGetBlockchainParamsGenesisNotFound _) ->
handleGenesisNotFound (sb, tracer)
Left (ErrGetInitialFeePolicyNoInitialPolicy _) ->
Left (ErrGetBlockchainParamsNoInitialPolicy _) ->
handleNoInitialPolicy tracer
return (nl, block0, feePolicy)
return (nl, blockchainParams)

withDBLayer
:: CM.Configuration
@@ -21,6 +21,7 @@ module Cardano.Wallet
(
-- * Interface
WalletLayer (..)
, BlockchainParameters (..)

-- * Errors
, ErrAdjustForFee (..)
@@ -107,6 +108,7 @@ import Cardano.Wallet.Primitive.Types
, DefineTx (..)
, Direction (..)
, SlotId (..)
, SlotLength (..)
, Tx (..)
, TxMeta (..)
, TxOut (..)
@@ -165,7 +167,7 @@ import Data.Text
import Data.Text.Class
( toText )
import Data.Time.Clock
( getCurrentTime )
( diffTimeToPicoseconds, getCurrentTime )
import Fmt
( Buildable, blockListF, pretty, (+|), (+||), (|+), (||+) )

@@ -361,18 +363,26 @@ cancelWorker (WorkerRegistry mvar) wid =
Construction
-------------------------------------------------------------------------------}

data BlockchainParameters t = BlockchainParameters
{ getGenesisBlock :: Block (Tx t)
-- ^ Very first block
, getFeePolicy :: FeePolicy
, getSlotLength :: SlotLength
}

-- | Create a new instance of the wallet layer.
newWalletLayer
:: forall s t. (Buildable (Tx t))
=> Trace IO Text
-> Block (Tx t)
-- ^ Very first block
-> FeePolicy
-> BlockchainParameters t
-> DBLayer IO s t
-> NetworkLayer t IO
-> TransactionLayer t
-> IO (WalletLayer s t)
newWalletLayer tracer block0 feePolicy db nw tl = do
newWalletLayer
tracer
(BlockchainParameters block0 feePolicy (SlotLength slotLength))
db nw tl = do
logDebugT $ "Wallet layer starting with: "
<> "block0: "+| block0 |+ ", "
<> "fee policy: "+|| feePolicy ||+""
@@ -536,7 +546,8 @@ newWalletLayer tracer block0 feePolicy db nw tl = do
-> BlockHeader
-> IO ()
restoreSleep t wid slot = do
let tenSeconds = 10000000 in threadDelay tenSeconds
let halfSlotLengthDelay = fromIntegral (diffTimeToPicoseconds slotLength `div` 2000000)
threadDelay halfSlotLengthDelay
runExceptT (networkTip nw) >>= \case
Left e -> do
logError t $ "Failed to get network tip: " +|| e ||+ ""
@@ -66,6 +66,7 @@ module Cardano.Wallet.Primitive.Types

-- * Slotting
, SlotId (..)
, SlotLength (..)
, slotRatio
, flatSlot
, fromFlatSlot
@@ -129,6 +130,8 @@ import Data.Text.Class
)
import Data.Time
( UTCTime )
import Data.Time.Clock
( DiffTime )
import Data.Word
( Word16, Word32, Word64 )
import Fmt
@@ -704,6 +707,9 @@ fromFlatSlot n = SlotId e (fromIntegral s)
epochLength :: Integral a => a
epochLength = 21600

newtype SlotLength = SlotLength DiffTime
deriving (Show, Eq)

{-------------------------------------------------------------------------------
Polymorphic Types
-------------------------------------------------------------------------------}
@@ -17,7 +17,8 @@ import Prelude
import Cardano.BM.Trace
( nullTracer )
import Cardano.Wallet
( ErrCreateUnsignedTx (..)
( BlockchainParameters (..)
, ErrCreateUnsignedTx (..)
, ErrSignTx (..)
, ErrSubmitTx (..)
, ErrUpdatePassphrase (..)
@@ -64,6 +65,7 @@ import Cardano.Wallet.Primitive.Types
, Direction (..)
, Hash (..)
, SlotId (..)
, SlotLength (..)
, TxIn (..)
, TxMeta (..)
, TxOut (..)
@@ -104,6 +106,8 @@ import Data.Ord
( Down (..) )
import Data.Quantity
( Quantity (..) )
import Data.Time.Clock
( secondsToDiffTime )
import Data.Word
( Word32 )
import GHC.Generics
@@ -368,7 +372,8 @@ setupFixture (wid, wname, wstate) = do
db <- newDBLayer
let nl = error "NetworkLayer"
let tl = dummyTransactionLayer
wl <- newWalletLayer @_ @DummyTarget nullTracer block0 dummyPolicy db nl tl
let bp = BlockchainParameters block0 dummyPolicy dummySlotLength
wl <- newWalletLayer @_ @DummyTarget nullTracer bp db nl tl
res <- runExceptT $ createWallet wl wid wname wstate
let wal = case res of
Left _ -> []
@@ -378,6 +383,9 @@ setupFixture (wid, wname, wstate) = do
dummyPolicy :: FeePolicy
dummyPolicy = LinearFee (Quantity 14) (Quantity 42)

dummySlotLength :: SlotLength
dummySlotLength = SlotLength $ secondsToDiffTime 1

-- | A dummy transaction layer to see the effect of a root private key. It
-- implements a fake signer that still produces sort of witnesses
dummyTransactionLayer :: TransactionLayer DummyTarget
@@ -55,6 +55,7 @@ library
, servant-client-core
, text
, text-class
, time
, transformers
hs-source-dirs:
src
@@ -43,7 +43,6 @@ module Cardano.Wallet.HttpBridge.Binary
, decodeListIndef
, toByteString
, estimateMaxNumberOfInputsParams

) where

import Prelude
@@ -19,6 +19,7 @@ module Cardano.Wallet.HttpBridge.Compatibility
, Network (..)
, block0
, byronFeePolicy
, byronSlotLength
) where

import Prelude
@@ -44,6 +45,7 @@ import Cardano.Wallet.Primitive.Types
, EncodeAddress (..)
, Hash (..)
, SlotId (..)
, SlotLength (..)
, Tx (..)
)
import Crypto.Hash
@@ -58,6 +60,8 @@ import Data.Quantity
( Quantity (..) )
import Data.Text.Class
( TextDecodingError (..) )
import Data.Time.Clock
( secondsToDiffTime )

import qualified Cardano.Wallet.HttpBridge.Binary as CBOR
import qualified Cardano.Wallet.HttpBridge.Primitive.Types as W
@@ -154,3 +158,8 @@ block0 = Block
-- | Hard-coded fee policy for Cardano on Byron
byronFeePolicy :: FeePolicy
byronFeePolicy = LinearFee (Quantity 155381) (Quantity 43.946)


-- | Hard-coded slot duration
byronSlotLength :: SlotLength
byronSlotLength = SlotLength $ secondsToDiffTime 20
@@ -16,11 +16,11 @@ import Cardano.BM.Trace
import Cardano.Launcher
( Command (Command), StdStream (..), installSignalHandlers, launch )
import Cardano.Wallet
( WalletLayer (..), newWalletLayer )
( BlockchainParameters (..), WalletLayer (..), newWalletLayer )
import Cardano.Wallet.DB.Sqlite
( PersistState )
import Cardano.Wallet.HttpBridge.Compatibility
( HttpBridge, block0, byronFeePolicy )
( HttpBridge, block0, byronFeePolicy, byronSlotLength )
import Cardano.Wallet.HttpBridge.Environment
( KnownNetwork (..), Network (..) )
import Cardano.Wallet.HttpBridge.Network
@@ -212,7 +212,8 @@ bench_restoration _ (wid, wname, s) = withHttpBridge network $ \port -> do
let tl = newTransactionLayer
BlockHeader sl _ <- unsafeRunExceptT $ networkTip nw
sayErr . fmt $ network ||+ " tip is at " +|| sl ||+ ""
w <- newWalletLayer @_ @t nullTracer block0 byronFeePolicy db nw tl
let bp = BlockchainParameters block0 byronFeePolicy byronSlotLength
w <- newWalletLayer @_ @t nullTracer bp db nw tl
wallet <- unsafeRunExceptT $ createWallet w wid wname s
unsafeRunExceptT $ restoreWallet w wallet
waitForWalletSync w wallet
@@ -13,9 +13,9 @@ import Cardano.BM.Trace
import Cardano.Launcher
( Command (..), StdStream (..), launch )
import Cardano.Wallet
( WalletLayer (..), newWalletLayer )
( BlockchainParameters (..), WalletLayer (..), newWalletLayer )
import Cardano.Wallet.HttpBridge.Compatibility
( HttpBridge, block0, byronFeePolicy )
( HttpBridge, block0, byronFeePolicy, byronSlotLength )
import Cardano.Wallet.HttpBridge.Environment
( KnownNetwork (..), Network (..) )
import Cardano.Wallet.Primitive.AddressDerivation
@@ -81,6 +81,6 @@ spec = do
db <- MVar.newDBLayer
nl <- HttpBridge.newNetworkLayer @'Testnet port
let tl = HttpBridge.newTransactionLayer
let bp = BlockchainParameters block0 byronFeePolicy byronSlotLength
(handle,) <$>
(newWalletLayer @_ @(HttpBridge 'Testnet)
nullTracer block0 byronFeePolicy db nl tl)
(newWalletLayer @_ @(HttpBridge 'Testnet) nullTracer bp db nl tl)
@@ -20,13 +20,13 @@ import Cardano.Faucet
import Cardano.Launcher
( Command (..), StdStream (..), launch )
import Cardano.Wallet
( newWalletLayer )
( BlockchainParameters (..), newWalletLayer )
import Cardano.Wallet.Api.Server
( Listen (..) )
import Cardano.Wallet.DB.Sqlite
( SqliteContext )
import Cardano.Wallet.HttpBridge.Compatibility
( HttpBridge, block0, byronFeePolicy )
( HttpBridge, block0, byronFeePolicy, byronSlotLength )
import Cardano.Wallet.HttpBridge.Environment
( Network (..) )
import Cardano.Wallet.Network
@@ -264,7 +264,8 @@ main = do
mvar <- newEmptyMVar
thread <- forkIO $ do
let tl = HttpBridge.newTransactionLayer
wallet <- newWalletLayer nullTracer block0 byronFeePolicy db nl tl
let bp = BlockchainParameters block0 byronFeePolicy byronSlotLength
wallet <- newWalletLayer nullTracer bp db nl tl
let listen = fromMaybe (ListenOnPort defaultPort) mlisten
Server.withListeningSocket listen $ \(port, socket) -> do
let settings = Warp.defaultSettings
@@ -54,6 +54,7 @@ library
, servant-client-core
, text
, text-class
, time
, transformers
hs-source-dirs:
src
@@ -95,6 +96,7 @@ test-suite unit
, QuickCheck
, text
, text-class
, time
, transformers
build-tools:
hspec-discover

0 comments on commit 137c106

Please sign in to comment.
You can’t perform that action at this time.