{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- HTTP-client(s) for fetching stake pool metadata from remote servers (directly
-- from pool operators, or from smash).

module Cardano.Pool.Metadata
    (

    -- * Fetch
      fetchFromRemote
    , StakePoolMetadataFetchLog (..)
    , fetchDelistedPools
    , healthCheck
    , isHealthyStatus
    , toHealthCheckSMASH
    , HealthStatusSMASH (..)

    -- * Construct URLs
    , UrlBuilder
    , identityUrlBuilder
    , registryUrlBuilder

    -- * re-exports
    , Manager
    , newManager
    , defaultManagerSettings

    -- * Types
    , SMASHPoolId (..)
    ) where

import Prelude

import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Cardano.Wallet.Api.Types
    ( HealthCheckSMASH (..), HealthStatusSMASH (..), defaultRecordTypeOptions )
import Cardano.Wallet.Primitive.AddressDerivation
    ( hex )
import Cardano.Wallet.Primitive.Types
    ( PoolId (..)
    , StakePoolMetadata (..)
    , StakePoolMetadataHash (..)
    , StakePoolMetadataUrl (..)
    , decodePoolIdBech32
    )
import Control.Monad
    ( forM, when )
import Control.Monad.IO.Class
    ( MonadIO (..) )
import Control.Monad.Trans.Except
    ( ExceptT (..), except, runExceptT, throwE, withExceptT )
import Control.Tracer
    ( Tracer, traceWith )
import Crypto.Hash.Utils
    ( blake2b256 )
import Data.Aeson
    ( FromJSON
    , ToJSON
    , eitherDecodeStrict
    , fieldLabelModifier
    , genericParseJSON
    , genericToJSON
    , parseJSON
    , toJSON
    )
import Data.Bifunctor
    ( first )
import Data.ByteArray.Encoding
    ( Base (..), convertToBase )
import Data.ByteString
    ( ByteString )
import Data.Coerce
    ( coerce )
import Data.List
    ( intercalate )
import Data.Text.Class
    ( TextDecodingError (..), ToText (..), fromText )
import Fmt
    ( pretty )
import GHC.Generics
    ( Generic )
import Network.HTTP.Client
    ( HttpException (..)
    , Manager
    , ManagerSettings
    , brConsume
    , brReadSome
    , managerResponseTimeout
    , requestFromURI
    , responseBody
    , responseStatus
    , responseTimeoutMicro
    , withResponse
    )
import Network.HTTP.Types.Status
    ( status200, status404 )
import Network.URI
    ( URI (..), parseURI )
import UnliftIO.Exception
    ( IOException, handle )

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.HTTP.Client.TLS as HTTPS

-- | Build the SMASH metadata fetch endpoint for a single pool. Does not
-- contain leading '/'.
metadaFetchEp :: PoolId -> StakePoolMetadataHash -> String
metadaFetchEp :: PoolId -> StakePoolMetadataHash -> String
metadaFetchEp PoolId
pid (StakePoolMetadataHash ByteString
bytes)
    = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String
"api", String
"v1", String
"metadata"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
pidStr, String
hashStr])
  where
    hashStr :: String
hashStr = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 ByteString
bytes
    pidStr :: String
pidStr  = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ PoolId -> Text
forall a. ToText a => a -> Text
toText PoolId
pid

-- TODO: use SMASH servant types
healthCheckEP :: String
healthCheckEP :: String
healthCheckEP = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" [Text
"api", Text
"v1", Text
"status"]

delistedEP :: String
delistedEP :: String
delistedEP = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" [Text
"api", Text
"v1", Text
"delisted"]

-- | TODO: import SMASH types
newtype SMASHPoolId = SMASHPoolId
    { SMASHPoolId -> Text
poolId :: T.Text
    } deriving stock (SMASHPoolId -> SMASHPoolId -> Bool
(SMASHPoolId -> SMASHPoolId -> Bool)
-> (SMASHPoolId -> SMASHPoolId -> Bool) -> Eq SMASHPoolId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SMASHPoolId -> SMASHPoolId -> Bool
$c/= :: SMASHPoolId -> SMASHPoolId -> Bool
== :: SMASHPoolId -> SMASHPoolId -> Bool
$c== :: SMASHPoolId -> SMASHPoolId -> Bool
Eq, Int -> SMASHPoolId -> ShowS
[SMASHPoolId] -> ShowS
SMASHPoolId -> String
(Int -> SMASHPoolId -> ShowS)
-> (SMASHPoolId -> String)
-> ([SMASHPoolId] -> ShowS)
-> Show SMASHPoolId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SMASHPoolId] -> ShowS
$cshowList :: [SMASHPoolId] -> ShowS
show :: SMASHPoolId -> String
$cshow :: SMASHPoolId -> String
showsPrec :: Int -> SMASHPoolId -> ShowS
$cshowsPrec :: Int -> SMASHPoolId -> ShowS
Show, Eq SMASHPoolId
Eq SMASHPoolId
-> (SMASHPoolId -> SMASHPoolId -> Ordering)
-> (SMASHPoolId -> SMASHPoolId -> Bool)
-> (SMASHPoolId -> SMASHPoolId -> Bool)
-> (SMASHPoolId -> SMASHPoolId -> Bool)
-> (SMASHPoolId -> SMASHPoolId -> Bool)
-> (SMASHPoolId -> SMASHPoolId -> SMASHPoolId)
-> (SMASHPoolId -> SMASHPoolId -> SMASHPoolId)
-> Ord SMASHPoolId
SMASHPoolId -> SMASHPoolId -> Bool
SMASHPoolId -> SMASHPoolId -> Ordering
SMASHPoolId -> SMASHPoolId -> SMASHPoolId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SMASHPoolId -> SMASHPoolId -> SMASHPoolId
$cmin :: SMASHPoolId -> SMASHPoolId -> SMASHPoolId
max :: SMASHPoolId -> SMASHPoolId -> SMASHPoolId
$cmax :: SMASHPoolId -> SMASHPoolId -> SMASHPoolId
>= :: SMASHPoolId -> SMASHPoolId -> Bool
$c>= :: SMASHPoolId -> SMASHPoolId -> Bool
> :: SMASHPoolId -> SMASHPoolId -> Bool
$c> :: SMASHPoolId -> SMASHPoolId -> Bool
<= :: SMASHPoolId -> SMASHPoolId -> Bool
$c<= :: SMASHPoolId -> SMASHPoolId -> Bool
< :: SMASHPoolId -> SMASHPoolId -> Bool
$c< :: SMASHPoolId -> SMASHPoolId -> Bool
compare :: SMASHPoolId -> SMASHPoolId -> Ordering
$ccompare :: SMASHPoolId -> SMASHPoolId -> Ordering
$cp1Ord :: Eq SMASHPoolId
Ord)
      deriving ((forall x. SMASHPoolId -> Rep SMASHPoolId x)
-> (forall x. Rep SMASHPoolId x -> SMASHPoolId)
-> Generic SMASHPoolId
forall x. Rep SMASHPoolId x -> SMASHPoolId
forall x. SMASHPoolId -> Rep SMASHPoolId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SMASHPoolId x -> SMASHPoolId
$cfrom :: forall x. SMASHPoolId -> Rep SMASHPoolId x
Generic)

instance FromJSON SMASHPoolId where
    parseJSON :: Value -> Parser SMASHPoolId
parseJSON = Options -> Value -> Parser SMASHPoolId
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultRecordTypeOptions
        { fieldLabelModifier :: ShowS
fieldLabelModifier = ShowS
forall a. a -> a
id }

instance ToJSON SMASHPoolId where
    toJSON :: SMASHPoolId -> Value
toJSON = Options -> SMASHPoolId -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultRecordTypeOptions
        { fieldLabelModifier :: ShowS
fieldLabelModifier = ShowS
forall a. a -> a
id }

toPoolId :: SMASHPoolId -> Either TextDecodingError PoolId
toPoolId :: SMASHPoolId -> Either TextDecodingError PoolId
toPoolId (SMASHPoolId Text
pid) =
    (TextDecodingError -> Either TextDecodingError PoolId)
-> (PoolId -> Either TextDecodingError PoolId)
-> Either TextDecodingError PoolId
-> Either TextDecodingError PoolId
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\TextDecodingError
_ -> Text -> Either TextDecodingError PoolId
decodePoolIdBech32 Text
pid) PoolId -> Either TextDecodingError PoolId
forall a b. b -> Either a b
Right (Text -> Either TextDecodingError PoolId
forall a. FromText a => Text -> Either TextDecodingError a
fromText @PoolId Text
pid)

-- | Some default settings, overriding some of the library's default with
-- stricter values.
defaultManagerSettings :: ManagerSettings
defaultManagerSettings :: ManagerSettings
defaultManagerSettings =
    ManagerSettings
HTTPS.tlsManagerSettings
        { managerResponseTimeout :: ResponseTimeout
managerResponseTimeout = Int -> ResponseTimeout
responseTimeoutMicro Int
tenSeconds }
  where
    tenSeconds :: Int
tenSeconds = Int
10_000_000 -- in μs

-- | Create a connection manager that supports TLS connections.
newManager :: MonadIO m => ManagerSettings -> m Manager
newManager :: ManagerSettings -> m Manager
newManager = ManagerSettings -> m Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
HTTPS.newTlsManagerWith

-- | A type-alias to ease signatures
type UrlBuilder
    =  PoolId
    -> StakePoolMetadataUrl
    -> StakePoolMetadataHash
    -> Either HttpException URI

-- | Simply return a pool metadata url, unchanged
identityUrlBuilder
    :: UrlBuilder
identityUrlBuilder :: UrlBuilder
identityUrlBuilder PoolId
_ (StakePoolMetadataUrl Text
url) StakePoolMetadataHash
_ =
    Either HttpException URI
-> (URI -> Either HttpException URI)
-> Maybe URI
-> Either HttpException URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HttpException -> Either HttpException URI
forall a b. a -> Either a b
Left HttpException
e) URI -> Either HttpException URI
forall a b. b -> Either a b
Right (Maybe URI -> Either HttpException URI)
-> Maybe URI -> Either HttpException URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI (Text -> String
T.unpack Text
url)
  where
    e :: HttpException
e = String -> String -> HttpException
InvalidUrlException (Text -> String
T.unpack Text
url) String
"Invalid URL"

-- | Build a URL from a metadata hash compatible with an aggregation registry
registryUrlBuilder
    :: URI
    -> UrlBuilder
registryUrlBuilder :: URI -> UrlBuilder
registryUrlBuilder URI
baseUrl PoolId
pid StakePoolMetadataUrl
_ StakePoolMetadataHash
hash =
    URI -> Either HttpException URI
forall a b. b -> Either a b
Right (URI -> Either HttpException URI)
-> URI -> Either HttpException URI
forall a b. (a -> b) -> a -> b
$ URI
baseUrl
        { uriPath :: String
uriPath = String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PoolId -> StakePoolMetadataHash -> String
metadaFetchEp PoolId
pid StakePoolMetadataHash
hash
        }

-- | A smash GET request that reads the result at once into memory.
smashRequest
    :: Tracer IO StakePoolMetadataFetchLog
    -> URI
    -> Manager
    -> ExceptT String IO ByteString
smashRequest :: Tracer IO StakePoolMetadataFetchLog
-> URI -> Manager -> ExceptT String IO ByteString
smashRequest Tracer IO StakePoolMetadataFetchLog
tr URI
uri Manager
manager = ExceptT String IO ByteString
getPayload
  where
    getPayload :: ExceptT String IO ByteString
    getPayload :: ExceptT String IO ByteString
getPayload = do
        Request
req <- (SomeException -> String)
-> ExceptT SomeException IO Request -> ExceptT String IO Request
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT SomeException -> String
forall a. Show a => a -> String
show (ExceptT SomeException IO Request -> ExceptT String IO Request)
-> ExceptT SomeException IO Request -> ExceptT String IO Request
forall a b. (a -> b) -> a -> b
$ Either SomeException Request -> ExceptT SomeException IO Request
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either SomeException Request -> ExceptT SomeException IO Request)
-> Either SomeException Request -> ExceptT SomeException IO Request
forall a b. (a -> b) -> a -> b
$ URI -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI URI
uri
        IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ Tracer IO StakePoolMetadataFetchLog
-> StakePoolMetadataFetchLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO StakePoolMetadataFetchLog
tr (StakePoolMetadataFetchLog -> IO ())
-> StakePoolMetadataFetchLog -> IO ()
forall a b. (a -> b) -> a -> b
$ URI -> StakePoolMetadataFetchLog
MsgFetchSMASH URI
uri
        IO (Either String ByteString) -> ExceptT String IO ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
            (IO (Either String ByteString) -> ExceptT String IO ByteString)
-> IO (Either String ByteString) -> ExceptT String IO ByteString
forall a b. (a -> b) -> a -> b
$ (IOException -> IO (Either String ByteString))
-> IO (Either String ByteString) -> IO (Either String ByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOException -> IO (Either String ByteString)
forall (m :: * -> *) a.
Monad m =>
IOException -> m (Either String a)
fromIOException
            (IO (Either String ByteString) -> IO (Either String ByteString))
-> IO (Either String ByteString) -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ (HttpException -> IO (Either String ByteString))
-> IO (Either String ByteString) -> IO (Either String ByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle HttpException -> IO (Either String ByteString)
forall (m :: * -> *) a.
Monad m =>
HttpException -> m (Either String a)
fromHttpException
            (IO (Either String ByteString) -> IO (Either String ByteString))
-> IO (Either String ByteString) -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ Request
-> Manager
-> (Response BodyReader -> IO (Either String ByteString))
-> IO (Either String ByteString)
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
manager Response BodyReader -> IO (Either String ByteString)
handleResponseStatus

    handleResponseStatus :: Response BodyReader -> IO (Either String ByteString)
handleResponseStatus Response BodyReader
response = case Response BodyReader -> Status
forall body. Response body -> Status
responseStatus Response BodyReader
response of
        Status
s | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 -> do
            let body :: BodyReader
body = Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
response
            ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ([ByteString] -> ByteString)
-> [ByteString]
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat ([ByteString] -> Either String ByteString)
-> IO [ByteString] -> IO (Either String ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BodyReader -> IO [ByteString]
brConsume BodyReader
body
        Status
s ->
            Either String ByteString -> IO (Either String ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ByteString -> IO (Either String ByteString))
-> Either String ByteString -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                [ String
"The server replied with something unexpected: "
                , Status -> String
forall a. Show a => a -> String
show Status
s
                ]

    fromHttpException :: Monad m => HttpException -> m (Either String a)
    fromHttpException :: HttpException -> m (Either String a)
fromHttpException = Either String a -> m (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> m (Either String a))
-> (HttpException -> Either String a)
-> HttpException
-> m (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (HttpException -> String) -> HttpException -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"HTTP exception: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (HttpException -> String) -> HttpException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> String
forall a. Show a => a -> String
show

-- | Gets the health status from the SMASH server. Returns
-- @Nothing@ if the server is unreachable.
healthCheck
    :: Tracer IO StakePoolMetadataFetchLog
    -> URI
    -> Manager
    -> IO (Maybe HealthStatusSMASH)
healthCheck :: Tracer IO StakePoolMetadataFetchLog
-> URI -> Manager -> IO (Maybe HealthStatusSMASH)
healthCheck Tracer IO StakePoolMetadataFetchLog
tr URI
uri Manager
manager = ExceptT String IO HealthStatusSMASH -> IO (Maybe HealthStatusSMASH)
runExceptTLog (ExceptT String IO HealthStatusSMASH
 -> IO (Maybe HealthStatusSMASH))
-> ExceptT String IO HealthStatusSMASH
-> IO (Maybe HealthStatusSMASH)
forall a b. (a -> b) -> a -> b
$ do
    ByteString
pl <- Tracer IO StakePoolMetadataFetchLog
-> URI -> Manager -> ExceptT String IO ByteString
smashRequest Tracer IO StakePoolMetadataFetchLog
tr
        (URI
uri { uriPath :: String
uriPath = String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
healthCheckEP , uriQuery :: String
uriQuery = String
"", uriFragment :: String
uriFragment = String
"" })
        Manager
manager
    Either String HealthStatusSMASH
-> ExceptT String IO HealthStatusSMASH
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String HealthStatusSMASH
 -> ExceptT String IO HealthStatusSMASH)
-> (ByteString -> Either String HealthStatusSMASH)
-> ByteString
-> ExceptT String IO HealthStatusSMASH
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromJSON HealthStatusSMASH =>
ByteString -> Either String HealthStatusSMASH
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict @HealthStatusSMASH (ByteString -> ExceptT String IO HealthStatusSMASH)
-> ByteString -> ExceptT String IO HealthStatusSMASH
forall a b. (a -> b) -> a -> b
$ ByteString
pl
  where
    runExceptTLog
        :: ExceptT String IO HealthStatusSMASH
        -> IO (Maybe HealthStatusSMASH)
    runExceptTLog :: ExceptT String IO HealthStatusSMASH -> IO (Maybe HealthStatusSMASH)
runExceptTLog ExceptT String IO HealthStatusSMASH
action = ExceptT String IO HealthStatusSMASH
-> IO (Either String HealthStatusSMASH)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT String IO HealthStatusSMASH
action IO (Either String HealthStatusSMASH)
-> (Either String HealthStatusSMASH
    -> IO (Maybe HealthStatusSMASH))
-> IO (Maybe HealthStatusSMASH)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
msg ->
            Maybe HealthStatusSMASH
forall a. Maybe a
Nothing Maybe HealthStatusSMASH -> IO () -> IO (Maybe HealthStatusSMASH)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer IO StakePoolMetadataFetchLog
-> StakePoolMetadataFetchLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO StakePoolMetadataFetchLog
tr (String -> StakePoolMetadataFetchLog
MsgFetchHealthCheckFailure String
msg)
        Right HealthStatusSMASH
health -> do
            Tracer IO StakePoolMetadataFetchLog
-> StakePoolMetadataFetchLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO StakePoolMetadataFetchLog
tr (HealthStatusSMASH -> StakePoolMetadataFetchLog
MsgFetchHealthCheckSuccess HealthStatusSMASH
health)
            Maybe HealthStatusSMASH -> IO (Maybe HealthStatusSMASH)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe HealthStatusSMASH -> IO (Maybe HealthStatusSMASH))
-> Maybe HealthStatusSMASH -> IO (Maybe HealthStatusSMASH)
forall a b. (a -> b) -> a -> b
$ HealthStatusSMASH -> Maybe HealthStatusSMASH
forall a. a -> Maybe a
Just HealthStatusSMASH
health

-- | Convert the result of @healthCheck@, which represents the
-- server response to our own @HealthCheckSMASH@ type, which is a
-- superset of it.
toHealthCheckSMASH :: Maybe HealthStatusSMASH -> HealthCheckSMASH
toHealthCheckSMASH :: Maybe HealthStatusSMASH -> HealthCheckSMASH
toHealthCheckSMASH = \case
    (Just HealthStatusSMASH
health)
        | HealthStatusSMASH -> Bool
isHealthyStatus HealthStatusSMASH
health -> HealthCheckSMASH
Available
        | Bool
otherwise -> HealthCheckSMASH
Unavailable
    Maybe HealthStatusSMASH
_ -> HealthCheckSMASH
Unreachable

isHealthyStatus :: HealthStatusSMASH -> Bool
isHealthyStatus :: HealthStatusSMASH -> Bool
isHealthyStatus (HealthStatusSMASH {Text
$sel:version:HealthStatusSMASH :: HealthStatusSMASH -> Text
$sel:status:HealthStatusSMASH :: HealthStatusSMASH -> Text
version :: Text
status :: Text
..}) = Text -> Text
T.toLower Text
status Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"ok"

fetchDelistedPools
    :: Tracer IO StakePoolMetadataFetchLog
    -> URI
    -> Manager
    -> IO (Maybe [PoolId])
fetchDelistedPools :: Tracer IO StakePoolMetadataFetchLog
-> URI -> Manager -> IO (Maybe [PoolId])
fetchDelistedPools Tracer IO StakePoolMetadataFetchLog
tr URI
uri Manager
manager = ExceptT String IO [PoolId] -> IO (Maybe [PoolId])
runExceptTLog (ExceptT String IO [PoolId] -> IO (Maybe [PoolId]))
-> ExceptT String IO [PoolId] -> IO (Maybe [PoolId])
forall a b. (a -> b) -> a -> b
$ do
    ByteString
pl <- Tracer IO StakePoolMetadataFetchLog
-> URI -> Manager -> ExceptT String IO ByteString
smashRequest Tracer IO StakePoolMetadataFetchLog
tr
        (URI
uri { uriPath :: String
uriPath = String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
delistedEP , uriQuery :: String
uriQuery = String
"", uriFragment :: String
uriFragment = String
"" })
        Manager
manager
    [SMASHPoolId]
smashPids <- Either String [SMASHPoolId] -> ExceptT String IO [SMASHPoolId]
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String [SMASHPoolId] -> ExceptT String IO [SMASHPoolId])
-> Either String [SMASHPoolId] -> ExceptT String IO [SMASHPoolId]
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String [SMASHPoolId]
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict @[SMASHPoolId] ByteString
pl
    [SMASHPoolId]
-> (SMASHPoolId -> ExceptT String IO PoolId)
-> ExceptT String IO [PoolId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [SMASHPoolId]
smashPids ((SMASHPoolId -> ExceptT String IO PoolId)
 -> ExceptT String IO [PoolId])
-> (SMASHPoolId -> ExceptT String IO PoolId)
-> ExceptT String IO [PoolId]
forall a b. (a -> b) -> a -> b
$ Either String PoolId -> ExceptT String IO PoolId
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String PoolId -> ExceptT String IO PoolId)
-> (SMASHPoolId -> Either String PoolId)
-> SMASHPoolId
-> ExceptT String IO PoolId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDecodingError -> String)
-> Either TextDecodingError PoolId -> Either String PoolId
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TextDecodingError -> String
getTextDecodingError (Either TextDecodingError PoolId -> Either String PoolId)
-> (SMASHPoolId -> Either TextDecodingError PoolId)
-> SMASHPoolId
-> Either String PoolId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMASHPoolId -> Either TextDecodingError PoolId
toPoolId
  where
    runExceptTLog
        :: ExceptT String IO [PoolId]
        -> IO (Maybe [PoolId])
    runExceptTLog :: ExceptT String IO [PoolId] -> IO (Maybe [PoolId])
runExceptTLog ExceptT String IO [PoolId]
action = ExceptT String IO [PoolId] -> IO (Either String [PoolId])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT String IO [PoolId]
action IO (Either String [PoolId])
-> (Either String [PoolId] -> IO (Maybe [PoolId]))
-> IO (Maybe [PoolId])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
msg ->
            Maybe [PoolId]
forall a. Maybe a
Nothing Maybe [PoolId] -> IO () -> IO (Maybe [PoolId])
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer IO StakePoolMetadataFetchLog
-> StakePoolMetadataFetchLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO StakePoolMetadataFetchLog
tr (String -> StakePoolMetadataFetchLog
MsgFetchDelistedPoolsFailure String
msg)

        Right [PoolId]
meta ->
            [PoolId] -> Maybe [PoolId]
forall a. a -> Maybe a
Just [PoolId]
meta Maybe [PoolId] -> IO () -> IO (Maybe [PoolId])
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer IO StakePoolMetadataFetchLog
-> StakePoolMetadataFetchLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO StakePoolMetadataFetchLog
tr ([PoolId] -> StakePoolMetadataFetchLog
MsgFetchDelistedPoolsSuccess [PoolId]
meta)

-- TODO: refactor/simplify this
fetchFromRemote
    :: Tracer IO StakePoolMetadataFetchLog
    -> [UrlBuilder]
    -> Manager
    -> PoolId
    -> StakePoolMetadataUrl
    -> StakePoolMetadataHash
    -> IO (Maybe StakePoolMetadata)
fetchFromRemote :: Tracer IO StakePoolMetadataFetchLog
-> [UrlBuilder]
-> Manager
-> PoolId
-> StakePoolMetadataUrl
-> StakePoolMetadataHash
-> IO (Maybe StakePoolMetadata)
fetchFromRemote Tracer IO StakePoolMetadataFetchLog
tr [UrlBuilder]
builders Manager
manager PoolId
pid StakePoolMetadataUrl
url StakePoolMetadataHash
hash = ExceptT String IO StakePoolMetadata -> IO (Maybe StakePoolMetadata)
runExceptTLog (ExceptT String IO StakePoolMetadata
 -> IO (Maybe StakePoolMetadata))
-> ExceptT String IO StakePoolMetadata
-> IO (Maybe StakePoolMetadata)
forall a b. (a -> b) -> a -> b
$ do
    ByteString
chunk <- URI -> ExceptT String IO (Maybe ByteString)
getChunk (URI -> ExceptT String IO (Maybe ByteString))
-> [UrlBuilder] -> ExceptT String IO ByteString
forall (m :: * -> *) a a.
(Show a, MonadIO m) =>
(URI -> ExceptT String m (Maybe a))
-> [PoolId
    -> StakePoolMetadataUrl -> StakePoolMetadataHash -> Either a URI]
-> ExceptT String m a
`fromFirst` [UrlBuilder]
builders
    Bool -> ExceptT String IO () -> ExceptT String IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
BS.length ByteString
chunk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
512) (ExceptT String IO () -> ExceptT String IO ())
-> ExceptT String IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> ExceptT String IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
        String
"Metadata exceeds max length of 512 bytes"
    Bool -> ExceptT String IO () -> ExceptT String IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
blake2b256 ByteString
chunk ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= StakePoolMetadataHash -> ByteString
coerce StakePoolMetadataHash
hash) (ExceptT String IO () -> ExceptT String IO ())
-> ExceptT String IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> ExceptT String IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String IO ()) -> String -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
"Metadata hash mismatch. Saw: "
        , ByteString -> String
B8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
hex (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
blake2b256 ByteString
chunk
        , String
", but expected: "
        , ByteString -> String
B8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
hex (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ StakePoolMetadataHash -> ByteString
coerce @_ @ByteString StakePoolMetadataHash
hash
        ]
    Either String StakePoolMetadata
-> ExceptT String IO StakePoolMetadata
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String StakePoolMetadata
 -> ExceptT String IO StakePoolMetadata)
-> Either String StakePoolMetadata
-> ExceptT String IO StakePoolMetadata
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String StakePoolMetadata
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict ByteString
chunk
  where
    runExceptTLog
        :: ExceptT String IO StakePoolMetadata
        -> IO (Maybe StakePoolMetadata)
    runExceptTLog :: ExceptT String IO StakePoolMetadata -> IO (Maybe StakePoolMetadata)
runExceptTLog ExceptT String IO StakePoolMetadata
action = ExceptT String IO StakePoolMetadata
-> IO (Either String StakePoolMetadata)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT String IO StakePoolMetadata
action IO (Either String StakePoolMetadata)
-> (Either String StakePoolMetadata
    -> IO (Maybe StakePoolMetadata))
-> IO (Maybe StakePoolMetadata)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
msg ->
            Maybe StakePoolMetadata
forall a. Maybe a
Nothing Maybe StakePoolMetadata -> IO () -> IO (Maybe StakePoolMetadata)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer IO StakePoolMetadataFetchLog
-> StakePoolMetadataFetchLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO StakePoolMetadataFetchLog
tr (StakePoolMetadataHash -> String -> StakePoolMetadataFetchLog
MsgFetchPoolMetadataFailure StakePoolMetadataHash
hash String
msg)

        Right StakePoolMetadata
meta ->
            StakePoolMetadata -> Maybe StakePoolMetadata
forall a. a -> Maybe a
Just StakePoolMetadata
meta Maybe StakePoolMetadata -> IO () -> IO (Maybe StakePoolMetadata)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer IO StakePoolMetadataFetchLog
-> StakePoolMetadataFetchLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO StakePoolMetadataFetchLog
tr (StakePoolMetadataHash
-> StakePoolMetadata -> StakePoolMetadataFetchLog
MsgFetchPoolMetadataSuccess StakePoolMetadataHash
hash StakePoolMetadata
meta)

    -- Try each builder in order, but only if the previous builder led to an
    -- IO exception. Other exceptions like HTTP exceptions are treated as
    -- 'normal' responses from the an aggregation server and do not cause a
    -- retry.
    fromFirst :: (URI -> ExceptT String m (Maybe a))
-> [PoolId
    -> StakePoolMetadataUrl -> StakePoolMetadataHash -> Either a URI]
-> ExceptT String m a
fromFirst URI -> ExceptT String m (Maybe a)
_ [] =
        String -> ExceptT String m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Metadata server(s) didn't reply in a timely manner."
    fromFirst URI -> ExceptT String m (Maybe a)
action (PoolId
-> StakePoolMetadataUrl -> StakePoolMetadataHash -> Either a URI
builder:[PoolId
 -> StakePoolMetadataUrl -> StakePoolMetadataHash -> Either a URI]
rest) = do
        URI
uri <- (a -> String) -> ExceptT a m URI -> ExceptT String m URI
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT a -> String
forall a. Show a => a -> String
show (ExceptT a m URI -> ExceptT String m URI)
-> ExceptT a m URI -> ExceptT String m URI
forall a b. (a -> b) -> a -> b
$ Either a URI -> ExceptT a m URI
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either a URI -> ExceptT a m URI)
-> Either a URI -> ExceptT a m URI
forall a b. (a -> b) -> a -> b
$ PoolId
-> StakePoolMetadataUrl -> StakePoolMetadataHash -> Either a URI
builder PoolId
pid StakePoolMetadataUrl
url StakePoolMetadataHash
hash
        URI -> ExceptT String m (Maybe a)
action URI
uri ExceptT String m (Maybe a)
-> (Maybe a -> ExceptT String m a) -> ExceptT String m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe a
Nothing -> do
                IO () -> ExceptT String m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String m ()) -> IO () -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ Tracer IO StakePoolMetadataFetchLog
-> StakePoolMetadataFetchLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO StakePoolMetadataFetchLog
tr (StakePoolMetadataFetchLog -> IO ())
-> StakePoolMetadataFetchLog -> IO ()
forall a b. (a -> b) -> a -> b
$ URI -> Bool -> StakePoolMetadataFetchLog
MsgFetchPoolMetadataFallback URI
uri ([PoolId
 -> StakePoolMetadataUrl -> StakePoolMetadataHash -> Either a URI]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PoolId
 -> StakePoolMetadataUrl -> StakePoolMetadataHash -> Either a URI]
rest)
                (URI -> ExceptT String m (Maybe a))
-> [PoolId
    -> StakePoolMetadataUrl -> StakePoolMetadataHash -> Either a URI]
-> ExceptT String m a
fromFirst URI -> ExceptT String m (Maybe a)
action [PoolId
 -> StakePoolMetadataUrl -> StakePoolMetadataHash -> Either a URI]
rest
            Just a
chunk ->
                a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
chunk

    getChunk :: URI -> ExceptT String IO (Maybe ByteString)
    getChunk :: URI -> ExceptT String IO (Maybe ByteString)
getChunk URI
uri = do
        Request
req <- (SomeException -> String)
-> ExceptT SomeException IO Request -> ExceptT String IO Request
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT SomeException -> String
forall a. Show a => a -> String
show (ExceptT SomeException IO Request -> ExceptT String IO Request)
-> ExceptT SomeException IO Request -> ExceptT String IO Request
forall a b. (a -> b) -> a -> b
$ Either SomeException Request -> ExceptT SomeException IO Request
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either SomeException Request -> ExceptT SomeException IO Request)
-> Either SomeException Request -> ExceptT SomeException IO Request
forall a b. (a -> b) -> a -> b
$ URI -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI URI
uri
        IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ Tracer IO StakePoolMetadataFetchLog
-> StakePoolMetadataFetchLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO StakePoolMetadataFetchLog
tr (StakePoolMetadataFetchLog -> IO ())
-> StakePoolMetadataFetchLog -> IO ()
forall a b. (a -> b) -> a -> b
$ StakePoolMetadataHash -> URI -> StakePoolMetadataFetchLog
MsgFetchPoolMetadata StakePoolMetadataHash
hash URI
uri
        IO (Either String (Maybe ByteString))
-> ExceptT String IO (Maybe ByteString)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
            (IO (Either String (Maybe ByteString))
 -> ExceptT String IO (Maybe ByteString))
-> IO (Either String (Maybe ByteString))
-> ExceptT String IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (IOException -> IO (Either String (Maybe ByteString)))
-> IO (Either String (Maybe ByteString))
-> IO (Either String (Maybe ByteString))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOException -> IO (Either String (Maybe ByteString))
forall (m :: * -> *) a.
Monad m =>
IOException -> m (Either String a)
fromIOException
            (IO (Either String (Maybe ByteString))
 -> IO (Either String (Maybe ByteString)))
-> IO (Either String (Maybe ByteString))
-> IO (Either String (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ (HttpException -> IO (Either String (Maybe ByteString)))
-> IO (Either String (Maybe ByteString))
-> IO (Either String (Maybe ByteString))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle HttpException -> IO (Either String (Maybe ByteString))
forall (m :: * -> *) a.
Monad m =>
HttpException -> m (Either String (Maybe a))
fromHttpException
            (IO (Either String (Maybe ByteString))
 -> IO (Either String (Maybe ByteString)))
-> IO (Either String (Maybe ByteString))
-> IO (Either String (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ Request
-> Manager
-> (Response BodyReader -> IO (Either String (Maybe ByteString)))
-> IO (Either String (Maybe ByteString))
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
manager ((Response BodyReader -> IO (Either String (Maybe ByteString)))
 -> IO (Either String (Maybe ByteString)))
-> (Response BodyReader -> IO (Either String (Maybe ByteString)))
-> IO (Either String (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ \Response BodyReader
res -> do
            -- NOTE
            -- Metadata are _supposed to_ be made of:
            --
            -- - A name (at most 50 UTF-8 bytes)
            -- - An optional description (at most 255 UTF-8 bytes)
            -- - A ticker (between 3 and 5 UTF-8 bytes)
            --
            -- So, the total, including a pretty JSON encoding with newlines ought
            -- to be less than or equal to 512 bytes. For security reasons, we only
            -- download the first 513 bytes and check the length at the
            -- call-site.
            case Response BodyReader -> Status
forall body. Response body -> Status
responseStatus Response BodyReader
res of
                Status
s | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200 -> do
                    let body :: BodyReader
body = Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
res
                    Maybe ByteString -> Either String (Maybe ByteString)
forall a b. b -> Either a b
Right (Maybe ByteString -> Either String (Maybe ByteString))
-> (ByteString -> Maybe ByteString)
-> ByteString
-> Either String (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (ByteString -> ByteString) -> ByteString -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> Either String (Maybe ByteString))
-> IO ByteString -> IO (Either String (Maybe ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BodyReader -> Int -> IO ByteString
brReadSome BodyReader
body Int
513

                Status
s | Status
s Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status404 -> do
                    Either String (Maybe ByteString)
-> IO (Either String (Maybe ByteString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Maybe ByteString)
 -> IO (Either String (Maybe ByteString)))
-> Either String (Maybe ByteString)
-> IO (Either String (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Maybe ByteString)
forall a b. a -> Either a b
Left String
"There's no known metadata for this pool."

                Status
s -> do
                    Either String (Maybe ByteString)
-> IO (Either String (Maybe ByteString))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Maybe ByteString)
 -> IO (Either String (Maybe ByteString)))
-> Either String (Maybe ByteString)
-> IO (Either String (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Maybe ByteString)
forall a b. a -> Either a b
Left (String -> Either String (Maybe ByteString))
-> String -> Either String (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                        [ String
"The server replied with something unexpected: "
                        , Status -> String
forall a. Show a => a -> String
show Status
s
                        ]

    fromHttpException :: Monad m => HttpException -> m (Either String (Maybe a))
    fromHttpException :: HttpException -> m (Either String (Maybe a))
fromHttpException = m (Either String (Maybe a))
-> HttpException -> m (Either String (Maybe a))
forall a b. a -> b -> a
const (Either String (Maybe a) -> m (Either String (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Maybe a) -> m (Either String (Maybe a)))
-> Either String (Maybe a) -> m (Either String (Maybe a))
forall a b. (a -> b) -> a -> b
$ Maybe a -> Either String (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing)

fromIOException :: Monad m => IOException -> m (Either String a)
fromIOException :: IOException -> m (Either String a)
fromIOException = Either String a -> m (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> m (Either String a))
-> (IOException -> Either String a)
-> IOException
-> m (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (IOException -> String) -> IOException -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"IO exception: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (IOException -> String) -> IOException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show

data StakePoolMetadataFetchLog
    = MsgFetchPoolMetadata StakePoolMetadataHash URI
    | MsgFetchPoolMetadataSuccess StakePoolMetadataHash StakePoolMetadata
    | MsgFetchPoolMetadataFailure StakePoolMetadataHash String
    | MsgFetchPoolMetadataFallback URI Bool
    | MsgFetchSMASH URI
    | MsgFetchDelistedPoolsFailure String
    | MsgFetchDelistedPoolsSuccess [PoolId]
    | MsgFetchHealthCheckFailure String
    | MsgFetchHealthCheckSuccess HealthStatusSMASH
    deriving (Int -> StakePoolMetadataFetchLog -> ShowS
[StakePoolMetadataFetchLog] -> ShowS
StakePoolMetadataFetchLog -> String
(Int -> StakePoolMetadataFetchLog -> ShowS)
-> (StakePoolMetadataFetchLog -> String)
-> ([StakePoolMetadataFetchLog] -> ShowS)
-> Show StakePoolMetadataFetchLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StakePoolMetadataFetchLog] -> ShowS
$cshowList :: [StakePoolMetadataFetchLog] -> ShowS
show :: StakePoolMetadataFetchLog -> String
$cshow :: StakePoolMetadataFetchLog -> String
showsPrec :: Int -> StakePoolMetadataFetchLog -> ShowS
$cshowsPrec :: Int -> StakePoolMetadataFetchLog -> ShowS
Show, StakePoolMetadataFetchLog -> StakePoolMetadataFetchLog -> Bool
(StakePoolMetadataFetchLog -> StakePoolMetadataFetchLog -> Bool)
-> (StakePoolMetadataFetchLog -> StakePoolMetadataFetchLog -> Bool)
-> Eq StakePoolMetadataFetchLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StakePoolMetadataFetchLog -> StakePoolMetadataFetchLog -> Bool
$c/= :: StakePoolMetadataFetchLog -> StakePoolMetadataFetchLog -> Bool
== :: StakePoolMetadataFetchLog -> StakePoolMetadataFetchLog -> Bool
$c== :: StakePoolMetadataFetchLog -> StakePoolMetadataFetchLog -> Bool
Eq)

instance HasPrivacyAnnotation StakePoolMetadataFetchLog
instance HasSeverityAnnotation StakePoolMetadataFetchLog where
    getSeverityAnnotation :: StakePoolMetadataFetchLog -> Severity
getSeverityAnnotation = \case
        MsgFetchPoolMetadata{} -> Severity
Info
        MsgFetchPoolMetadataSuccess{} -> Severity
Info
        MsgFetchPoolMetadataFailure{} -> Severity
Warning
        MsgFetchPoolMetadataFallback{} -> Severity
Warning
        MsgFetchSMASH{} -> Severity
Debug
        MsgFetchDelistedPoolsFailure{} -> Severity
Warning
        MsgFetchDelistedPoolsSuccess{} -> Severity
Info
        MsgFetchHealthCheckFailure{} -> Severity
Warning
        MsgFetchHealthCheckSuccess{} -> Severity
Info

instance ToText StakePoolMetadataFetchLog where
    toText :: StakePoolMetadataFetchLog -> Text
toText = \case
        MsgFetchPoolMetadata StakePoolMetadataHash
hash URI
uri -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Fetching metadata with hash ", StakePoolMetadataHash -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty StakePoolMetadataHash
hash
            , Text
" from ", String -> Text
T.pack (URI -> String
forall a. Show a => a -> String
show URI
uri)
            ]
        MsgFetchPoolMetadataSuccess StakePoolMetadataHash
hash StakePoolMetadata
meta -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Successfully fetched metadata with hash ", StakePoolMetadataHash -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty StakePoolMetadataHash
hash
            , Text
": ", String -> Text
T.pack (StakePoolMetadata -> String
forall a. Show a => a -> String
show StakePoolMetadata
meta)
            ]
        MsgFetchPoolMetadataFailure StakePoolMetadataHash
hash String
msg -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Failed to fetch metadata with hash ", StakePoolMetadataHash -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty StakePoolMetadataHash
hash, Text
": ", String -> Text
T.pack String
msg
            ]
        MsgFetchPoolMetadataFallback URI
uri Bool
noMoreUrls -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Couldn't reach server at ", String -> Text
T.pack (URI -> String
forall a. Show a => a -> String
show URI
uri), Text
"."
            , if Bool
noMoreUrls
                then Text
""
                else Text
" Falling back using a different strategy."
            ]
        MsgFetchSMASH URI
uri -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Making a SMASH request to ", String -> Text
T.pack (URI -> String
forall a. Show a => a -> String
show URI
uri)
            ]
        MsgFetchDelistedPoolsSuccess [PoolId]
poolIds -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Successfully fetched delisted "
            , String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> ([PoolId] -> Int) -> [PoolId] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PoolId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PoolId] -> String) -> [PoolId] -> String
forall a b. (a -> b) -> a -> b
$ [PoolId]
poolIds)
            , Text
" pools."
            ]
        MsgFetchDelistedPoolsFailure String
err -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Failed to fetch delisted pools: ", String -> Text
T.pack String
err
            ]
        MsgFetchHealthCheckSuccess HealthStatusSMASH
health -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Successfully checked health "
            , String -> Text
T.pack (HealthStatusSMASH -> String
forall a. Show a => a -> String
show HealthStatusSMASH
health)
            ]
        MsgFetchHealthCheckFailure String
err -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Failed to check health: ", String -> Text
T.pack String
err
            ]