From 543a44b281c663d82865c05cecd3902a929711c6 Mon Sep 17 00:00:00 2001
From: Julian Ospald <julian.ospald@iohk.io>
Date: Mon, 31 Aug 2020 16:06:36 +0200
Subject: [PATCH] Return descriptive 503 when listing stake pools with
 uncomplete sync

Wrt #1971
---
 lib/core/src/Cardano/Wallet.hs                | 10 +++++++
 lib/core/src/Cardano/Wallet/Api/Server.hs     |  6 ++++
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 30 +++++++++++++------
 3 files changed, 37 insertions(+), 9 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
index eaff67baf02..660008b54e9 100644
--- a/lib/core/src/Cardano/Wallet.hs
+++ b/lib/core/src/Cardano/Wallet.hs
@@ -172,6 +172,9 @@ module Cardano.Wallet
 
     -- * Logging
     , WalletLog (..)
+
+    -- * Stake pool listing
+    , ErrListPools (..)
     ) where
 
 import Prelude hiding
@@ -2316,6 +2319,13 @@ data ErrWithdrawalNotWorth
     = ErrWithdrawalNotWorth
     deriving (Generic, Eq, Show)
 
+-- | Errors that can occur when trying to list stake pool.
+data ErrListPools
+    = ErrListPoolsNetworkError ErrNetworkUnavailable
+    | ErrListPoolsPastHorizonException PastHorizonException
+    deriving (Show)
+
+
 {-------------------------------------------------------------------------------
                                    Utils
 -------------------------------------------------------------------------------}
diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs
index a4213f014b5..1559bdf41dd 100644
--- a/lib/core/src/Cardano/Wallet/Api/Server.hs
+++ b/lib/core/src/Cardano/Wallet/Api/Server.hs
@@ -109,6 +109,7 @@ import Cardano.Wallet
     , ErrImportAddress (..)
     , ErrImportRandomAddress (..)
     , ErrJoinStakePool (..)
+    , ErrListPools (..)
     , ErrListTransactions (..)
     , ErrListUTxOStatistics (..)
     , ErrMkTx (..)
@@ -2480,6 +2481,11 @@ instance LiftHandler ErrWithdrawalNotWorth where
                 , "request."
                 ]
 
+instance LiftHandler ErrListPools where
+    handler = \case
+        ErrListPoolsNetworkError e -> handler e
+        ErrListPoolsPastHorizonException e -> handler e
+
 instance LiftHandler (Request, ServerError) where
     handler (req, err@(ServerError code _ body headers))
       | not (isJSON body) = case code of
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 2fc4c4d62a4..f5c5afa31fd 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -37,6 +37,8 @@ import Cardano.Pool.DB
     ( DBLayer (..), ErrPointAlreadyExists (..), readPoolLifeCycleStatus )
 import Cardano.Pool.Metadata
     ( StakePoolMetadataFetchLog )
+import Cardano.Wallet
+    ( ErrListPools (..) )
 import Cardano.Wallet.Api.Types
     ( ApiT (..) )
 import Cardano.Wallet.Network
@@ -49,7 +51,7 @@ import Cardano.Wallet.Network
     , follow
     )
 import Cardano.Wallet.Primitive.Slotting
-    ( TimeInterpreter, firstSlotInEpoch, startTime )
+    ( PastHorizonException (..), TimeInterpreter, firstSlotInEpoch, startTime )
 import Cardano.Wallet.Primitive.Types
     ( ActiveSlotCoefficient (..)
     , BlockHeader
@@ -84,16 +86,20 @@ import Cardano.Wallet.Unsafe
     ( unsafeMkPercentage )
 import Control.Concurrent
     ( threadDelay )
+import Control.Exception
+    ( throwIO, try )
 import Control.Monad
     ( forM, forM_, forever, when )
 import Control.Monad.IO.Class
     ( liftIO )
 import Control.Monad.Trans.Except
-    ( ExceptT (..), runExceptT, withExceptT )
+    ( ExceptT (..), mapExceptT, runExceptT, throwE, withExceptT )
 import Control.Monad.Trans.State
     ( State, evalState, state )
 import Control.Tracer
     ( Tracer, contramap, traceWith )
+import Data.Bifunctor
+    ( first )
 import Data.Function
     ( (&) )
 import Data.Generics.Internal.VL.Lens
@@ -155,7 +161,7 @@ data StakePoolLayer = StakePoolLayer
         :: EpochNo
         -- Exclude all pools that retired in or before this epoch.
         -> Coin
-        -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool]
+        -> ExceptT ErrListPools IO [Api.ApiStakePool]
     }
 
 newStakePoolLayer
@@ -184,17 +190,18 @@ newStakePoolLayer nl db@DBLayer {..} =
         :: EpochNo
         -- Exclude all pools that retired in or before this epoch.
         -> Coin
-        -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool]
+        -> ExceptT ErrListPools IO [Api.ApiStakePool]
     _listPools currentEpoch userStake = do
         tip <- withExceptT fromErrCurrentNodeTip $ currentNodeTip nl
-        rawLsqData <- stakeDistribution nl tip userStake
+        rawLsqData <- mapExceptT (fmap (first ErrListPoolsNetworkError))
+                        $ stakeDistribution nl tip userStake
         let lsqData = combineLsqData rawLsqData
         dbData <- liftIO $ readPoolDbData db
         seed <- liftIO $ atomically readSystemSeed
         -- TODO:
         -- Use a more efficient way of filtering out retired pools.
         -- See: https://jira.iohk.io/projects/ADP/issues/ADP-383
-        liftIO $
+        r <- liftIO $ try $
             sortByReward seed
             . filter (not . poolIsRetired)
             . map snd
@@ -204,11 +211,16 @@ newStakePoolLayer nl db@DBLayer {..} =
                 (nOpt rawLsqData)
                 lsqData
                 dbData
+        case r of
+            Left e@(PastHorizon{}) -> throwE (ErrListPoolsPastHorizonException e)
+            Right r' -> pure r'
+
       where
-        fromErrCurrentNodeTip :: ErrCurrentNodeTip -> ErrNetworkUnavailable
+
+        fromErrCurrentNodeTip :: ErrCurrentNodeTip -> ErrListPools
         fromErrCurrentNodeTip = \case
-            ErrCurrentNodeTipNetworkUnreachable e -> e
-            ErrCurrentNodeTipNotFound -> ErrNetworkUnreachable "tip not found"
+            ErrCurrentNodeTipNetworkUnreachable e -> ErrListPoolsNetworkError e
+            ErrCurrentNodeTipNotFound -> ErrListPoolsNetworkError $ ErrNetworkUnreachable "tip not found"
 
         epochIsInFuture :: EpochNo -> Bool
         epochIsInFuture = (> currentEpoch)