Skip to content

Commit

Permalink
Stake pool metadata: Start updating to new schema
Browse files Browse the repository at this point in the history
  • Loading branch information
@rvl
rvl committed Nov 29, 2019
1 parent 5248130 commit 55b4233
Show file tree
Hide file tree
Showing 3 changed files with 108 additions and 30 deletions.
33 changes: 25 additions & 8 deletions lib/core/src/Cardano/Pool/Metadata.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,7 @@ import Cardano.BM.Data.Severity
import Cardano.BM.Trace
( Trace, traceNamedItem )
import Cardano.Wallet.Primitive.Types
( PoolId (..), ShowFmt (..) )
( PoolId (..), PoolOwner (..), ShowFmt (..) )
import Codec.Archive.Zip
import Control.Exception
( IOException, displayException, tryJust )
Expand Down Expand Up @@ -90,12 +90,23 @@ import qualified Data.Text as T
Types
-------------------------------------------------------------------------------}

-- | Information about a stake pool. This information is not used directly by
-- cardano-wallet. It is sourced from the stake pool registry and passed
-- straight through to API consumers.
-- | Information about a stake pool, published by a stake pool owner in the
-- stake pool registry.
--
-- The wallet searches for registrations involving the owner, to find metadata
-- for a given PoolID.
--
-- The metadata information is not used directly by cardano-wallet, but rather
-- passed straight through to API consumers.
data StakePoolMetadata = StakePoolMetadata
{ ticker :: StakePoolTicker
-- ^ Short human-readable ID for the stake pool.
{ owner :: PoolOwner
-- ^ Bech32-encoded ed25519 public key.
, ticker :: StakePoolTicker
-- ^ Very short human-readable ID for the stake pool.
, name :: Text
-- ^ Name of the stake pool.
, description :: Maybe Text
-- ^ Short description of the stake pool.
, homepage :: Text
-- ^ Absolute URL for the stake pool's homepage link.
, pledgeAddress :: Text
Expand All @@ -109,11 +120,11 @@ newtype StakePoolTicker = StakePoolTicker { unStakePoolTicker :: Text }

instance FromText StakePoolTicker where
fromText t
| T.length t == 3 || T.length t == 4
| T.length t >= 3 && T.length t <= 5
= Right $ StakePoolTicker t
| otherwise
= Left . TextDecodingError $
"stake pool ticker length must be 3-4 characters"
"stake pool ticker length must be 3-5 characters"

-- NOTE
-- JSON instances for 'StakePoolMetadata' and 'StakePoolTicker' matching the
Expand All @@ -132,6 +143,12 @@ instance FromJSON StakePoolTicker where
instance ToJSON StakePoolTicker where
toJSON = toJSON . toText

instance FromJSON PoolOwner where
parseJSON = parseJSON >=> either (fail . show . ShowFmt) pure . fromText

instance ToJSON PoolOwner where
toJSON = toJSON . toText

defaultRecordTypeOptions :: Aeson.Options
defaultRecordTypeOptions = Aeson.defaultOptions
{ fieldLabelModifier = camelTo2 '_' . dropWhile (== '_')
Expand Down
40 changes: 40 additions & 0 deletions lib/core/src/Cardano/Wallet/Primitive/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -116,6 +116,7 @@ module Cardano.Wallet.Primitive.Types

-- * Stake Pools
, PoolId(..)
, PoolOwner(..)
, StakeDistribution (..)
, poolIdBytesLength

Expand Down Expand Up @@ -229,6 +230,8 @@ import Numeric.Natural
import Safe
( readMay )

import qualified Cardano.Crypto.Wallet as CC
import qualified Codec.Binary.Bech32 as Bech32
import qualified Control.Foldl as F
import qualified Data.ByteString as BS
import qualified Data.Char as C
Expand Down Expand Up @@ -514,6 +517,43 @@ instance FromText PoolId where
where
textDecodingError = Left . TextDecodingError . show

-- | A stake pool owner, which is a public key encoded in bech32 with prefix
-- ed25519_pk.
newtype PoolOwner = PoolOwner { getPoolOwner :: ByteString }
deriving (Generic, Eq, Show, Ord)

poolOwnerPrefix :: Bech32.HumanReadablePart
poolOwnerPrefix = Bech32.unsafeHumanReadablePartFromText "ed25519_pk"

instance NFData PoolOwner

instance Buildable PoolOwner where
build poolId = build (toText poolId)

instance ToText PoolOwner where
toText = Bech32.encodeLenient poolOwnerPrefix
. Bech32.dataPartFromBytes
. getPoolOwner

instance FromText PoolOwner where
fromText t = case fmap Bech32.dataPartToBytes <$> Bech32.decode t of
Left err ->
Left $ TextDecodingError $
"Stake pool owner is not a valid bech32 string: "
<> show err
Right (hrp, Just bytes)
| hrp == poolOwnerPrefix ->
Right $ PoolOwner bytes
| otherwise ->
Left $ TextDecodingError $
"Stake pool owner has wrong prefix:"
<> " expected "
<> T.unpack (Bech32.humanReadablePartToText poolOwnerPrefix)
<> " but got "
<> show hrp
Right (_, Nothing) ->
Left $ TextDecodingError "Stake pool owner is invalid"

data StakeDistribution = StakeDistribution
{ dangling :: Quantity "lovelace" Word64
, pools :: [(PoolId, Quantity "lovelace" Word64)]
Expand Down
65 changes: 43 additions & 22 deletions lib/core/test/unit/Cardano/Pool/MetadataSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,7 +25,7 @@ import Cardano.Pool.Metadata
, transformTrace
)
import Cardano.Wallet.Primitive.Types
( PoolId (..) )
( PoolId (..), PoolOwner (..) )
import Cardano.Wallet.Unsafe
( unsafeFromText )
import Codec.Archive.Zip
Expand Down Expand Up @@ -79,18 +79,18 @@ spec = do
around (testServer dataDir) $ do
it "Loads the example zip" $ \port -> do
tr <- setupLogging
res <- getStakePoolMetadata tr (testUrl port) presentPids
res <- getStakePoolMetadata tr (testUrl port) presentOwners
res `shouldBe` Right (map Just presentMetas)

it "Handles a missing pool" $ \port -> do
tr <- setupLogging
res <- getStakePoolMetadata tr (testUrl port) (absentPid:presentPids)
res <- getStakePoolMetadata tr (testUrl port) (absentOwner:presentOwners)
res `shouldBe` Right (Nothing:map Just presentMetas)

it "Fails with an unavailable HTTP server" $ \_port -> do
tr <- setupLogging
let badUrl = "http://localhost:99/master.zip"
res <- getStakePoolMetadata tr badUrl presentPids
res <- getStakePoolMetadata tr badUrl presentOwners
case res of
Left (FetchErrorDownload msg) ->
head (words msg) `shouldBe` "HttpExceptionRequest"
Expand Down Expand Up @@ -118,22 +118,34 @@ dataDir = $( TH.LitE . TH.StringL <$>
testUrl :: Port -> String
testUrl p = "http://localhost:" <> show p <> "/testnet-stake-pool-registry-master.zip"

presentPids :: [PoolId]
presentPids = map PoolId
[ "pk1afhcpw2tg7nr2m3wr4x8jaa4dv7d09gnv27kwfxpjyvukwxs8qdqwg85xp"
, "pk1z4vh8gva25w07x8574uujuveu8gz43fu6qfln3t4prcavrvcphjsk0pdqs"
presentOwners :: [PoolId]
presentOwners = map PoolId
[ "ed25519_pk1afhcpw2tg7nr2m3wr4x8jaa4dv7d09gnv27kwfxpjyvukwxs8qdqwg85xp"
, "ed25519_pk1z4vh8gva25w07x8574uujuveu8gz43fu6qfln3t4prcavrvcphjsk0pdqs"
]

presentMetas :: [StakePoolMetadata]
presentMetas =
[ StakePoolMetadata (unsafeFromText "FST") "https://12345"
"ed25519_pk15vz9yc5c3upgze8tg5kd7kkzxqgqfxk5a3kudp22hdg0l2za00sq2ufkk7"
, StakePoolMetadata (unsafeFromText "TICK") "https://12345"
"ed25519_pk15vz9yc5c3upgze8tg5kd7kkzxqgqfxk5a3kudp22hdg0l2za00sq2ufkk7"
[ StakePoolMetadata
{ ticker = unsafeFromText "FST"
, homepage = "https://12345"
, owner = unsafeFromText "ed25519_pk1afhcpw2tg7nr2m3wr4x8jaa4dv7d09gnv27kwfxpjyvukwxs8qdqwg85xp"
, name = "First stake pool"
, description = Just "It's better than SND"
, pledgeAddress = "addr15vz9yc5c3upgze8tg5kd7kkzxqgqfxk5a3kudp22hdg0l2za00sq2ufkk7"
}
, StakePoolMetadata
{ ticker = unsafeFromText "TICK"
, homepage = "https://12345"
, owner = unsafeFromText "ed25519_pk1z4vh8gva25w07x8574uujuveu8gz43fu6qfln3t4prcavrvcphjsk0pdqs"
, name = "Pooley Mc-Poolface"
, description = Nothing
, pledgeAddress = "addr15vz9yc5c3upgze8tg5kd7kkzxqgqfxk5a3kudp22hdg0l2za00sq2ufkk7"
}
]

absentPid :: PoolId
absentPid = PoolId "pk192m4ytl5k357e2l666yleuwjlurmf0vxjyh4atxzu5m22q6mexlsp88k7x"
absentOwner :: PoolId
absentOwner = PoolId "pk192m4ytl5k357e2l666yleuwjlurmf0vxjyh4atxzu5m22q6mexlsp88k7x"

{-------------------------------------------------------------------------------
Property
Expand All @@ -142,7 +154,7 @@ absentPid = PoolId "pk192m4ytl5k357e2l666yleuwjlurmf0vxjyh4atxzu5m22q6mexlsp88k7
data TestCase = TestCase
{ stakePools :: [(PoolId, StakePoolEntry)]
-- ^ Stake pool metadata in the zip file.
, poolIds :: [PoolId]
, poolOwners :: [PoolId]
-- ^ Stake pools to look up for the test.
, topDir :: FilePath
-- ^ The name of the top-level directory in the zip file.
Expand All @@ -163,14 +175,14 @@ prop_getStakePoolMetadata tc = monadicIO $ do
(res, msgs) <- run $ withTestCaseZip tc $ \zipFile ->
testServer (takeDirectory zipFile) $ \port -> do
let url = testCaseUrl tc port
captureLogging $ \tr -> getStakePoolMetadata tr url (poolIds tc)
captureLogging $ \tr -> getStakePoolMetadata tr url (poolOwners tc)
let numDecodeErrors = count isDecodeErrorMsg msgs

-- Expected results
let expected =
[ stakePoolEntryMeta =<< lookup p (stakePools tc) | p <- poolIds tc ]
[ stakePoolEntryMeta =<< lookup p (stakePools tc) | p <- poolOwners tc ]
let numJunkEntries =
count (\(p, e) -> isJunk e && p `elem` poolIds tc) (stakePools tc)
count (\(p, e) -> isJunk e && p `elem` poolOwners tc) (stakePools tc)

monitor $ counterexample $ unlines $
[ "expected = " ++ show expected
Expand Down Expand Up @@ -231,9 +243,9 @@ instance Arbitrary TestCase where
stakePools <- arbitrary
presentPoolIds <- sublistOf (map fst stakePools)
absentPoolIds <- arbitrary
poolIds <- shuffle (presentPoolIds ++ absentPoolIds)
poolOwners <- shuffle (presentPoolIds ++ absentPoolIds)
PathElement topDir <- arbitrary
pure $ TestCase {stakePools, poolIds, topDir}
pure $ TestCase {stakePools, poolOwners, topDir}
shrink (TestCase sps pids td)
= [ TestCase sps' pids' td'
| (sps', pids', td') <- shrink (sps, pids, td)
Expand All @@ -248,20 +260,29 @@ instance Arbitrary StakePoolEntry where

instance Arbitrary StakePoolMetadata where
arbitrary = StakePoolMetadata
<$> arbitrary <*> arbitraryText <*> arbitraryText
<$> arbitrary
<*> arbitrary
<*> arbitraryText
<*> arbitraryMaybeText
<*> arbitraryText
<*> arbitraryText
where
arbitraryText = T.pack <$> arbitrary
arbitraryMaybeText = fmap T.pack <$> arbitrary

instance Arbitrary StakePoolTicker where
arbitrary = unsafeFromText . T.pack <$> do
len <- choose (3, 4)
len <- choose (3, 5)
replicateM len arbitrary

instance Arbitrary PoolId where
arbitrary = do
bytes <- infiniteListOf $ elements ['a'..'z']
return $ PoolId $ B8.pack $ take 32 bytes

instance Arbitrary PoolOwner where
arbitrary = PoolOwner . B8.pack . pure <$> elements ['a'..'g']

newtype PathElement = PathElement FilePath deriving (Show, Eq)

instance Arbitrary PathElement where
Expand Down

0 comments on commit 55b4233

Please sign in to comment.