Fix benchmarks in Buildkite

.buildkite/benchmark.sh

@@ -1,4 +1,5 @@
-#!/usr/bin/env bash
+#! /usr/bin/env nix-shell
+#! nix-shell -i bash -p nix git stack haskellPackages.hp2pretty buildkite-agent
 
 set -euo pipefail
 
@@ -9,6 +10,10 @@ if [ -z "$netname" ]; then
    exit 1
 fi
 
+echo "--- Build code and benchmarks"
+stack build --bench --no-run-benchmarks
+
+echo "+++ Run benchmarks"
 stack bench cardano-wallet:restore --interleaved-output --ba "$netname +RTS -N2 -qg -A1m -I0 -T -M1G -h -RTS"
 
 hp2pretty restore.hp

.buildkite/nightly.yml

@@ -2,12 +2,12 @@ env:
   NIX_PATH: "channel:nixos-19.03"
 steps:
   - label: 'Restore benchmark - testnet'
-    command: "nix-shell -p nix git stack haskellPackages.hp2pretty buildkite-agent --run ./.buildkite/benchmark.sh testnet"
+    command: "./.buildkite/benchmark.sh testnet"
     timeout_in_minutes: 60
     agents:
       system: x86_64-linux
   - label: 'Restore benchmark - mainnet'
-    command: "nix-shell -p nix git stack haskellPackages.hp2pretty buildkite-agent --run ./.buildkite/benchmark.sh mainnet"
+    command: "./.buildkite/benchmark.sh mainnet"
     timeout_in_minutes: 60
     agents:
       system: x86_64-linux

src/Cardano/Wallet/Network.hs

@@ -11,6 +11,7 @@ module Cardano.Wallet.Network
 
     -- * Errors
     , ErrNetworkUnreachable(..)
+    , ErrNetworkTip(..)
     , ErrPostTx(..)
 
     -- * Deprecated (to be removed)
@@ -48,7 +49,7 @@ data NetworkLayer m = NetworkLayer
         -- after the starting slot.
 
     , networkTip
-        :: ExceptT ErrNetworkUnreachable m (Hash "BlockHeader", BlockHeader)
+        :: ExceptT ErrNetworkTip m (Hash "BlockHeader", BlockHeader)
         -- ^ Get the current network tip from the chain producer
 
     , postTx
@@ -63,6 +64,14 @@ newtype ErrNetworkUnreachable
 
 instance Exception ErrNetworkUnreachable
 
+-- | Error while trying to get the network tip
+data ErrNetworkTip
+    = ErrNetworkTipNetworkUnreachable ErrNetworkUnreachable
+    | ErrNetworkTipNotFound
+    deriving (Generic, Show, Eq)
+
+instance Exception ErrNetworkTip
+
 -- | Error while trying to send a transaction
 data ErrPostTx
     = ErrPostTxNetworkUnreachable ErrNetworkUnreachable

src/Cardano/Wallet/Network/HttpBridge.hs

@@ -22,7 +22,11 @@ module Cardano.Wallet.Network.HttpBridge
 import Prelude
 
 import Cardano.Wallet.Network
-    ( ErrNetworkUnreachable (..), ErrPostTx (..), NetworkLayer (..) )
+    ( ErrNetworkTip (..)
+    , ErrNetworkUnreachable (..)
+    , ErrPostTx (..)
+    , NetworkLayer (..)
+    )
 import Cardano.Wallet.Network.HttpBridge.Api
     ( ApiT (..), EpochIndex (..), NetworkName (..), api )
 import Cardano.Wallet.Primitive.Types
@@ -36,7 +40,7 @@ import Control.Monad.Catch
 import Control.Monad.Fail
     ( MonadFail )
 import Control.Monad.Trans.Except
-    ( ExceptT (..) )
+    ( ExceptT (..), mapExceptT )
 import Crypto.Hash
     ( HashAlgorithm, digestFromByteString )
 import Data.ByteArray
@@ -86,17 +90,18 @@ rbNextBlocks
     => HttpBridge m -- ^ http-bridge API
     -> SlotId -- ^ Starting point
     -> ExceptT ErrNetworkUnreachable m [Block]
-rbNextBlocks network start = do
-    (tipHash, tip) <- fmap slotId <$> getNetworkTip network
-    epochBlocks <- nextStableEpoch (epochNumber start)
-    additionalBlocks <-
-        if null epochBlocks then
-            unstableBlocks tipHash tip
-        else if length epochBlocks < 1000 then
-            nextStableEpoch (epochNumber start + 1)
-        else
-            pure []
-    pure (epochBlocks ++ additionalBlocks)
+rbNextBlocks network start = maybeTip (getNetworkTip network) >>= \case
+    Just (tipHash, tipHdr) -> do
+        epochBlocks <- nextStableEpoch (epochNumber start)
+        additionalBlocks <-
+            if null epochBlocks then
+                unstableBlocks tipHash (slotId tipHdr)
+            else if length epochBlocks < 1000 then
+                nextStableEpoch (epochNumber start + 1)
+            else
+                pure []
+        pure (epochBlocks ++ additionalBlocks)
+    Nothing -> pure []
   where
     nextStableEpoch ix = do
         epochBlocks <- getEpoch network ix
@@ -113,6 +118,11 @@ rbNextBlocks network start = do
         | start <= tip = fetchBlocksFromTip network start tipHash
         | otherwise    = pure []
 
+    maybeTip = mapExceptT $ fmap $ \case
+        Left (ErrNetworkTipNetworkUnreachable e) -> Left e
+        Left ErrNetworkTipNotFound -> Right Nothing
+        Right tip -> Right (Just tip)
+
 -- Fetch blocks which are not in epoch pack files.
 fetchBlocksFromTip
     :: Monad m
@@ -143,7 +153,7 @@ data HttpBridge m = HttpBridge
     , getEpoch
         :: Word64 -> ExceptT ErrNetworkUnreachable m [Block]
     , getNetworkTip
-        :: ExceptT ErrNetworkUnreachable m (Hash "BlockHeader", BlockHeader)
+        :: ExceptT ErrNetworkTip m (Hash "BlockHeader", BlockHeader)
     , postSignedTx
         :: SignedTx -> ExceptT ErrPostTx m ()
     }
@@ -163,7 +173,10 @@ mkHttpBridge mgr baseUrl network = HttpBridge
             x -> defaultHandler x
 
     , getNetworkTip = ExceptT $ do
-        run (blockHeaderHash <$> cGetNetworkTip network) >>= defaultHandler
+        run (blockHeaderHash <$> cGetNetworkTip network) >>= \case
+            Left (FailureResponse e) | responseStatusCode e == status404 ->
+              return $ Left ErrNetworkTipNotFound
+            x -> left ErrNetworkTipNetworkUnreachable <$> defaultHandler x
 
     , postSignedTx = \tx -> void $ ExceptT $ do
         let e0 = "Failed to send to peers: Blockchain protocol error"
@@ -187,8 +200,15 @@ mkHttpBridge mgr baseUrl network = HttpBridge
         -> IO (Either ErrNetworkUnreachable a)
     defaultHandler = \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 ->
             throwM e
 

test/bench/Main.hs

@@ -50,7 +50,7 @@ import Data.Time.Clock.POSIX
 import Fmt
     ( fmt, (+|), (+||), (|+), (||+) )
 import Say
-    ( say )
+    ( sayErr )
 import System.Environment
     ( getArgs )
 
@@ -88,12 +88,12 @@ runBenchmarks :: [IO (Text, Double)] -> IO ()
 runBenchmarks bs = do
     initializeTime
     rs <- sequence bs
-    say "\n\nAll results:"
+    sayErr "\n\nAll results:"
     mapM_ (uncurry printResult) rs
 
 bench :: Text -> IO () -> IO (Text, Double)
 bench benchName action = do
-    say $ "Running " <> benchName
+    sayErr $ "Running " <> benchName
     start <- getTime
     res <- action
     evaluate (rnf res)
@@ -103,7 +103,7 @@ bench benchName action = do
     pure (benchName, dur)
 
 printResult :: Text -> Double -> IO ()
-printResult benchName dur = say . fmt $ "  "+|benchName|+": "+|secs dur|+""
+printResult benchName dur = sayErr . fmt $ "  "+|benchName|+": "+|secs dur|+""
 
 {-------------------------------------------------------------------------------
                                   Benchmarks
@@ -115,15 +115,15 @@ bench_restoration network nw = withHttpBridge network $ \port -> do
     dbLayer <- MVar.newDBLayer
     networkLayer <- newNetworkLayer networkName port
     (_, bh) <- unsafeRunExceptT $ networkTip networkLayer
-    say . fmt $ "Note: the "+|networkName|+" tip is at "+||(bh ^. #slotId)||+""
+    sayErr . fmt $ "Note: the "+|networkName|+" tip is at "+||(bh ^. #slotId)||+""
     let walletLayer = mkWalletLayer dbLayer networkLayer
     wallet <- unsafeRunExceptT $ createWallet walletLayer nw
     processWallet walletLayer logChunk wallet
   where
     networkName = toText network
 
 logChunk :: SlotId -> IO ()
-logChunk slot = say . fmt $ "Processing "+||slot||+""
+logChunk slot = sayErr . fmt $ "Processing "+||slot||+""
 
 withHttpBridge :: Network -> (Int -> IO a) -> IO a
 withHttpBridge network action = bracket start stop (const (action port))
@@ -159,11 +159,11 @@ walletSeq = baseWallet
 
 prepareNode :: Network -> IO ()
 prepareNode net = do
-    say . fmt $ "Syncing "+|toText net|+" node... "
+    sayErr . fmt $ "Syncing "+|toText net|+" node... "
     sl <- withHttpBridge net $ \port -> do
         network <- newNetworkLayer (toText net) port
         waitForNodeSync network (toText net) logQuiet
-    say . fmt $ "Completed sync of "+|toText net|+" up to "+||sl||+""
+    sayErr . fmt $ "Completed sync of "+|toText net|+" up to "+||sl||+""
 
 -- | Poll the network tip until it reaches the slot corresponding to the current
 -- time.
@@ -188,7 +188,7 @@ waitForNodeSync network networkName logSlot = loop 10
                 else
                     pure tipBlockSlot
         Left e | retries > 0 -> do
-                     say "Fetching tip failed, retrying shortly..."
+                     sayErr "Fetching tip failed, retrying shortly..."
                      threadDelay 15000000
                      loop (retries - 1)
                | otherwise -> throwIO e

test/integration/Cardano/Wallet/Network/HttpBridgeSpec.hs

@@ -12,7 +12,11 @@ import Cardano.Launcher
 import Cardano.Wallet.Binary
     ( TxWitness (..), encodeSignedTx )
 import Cardano.Wallet.Network
-    ( ErrNetworkUnreachable (..), ErrPostTx (..), NetworkLayer (..) )
+    ( ErrNetworkTip (..)
+    , ErrNetworkUnreachable (..)
+    , ErrPostTx (..)
+    , NetworkLayer (..)
+    )
 import Cardano.Wallet.Primitive.Types
     ( Address (..)
     , Block (..)
@@ -32,7 +36,7 @@ import Control.Concurrent.Async
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
-    ( runExceptT )
+    ( runExceptT, withExceptT )
 import Test.Hspec
     ( Spec, afterAll, beforeAll, describe, it, shouldReturn, shouldSatisfy )
 
@@ -67,7 +71,7 @@ spec = do
 
         it "get unstable blocks for the unstable epoch" $ \(_, network) -> do
             let action = runExceptT $ do
-                    (SlotId ep sl) <- (slotId . snd) <$> networkTip network
+                    (SlotId ep sl) <- (slotId . snd) <$> networkTip' network
                     let sl' = if sl > 2 then sl - 2 else 0
                     blocks <- nextBlocks network (SlotId ep sl')
                     lift $ blocks `shouldSatisfy` (\bs
@@ -78,7 +82,7 @@ spec = do
 
         it "produce no blocks if start is after tip" $ \(_, network) -> do
             let action = runExceptT $ do
-                    SlotId ep sl <- (slotId . snd) <$> networkTip network
+                    SlotId ep sl <- (slotId . snd) <$> networkTip' network
                     length <$> nextBlocks network (SlotId (ep + 1) sl)
             action `shouldReturn` pure 0
 
@@ -88,7 +92,7 @@ spec = do
             let action = do
                     res <- runExceptT $ networkTip network
                     res `shouldSatisfy` \case
-                        Left (ErrNetworkUnreachable _) -> True
+                        Left (ErrNetworkTipNetworkUnreachable _) -> True
                         _ -> error (msg res)
             action `shouldReturn` ()
 
@@ -153,6 +157,11 @@ spec = do
     txEmpty :: Tx
     txEmpty = Tx [] []
 
+    networkTip' = withExceptT unwrap . networkTip
+      where
+        unwrap (ErrNetworkTipNetworkUnreachable e) = e
+        unwrap ErrNetworkTipNotFound = ErrNetworkUnreachable "no tip"
+
     newNetworkLayer =
         HttpBridge.newNetworkLayer "testnet" port
     closeBridge (handle, _) = do