Fix isHealthyStatus

lib/core/src/Cardano/Pool/Metadata.hs

@@ -22,6 +22,7 @@ module Cardano.Pool.Metadata
     , fetchDelistedPools
     , healthCheck
     , isHealthyStatus
+    , toHealthCheckSMASH
     , HealthStatusSMASH (..)
 
     -- * Construct URLs
@@ -43,7 +44,7 @@ import Cardano.BM.Data.Severity
 import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Wallet.Api.Types
-    ( HealthStatusSMASH (..), defaultRecordTypeOptions )
+    ( HealthCheckSMASH (..), HealthStatusSMASH (..), defaultRecordTypeOptions )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( hex )
 import Cardano.Wallet.Primitive.Types
@@ -239,10 +240,18 @@ healthCheck tr uri manager = runExceptTLog $ do
             traceWith tr (MsgFetchHealthCheckSuccess health)
             pure $ Just 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 = \case
+    (Just health)
+        | isHealthyStatus health -> Available
+        | otherwise -> Unavailable
+    _ -> Unreachable
+
 isHealthyStatus :: HealthStatusSMASH -> Bool
-isHealthyStatus (HealthStatusSMASH {..})
-    | T.toLower status /= "ok" = True
-    | otherwise = False
+isHealthyStatus (HealthStatusSMASH {..}) = T.toLower status == "ok"
 
 fetchDelistedPools
     :: Tracer IO StakePoolMetadataFetchLog

lib/core/src/Cardano/Wallet/Api.hs

@@ -127,6 +127,7 @@ import Cardano.Wallet.Api.Types
     , ApiByronWallet
     , ApiCoinSelectionT
     , ApiFee
+    , ApiHealthCheck
     , ApiMaintenanceAction
     , ApiMaintenanceActionPostData
     , ApiNetworkClock
@@ -147,7 +148,6 @@ import Cardano.Wallet.Api.Types
     , ApiWalletPassphrase
     , ApiWalletSignData
     , ByronWalletPutPassphraseData
-    , HealthCheckSMASH
     , Iso8601Time
     , MinWithdrawal
     , PostExternalTransactionData
@@ -168,14 +168,14 @@ import Cardano.Wallet.Primitive.AddressDerivation
 import Cardano.Wallet.Primitive.SyncProgress
     ( SyncTolerance )
 import Cardano.Wallet.Primitive.Types
-    ( AddressState
-    , Block
-    , Coin (..)
+    ( Block
     , NetworkParameters
     , SmashServer (..)
     , SortOrder (..)
     , WalletId (..)
     )
+import Cardano.Wallet.Primitive.Types.Address
+    ( AddressState )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..) )
 import Cardano.Wallet.Registry
@@ -723,16 +723,11 @@ type GetNetworkClock = "network"
 -------------------------------------------------------------------------------}
 
 type SMASH = GetCurrentSMASHHealth
-    :<|> GetURISmashHealth
 
 type GetCurrentSMASHHealth = "smash"
     :> "health"
-    :> Get '[JSON] (ApiT HealthCheckSMASH)
-
-type GetURISmashHealth = "smash"
-    :> "health"
-    :> ReqBody '[JSON] (ApiT SmashServer)
-    :> Post '[JSON] (ApiT HealthCheckSMASH)
+    :> QueryParam "url" (ApiT SmashServer)
+    :> Get '[JSON] ApiHealthCheck
 
 {-------------------------------------------------------------------------------
                                    Proxy_

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -152,6 +152,7 @@ module Cardano.Wallet.Api.Types
     , defaultRecordTypeOptions
     , HealthStatusSMASH (..)
     , HealthCheckSMASH (..)
+    , ApiHealthCheck (..)
     ) where
 
 import Prelude
@@ -2179,12 +2180,20 @@ data HealthCheckSMASH =
     | NoSmashConfigured  -- no SMASH server has been configured
     deriving (Generic, Show, Eq, Ord)
 
-instance FromJSON (ApiT HealthCheckSMASH) where
-    parseJSON = fmap ApiT . genericParseJSON defaultSumTypeOptions
+newtype ApiHealthCheck = ApiHealthCheck
+    { health :: HealthCheckSMASH }
+    deriving (Generic, Show, Eq, Ord)
+
+instance FromJSON HealthCheckSMASH where
+    parseJSON = genericParseJSON defaultSumTypeOptions
         { sumEncoding = UntaggedValue }
+instance ToJSON HealthCheckSMASH where
+    toJSON = genericToJSON defaultSumTypeOptions
 
-instance ToJSON (ApiT HealthCheckSMASH) where
-    toJSON = genericToJSON defaultSumTypeOptions . getApiT
+instance FromJSON ApiHealthCheck where
+    parseJSON = genericParseJSON defaultRecordTypeOptions
+instance ToJSON ApiHealthCheck where
+    toJSON = genericToJSON defaultRecordTypeOptions
 
 instance FromJSON (ApiT SmashServer) where
     parseJSON = parseJSON >=> either (fail . show . ShowFmt) (pure . ApiT) . fromText

lib/core/test/unit/Cardano/Wallet/Api/Malformed.hs

@@ -76,7 +76,7 @@ import Cardano.Wallet.Api.Types
 import Cardano.Wallet.Primitive.AddressDerivation
     ( AccountingStyle (..), DerivationIndex (..), NetworkDiscriminant (..) )
 import Cardano.Wallet.Primitive.Types
-    ( WalletId, SmashServer, walletNameMaxLength )
+    ( SmashServer, WalletId, walletNameMaxLength )
 import Cardano.Wallet.Primitive.Types.Address
     ( Address (..) )
 import Control.Arrow

lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs

@@ -63,6 +63,7 @@ import Cardano.Wallet.Api.Types
     , ApiEpochInfo (..)
     , ApiErrorCode (..)
     , ApiFee (..)
+    , ApiHealthCheck (..)
     , ApiMaintenanceAction (..)
     , ApiMaintenanceActionPostData (..)
     , ApiMnemonicT (..)
@@ -353,7 +354,7 @@ spec = do
             jsonRoundtripAndGolden $ Proxy @ApiNetworkParameters
             jsonRoundtripAndGolden $ Proxy @ApiNetworkClock
             jsonRoundtripAndGolden $ Proxy @ApiWalletDelegation
-            jsonRoundtripAndGolden $ Proxy @(ApiT HealthCheckSMASH)
+            jsonRoundtripAndGolden $ Proxy @ApiHealthCheck
             jsonRoundtripAndGolden $ Proxy @ApiWalletDelegationStatus
             jsonRoundtripAndGolden $ Proxy @ApiWalletDelegationNext
             jsonRoundtripAndGolden $ Proxy @(ApiT (Hash "Genesis"))
@@ -1728,6 +1729,10 @@ instance Arbitrary HealthCheckSMASH where
     arbitrary = genericArbitrary
     shrink = genericShrink
 
+instance Arbitrary ApiHealthCheck where
+    arbitrary = genericArbitrary
+    shrink = genericShrink
+
 {-------------------------------------------------------------------------------
                    Specification / Servant-Swagger Machinery
 
@@ -1795,7 +1800,7 @@ instance ToSchema (ApiSelectCoinsData n) where
 instance ToSchema (ApiT SmashServer) where
     declareNamedSchema _ = declareSchemaForDefinition "ApiSmashServer"
 
-instance ToSchema (ApiT HealthCheckSMASH) where
+instance ToSchema ApiHealthCheck where
     declareNamedSchema _ = declareSchemaForDefinition "ApiHealthCheck"
 
 instance ToSchema (ApiSelectCoinsPayments n) where

lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs

@@ -24,7 +24,7 @@ import Prelude
 import Cardano.Address
     ( unAddress )
 import Cardano.Pool.Metadata
-    ( defaultManagerSettings, healthCheck, isHealthyStatus, newManager )
+    ( defaultManagerSettings, healthCheck, newManager, toHealthCheckSMASH )
 import Cardano.Wallet
     ( ErrCreateRandomAddress (..)
     , ErrNotASequentialWallet (..)
@@ -109,6 +109,7 @@ import Cardano.Wallet.Api.Types
     , ApiAddressInspectData (..)
     , ApiCredential (..)
     , ApiErrorCode (..)
+    , ApiHealthCheck (..)
     , ApiMaintenanceAction (..)
     , ApiMaintenanceActionPostData (..)
     , ApiSelectCoinsAction (..)
@@ -435,21 +436,19 @@ server byron icarus shelley spl ntp =
             = Handler $ fmap ApiT $ liftIO $ getSettings spl
 
     smash :: Server SMASH
-    smash = getCurrentSmashHealth :<|> getUriSmashHealth
+    smash = getCurrentSmashHealth
       where
         getHealth smashServer = liftIO $ do
             manager <- newManager defaultManagerSettings
-            health <- healthCheck mempty (unSmashServer smashServer) manager
-            pure $ ApiT $ maybe Unreachable
-                (\h -> if isHealthyStatus h then Available else Unavailable) health
+            health' <- healthCheck mempty (unSmashServer smashServer) manager
+            pure $ ApiHealthCheck $ toHealthCheckSMASH health'
 
-        getUriSmashHealth (ApiT smashServer) = Handler $ getHealth smashServer
-
-        getCurrentSmashHealth = Handler $ do
+        getCurrentSmashHealth (Just (ApiT smashServer)) = Handler $ getHealth smashServer
+        getCurrentSmashHealth Nothing = Handler $ do
             settings' <- liftIO $ getSettings spl
             case poolMetadataSource settings' of
                 FetchSMASH smashServer -> getHealth smashServer
-                _ -> pure (ApiT NoSmashConfigured)
+                _ -> pure (ApiHealthCheck NoSmashConfigured)
 
 postAnyAddress
     :: NetworkId

lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs

@@ -48,9 +48,9 @@ import Cardano.Pool.Metadata
     , fetchFromRemote
     , healthCheck
     , identityUrlBuilder
-    , isHealthyStatus
     , newManager
     , registryUrlBuilder
+    , toHealthCheckSMASH
     )
 import Cardano.Wallet
     ( ErrListPools (..) )
@@ -745,13 +745,8 @@ monitorMetadata gcStatus tr sp db@(DBLayer{..}) = do
 
     health <- case poolMetadataSource settings of
         FetchSMASH uri -> do
-            let checkHealth _ = do
-                    r <- healthCheck trFetch (unSmashServer uri) manager
-                    case r of
-                        (Just health)
-                            | isHealthyStatus health -> pure Available
-                            | otherwise -> pure Unavailable
-                        _ -> pure Unreachable
+            let checkHealth _ = toHealthCheckSMASH
+                    <$> healthCheck trFetch (unSmashServer uri) manager
 
                 maxRetries = 8
                 retryCheck RetryStatus{rsIterNumber} b

specifications/api/swagger.yaml

@@ -341,7 +341,6 @@ x-ScriptValue: &ScriptValue
       type: string
       format: bech32
       pattern: "^(script_vkh)1[0-9a-z]*$"
-      example: script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt36ms
 
     - title: All
       type: object
@@ -390,33 +389,6 @@ x-ScriptValue: &ScriptValue
 
 x-script: &script
   <<: *ScriptValue
-  description: |
-    Script allows establishing either payment or stake guard that could be removed
-    when a special combination of signing keys is present.
-
-    The script can be constructed using four primitives:
-     - verification key hash for which a corresponding signing key is expected
-     - all condition for which all list elements' expectation are met for the condition to be valid
-     - any condition for which any list element' expectation is to be met for the condition to be valid
-     - some condition for which a minimal number of list elements' expectation is to be met for the condition to be valid
-  example:
-    -
-      "script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt36ms"
-    -
-      { "all": [ "script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt36ms"
-               , "script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt37ms"] }
-    -
-      { "all": [ "script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt36ms"
-               , { "any" : [ "script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt37ms"
-                           , "script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt38ms"] }
-               ] }
-    -
-      { "all": [ "script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt36ms"
-               , { "some" : { "from" : [ "script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt37ms"
-                                       , "script_vkh18srsxr3khll7vl3w9mqfu55n6wzxxlxj7qzr2mhnyreluzt38ms"]
-                            , "at_least" : 2
-                            }
-                 } ] }
 
 x-CredentialValue: &CredentialValue
   nullable: false
@@ -1735,12 +1707,17 @@ components:
       description: A base SMASH uri without endpoint path.
 
     ApiHealthCheck: &ApiHealthCheck
-      type: string
-      enum: ["available", "unavailable", "unreachable", "no_smash_configured"]
+      type: object
+      required:
+        - health
+      properties:
+        health:
+          type: string
+          enum: ["available", "unavailable", "unreachable", "no_smash_configured"]
       description: |
         The status of the SMASH server. Possible values are:
 
-        status                  | description
+        health                  | description
         ---                     | ---
         `"available"`           | server is awaiting your requests
         `"unavailable"`         | server is running, but currently unavailable, try again in a short time
@@ -3181,15 +3158,6 @@ x-responsesGetSmashHealth: &responsesGetSmashHealth
       application/json:
         schema: *ApiHealthCheck
 
-x-responsesPostSmashHealth: &responsesPostSmashHealth
-  <<: *responsesErr400
-  <<: *responsesErr406
-  <<: *responsesErr415
-  200:
-    description: Ok
-    content:
-      application/json:
-        schema: *ApiHealthCheck
 
 #############################################################################
 #                                                                           #
@@ -4135,23 +4103,16 @@ paths:
       responses: *responsesGetSettings
 
   /smash/health:
-    post:
-      operationId: getUriSmashHealth
-      tags: ["Utils"]
-      summary: SMASH health
-      description: |
-        Get health status of given SMASH uri.
-      requestBody:
-        required: true
-        content:
-          application/json:
-            schema: *ApiSmashServer
-      responses: *responsesPostSmashHealth
-
     get:
       operationId: getCurrentSmashHealth
       tags: ["Utils"]
       summary: Current SMASH health
       description: |
         Get health status of the currently active SMASH server.
+      parameters:
+        - in: query
+          name: url
+          schema: *ApiSmashServer
+          required: false
+          description: check this url for health instead of the currently configured one
       responses: *responsesGetSmashHealth