Apply review suggestions

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs

@@ -159,7 +159,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         \Cannot join existent stakepool with wrong password" $ \ctx -> do
         w <- fixtureWallet ctx
         pool:_ <- map (view #id) . view #pools . snd <$> unsafeRequest
-            @(ApiListStakePools ApiStakePool) ctx (Link.listStakePools arbitraryStake) Empty
+            @(ApiListStakePools ApiStakePool) 
+            ctx (Link.listStakePools arbitraryStake) Empty
         joinStakePool @n ctx pool (w, "Wrong Passphrase") >>= flip verify
             [ expectResponseCode HTTP.status403
             , expectErrorMessage errMsg403WrongPass
@@ -556,9 +557,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
 
         (_, w) <- unsafeRequest @ApiWallet ctx
             (Link.postWallet @'Shelley) payload
-        pool:_ <- map (view #id) . view #pools . snd
-                <$> unsafeRequest @(ApiListStakePools ApiStakePool)
-                    ctx (Link.listStakePools arbitraryStake) Empty
+        pool:_ <- map (view #id) . view #pools . snd <$>
+            unsafeRequest @(ApiListStakePools ApiStakePool)
+                ctx (Link.listStakePools arbitraryStake) Empty
 
         eventually "wallet join a pool" $ do
             joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
@@ -685,9 +686,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         $ it "Join/quit when already joined a pool" $ \ctx -> do
             w <- fixtureWallet ctx
 
-            pool1:pool2:_ <- map (view #id) . view #pools . snd
-                    <$> unsafeRequest @(ApiListStakePools ApiStakePool)
-                        ctx (Link.listStakePools arbitraryStake) Empty
+            pool1:pool2:_ <- map (view #id) . view #pools . snd <$>
+                unsafeRequest @(ApiListStakePools ApiStakePool)
+                    ctx (Link.listStakePools arbitraryStake) Empty
 
             joinStakePool @n ctx pool1 (w, fixturePassphrase) >>= flip verify
                 [ expectResponseCode HTTP.status202
@@ -755,9 +756,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         it "STAKE_POOLS_JOIN_01x - \
             \I can join if I have just the right amount" $ \ctx -> do
             w <- fixtureWalletWith @n ctx [costOfJoining ctx + depositAmt ctx]
-            pool:_ <- map (view #id) . view #pools . snd
-                    <$> unsafeRequest @(ApiListStakePools ApiStakePool)
-                        ctx (Link.listStakePools arbitraryStake) Empty
+            pool:_ <- map (view #id) . view #pools . snd <$>
+                unsafeRequest @(ApiListStakePools ApiStakePool)
+                    ctx (Link.listStakePools arbitraryStake) Empty
             joinStakePool @n ctx pool (w, fixturePassphrase)>>= flip verify
                 [ expectResponseCode HTTP.status202
                 , expectField (#status . #getApiT) (`shouldBe` Pending)
@@ -767,9 +768,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         it "STAKE_POOLS_JOIN_01x - \
            \I cannot join if I have not enough fee to cover" $ \ctx -> do
             w <- fixtureWalletWith @n ctx [costOfJoining ctx + depositAmt ctx - 1]
-            pool:_ <- map (view #id) . view #pools . snd
-                    <$> unsafeRequest @(ApiListStakePools ApiStakePool)
-                        ctx (Link.listStakePools arbitraryStake) Empty
+            pool:_ <- map (view #id) . view #pools . snd <$>
+                unsafeRequest @(ApiListStakePools ApiStakePool)
+                    ctx (Link.listStakePools arbitraryStake) Empty
             joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
                 [ expectResponseCode HTTP.status403
                 , expectErrorMessage (errMsg403DelegationFee 1)
@@ -791,8 +792,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
             w <- fixtureWalletWith @n ctx initBalance
 
             pool:_ <- map (view #id) . view #pools . snd
-                    <$> unsafeRequest @(ApiListStakePools ApiStakePool)
-                        ctx (Link.listStakePools arbitraryStake) Empty
+                <$> unsafeRequest @(ApiListStakePools ApiStakePool)
+                    ctx (Link.listStakePools arbitraryStake) Empty
 
             joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
                 [ expectResponseCode HTTP.status202
@@ -828,8 +829,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
             w <- fixtureWalletWith @n ctx initBalance
 
             pool:_ <- map (view #id) . view #pools . snd
-                    <$> unsafeRequest @(ApiListStakePools ApiStakePool)
-                        ctx (Link.listStakePools arbitraryStake) Empty
+                <$> unsafeRequest @(ApiListStakePools ApiStakePool)
+                    ctx (Link.listStakePools arbitraryStake) Empty
 
             joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
                 [ expectResponseCode HTTP.status202
@@ -1007,7 +1008,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         \NonMyopicMemberRewards are 0 when stake is 0" $ \ctx -> do
         pendingWith "This assumption seems false, for some reasons..."
         let stake = Just $ Coin 0
-        r <- request @(ApiListStakePools ApiStakePool) @IO ctx (Link.listStakePools stake)
+        r <- request @(ApiListStakePools ApiStakePool) @IO
+            ctx (Link.listStakePools stake)
             Default Empty
         expectResponseCode HTTP.status200 r
         verify ((second . second) (view #pools) r)

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

@@ -216,8 +216,9 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
     , delistPools
         :: [PoolId]
         -> stm ()
-        -- ^ Mark pools as delisted
-        --
+        -- ^ Mark pools as delisted, e.g. due to non-compliance.
+        -- This is stored as an attribute in the metadata table.
+
     , removePools
         :: [PoolId]
         -> stm ()

lib/core/src/Cardano/Pool/DB/Model.hs

@@ -435,8 +435,9 @@ mRollbackTo ti point = do
 mDelistPools :: [PoolId] -> ModelOp ()
 mDelistPools poolsToDelist =
     forM_ poolsToDelist $ \pool -> do
-        mhash <- (>>= (fmap snd . poolMetadata . snd)) <$> mReadPoolRegistration pool
-        forM_ mhash $ \hash -> modify #metadata
+        mRegistrationCert <- fmap snd <$> mReadPoolRegistration pool
+        let mHash = fmap snd (poolMetadata =<< mRegistrationCert)
+        forM_ mHash $ \hash -> modify #metadata
             $ Map.adjust (\m -> m { delisted = True }) hash
 
 mRemovePools :: [PoolId] -> ModelOp ()

lib/core/src/Cardano/Pool/DB/Sqlite.hs

@@ -101,8 +101,6 @@ import Data.Ratio
     ( denominator, numerator, (%) )
 import Data.String.Interpolate
     ( i )
-import Data.String.QQ
-    ( s )
 import Data.Text
     ( Text )
 import Data.Time.Clock
@@ -399,7 +397,8 @@ newDBLayer trace fp timeInterpreter = do
                         (PoolMetadataFetchAttempts hash url retryAfter $ retryCount + 1)
 
         putPoolMetadata hash metadata = do
-            let StakePoolMetadata{ticker,name,description,homepage,delisted} = metadata
+            let StakePoolMetadata
+                    {ticker, name, description, homepage, delisted} = metadata
             repsert
                 (PoolMetadataKey hash)
                 (PoolMetadata hash name ticker description homepage delisted)
@@ -529,8 +528,9 @@ newDBLayer trace fp timeInterpreter = do
             listOfK k = go
               where
                 go [] = []
-                go xs = let (l, r) = splitAt k xs
-                        in l : go r
+                go xs =
+                    let (l, r) = splitAt k xs
+                    in l : go r
 
         removePools = mapM_ $ \pool -> do
             liftIO $ traceWith trace $ MsgRemovingPool pool
@@ -591,7 +591,11 @@ newDBLayer trace fp timeInterpreter = do
                 [Asc InternalStateId, LimitTo 1]
             case result of
                 Nothing -> pure . W.lastMetadataGC $ defaultInternalState
-                Just x -> pure . W.lastMetadataGC . fromInternalState . entityVal $ x
+                Just x -> pure
+                    . W.lastMetadataGC
+                    . fromInternalState
+                    . entityVal
+                    $ x
 
         putLastMetadataGC utc = do
             result <- selectFirst
@@ -767,7 +771,7 @@ createView conn (DatabaseView name definition) = do
 -- This view does NOT exclude pools that have retired.
 --
 activePoolLifeCycleData :: DatabaseView
-activePoolLifeCycleData = DatabaseView "active_pool_lifecycle_data" [s|
+activePoolLifeCycleData = DatabaseView "active_pool_lifecycle_data" [i|
     SELECT
         active_pool_registrations.pool_id as pool_id,
         active_pool_retirements.retirement_epoch as retirement_epoch,
@@ -796,7 +800,7 @@ activePoolLifeCycleData = DatabaseView "active_pool_lifecycle_data" [s|
 -- This view does NOT exclude pools that have retired.
 --
 activePoolOwners :: DatabaseView
-activePoolOwners = DatabaseView "active_pool_owners" [s|
+activePoolOwners = DatabaseView "active_pool_owners" [i|
     SELECT pool_id, pool_owners FROM (
         SELECT row_number() OVER w AS r, *
         FROM (
@@ -824,7 +828,7 @@ activePoolOwners = DatabaseView "active_pool_owners" [s|
 -- This view does NOT exclude pools that have retired.
 --
 activePoolRegistrations :: DatabaseView
-activePoolRegistrations = DatabaseView "active_pool_registrations" [s|
+activePoolRegistrations = DatabaseView "active_pool_registrations" [i|
     SELECT
         pool_id,
         cost,
@@ -854,7 +858,7 @@ activePoolRegistrations = DatabaseView "active_pool_registrations" [s|
 --      certificates revoked by subsequent re-registration certificates.
 --
 activePoolRetirements :: DatabaseView
-activePoolRetirements = DatabaseView "active_pool_retirements" [s|
+activePoolRetirements = DatabaseView "active_pool_retirements" [i|
     SELECT * FROM (
         SELECT
             pool_id,
@@ -1039,4 +1043,3 @@ fromInternalState
     :: InternalState
     -> W.InternalState
 fromInternalState (InternalState utc) = W.InternalState utc
-

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

@@ -158,7 +158,10 @@ fetchDelistedPools tr uri manager = runExceptTLog $ do
                     Right . BS.concat <$> brConsume body
 
                 s -> do
-                    pure $ Left $ "The server replied something unexpected: " <> show s
+                    pure $ Left $ mconcat
+                        [ "The server replied something unexpected: "
+                        , show s
+                        ]
 
     runExceptTLog
         :: ExceptT String IO [PoolId]
@@ -171,7 +174,7 @@ fetchDelistedPools tr uri manager = runExceptTLog $ do
             Just meta <$ traceWith tr (MsgFetchDelistedPoolsSuccess meta)
 
     fromHttpException :: Monad m => HttpException -> m (Either String a)
-    fromHttpException = return . Left . ("HTTp Exception exception: " <>) . show
+    fromHttpException = return . Left . ("HTTP exception: " <>) . show
 
 -- TODO: refactor/simplify this
 fetchFromRemote
@@ -249,15 +252,16 @@ fetchFromRemote tr builders manager pid url hash = runExceptTLog $ do
                     pure $ Left "There's no known metadata for this pool."
 
                 s -> do
-                    pure $ Left $ "The server replied something unexpected: " <> show s
+                    pure $ Left $ mconcat
+                        [ "The server replied with something unexpected: "
+                        , show s
+                        ]
 
     fromHttpException :: Monad m => HttpException -> m (Either String (Maybe a))
     fromHttpException = const (return $ Right Nothing)
 
 fromIOException :: Monad m => IOException -> m (Either String a)
 fromIOException = return . Left . ("IO exception: " <>) . show
-
-
 data StakePoolMetadataFetchLog
     = MsgFetchPoolMetadata StakePoolMetadataHash URI
     | MsgFetchPoolMetadataSuccess StakePoolMetadataHash StakePoolMetadata
@@ -302,8 +306,9 @@ instance ToText StakePoolMetadataFetchLog where
             [ "Fetching delisted pools from ", T.pack (show uri)
             ]
         MsgFetchDelistedPoolsSuccess poolIds -> mconcat
-            [ "Successfully fetched delisted pools: "
-            , T.pack (show poolIds)
+            [ "Successfully fetched delisted "
+            , T.pack (show . length $ poolIds)
+            , " pools."
             ]
         MsgFetchDelistedPoolsFailure err -> mconcat
             [ "Failed to fetch delisted pools: ", T.pack err

lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs

@@ -698,7 +698,8 @@ instance PersistField POSIXTime where
         utcTimeToPOSIXSeconds <$>
             parseTimeM True defaultTimeLocale
                 (iso8601DateFormat (Just "%H:%M:%S")) (T.unpack time)
-    fromPersistValue _ = Left "Could not convert to unknown constructor POSIX seconds"
+    fromPersistValue _ = Left
+        "Could not convert to unknown constructor POSIX seconds"
 
 instance PersistFieldSql POSIXTime where
     sqlType _ = sqlType (Proxy @Text)

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

@@ -1988,9 +1988,9 @@ data InternalState = InternalState
     } deriving (Generic, Show, Eq)
 
 defaultInternalState :: InternalState
-defaultInternalState = InternalState {
-   lastMetadataGC = (fromIntegral @Int 0)
-}
+defaultInternalState = InternalState
+    { lastMetadataGC = fromIntegral @Int 0 }
+
 
 instance FromJSON PoolMetadataSource where
     parseJSON = parseJSON >=> either (fail . show . ShowFmt) pure . fromText

lib/core/test/unit/Cardano/Pool/DB/Properties.hs

@@ -1437,7 +1437,7 @@ prop_modSettingsReadSettings DBLayer{..} settings = do
         assertWith "Modifying settings and reading afterwards works"
             (modSettings' == settings)
 
--- | read . put == pure
+-- | read . put == id
 prop_putLastMetadataGCReadLastMetadataGC
     :: DBLayer IO
     -> POSIXTime

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

@@ -1197,7 +1197,7 @@ instance Arbitrary PoolId where
         return $ PoolId $ BS.pack $ take 28 bytes
 
 instance Arbitrary (ApiListStakePools ApiStakePool) where
-    arbitrary = ApiListStakePools <$> arbitrary <*> arbitrary
+    arbitrary = applyArbitrary2 ApiListStakePools
 
 instance Arbitrary ApiStakePool where
     arbitrary = ApiStakePool

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

@@ -1075,13 +1075,9 @@ inspectAddress =
   where
     inspect :: ByteString -> Either TextDecodingError Aeson.Value
     inspect = maybe (Left errMalformedAddress) Right
-        . inspectShelleyAddress mRootPub
+        . inspectShelleyAddress
         . unsafeMkAddress
 
-    -- TODO: It's possible to inspect a byron address, given a root XPub.
-    -- However, this is not yet exposed by the API.
-    mRootPub = Nothing
-
 toHDPayloadAddress :: W.Address -> Maybe Byron.HDAddressPayload
 toHDPayloadAddress (W.Address addr) = do
     payload <- CBOR.deserialiseCbor CBOR.decodeAddressPayload addr

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

@@ -9,6 +9,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 

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

@@ -13,6 +13,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NumericUnderscores #-}
 
 -- |
 -- Copyright: © 2020 IOHK
@@ -782,20 +783,19 @@ gcDelistedPools tr DBLayer{..} fetchDelisted = forever $ do
 
     let timeSinceLastGC = currentTime - lastGC
         sixHours = posixDayLength / 4
-    if timeSinceLastGC > sixHours
-        then do
-            delistedPools <- fmap (fromMaybe []) fetchDelisted
-            atomically $ do
-                putLastMetadataGC currentTime
-                delistPools delistedPools
-        else do
-            -- Sleep for 60 seconds. This is useful in case
-            -- something else is modifying the last sync time
-            -- in the database.
-            let sec_to_milisec = (* 1000000)
-                sleep_time = sec_to_milisec 60
-            traceWith tr $ MsgGCTakeBreak sleep_time
-            threadDelay sleep_time
+    when (timeSinceLastGC > sixHours) $ do
+        delistedPools <- fmap (fromMaybe []) fetchDelisted
+        atomically $ do
+            putLastMetadataGC currentTime
+            delistPools delistedPools
+
+    -- Sleep for 60 seconds. This is useful in case
+    -- something else is modifying the last sync time
+    -- in the database.
+    let ms = (* 1_000_000)
+    let sleepTime = ms 60
+    traceWith tr $ MsgGCTakeBreak sleepTime
+    threadDelay sleepTime
     pure ()
 
 data StakePoolLog
@@ -884,5 +884,5 @@ instance ToText StakePoolLog where
         MsgGCTakeBreak delay -> mconcat
             [ "Taking a little break from GCing delisted metadata pools, "
             , "back to it in about "
-            , pretty (fixedF 1 (toRational delay / 1000000)), "s"
+            , pretty (fixedF 1 (toRational delay / 1_000_000)), "s"
             ]

specifications/api/swagger.yaml

@@ -2659,7 +2659,7 @@ paths:
       tags: ["Stake Pools"]
       summary: Maintenance actions
       description: |
-        Performs maintenance action on the stake pools, such
+        Performs maintenance actions on stake pools, such
         as triggering metadata garbage collection.
 
         Actions may not be instantaneous.
@@ -3220,4 +3220,3 @@ paths:
 
         Return the current settings.
       responses: *responsesGetSettings
-