Add settings column to pools database wrt ADP-427

lib/core/cardano-wallet-core.cabal

@@ -226,6 +226,7 @@ test-suite unit
     , lens
     , memory
     , network
+    , network-uri
     , persistent
     , OddWord
     , QuickCheck

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

@@ -31,6 +31,7 @@ import Cardano.Wallet.Primitive.Types
     , PoolLifeCycleStatus (..)
     , PoolRegistrationCertificate
     , PoolRetirementCertificate
+    , Settings
     , SlotNo (..)
     , StakePoolMetadata
     , StakePoolMetadataHash
@@ -223,6 +224,15 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         --    - 'listRetiredPools'.
         --    - 'removePools'.
 
+    , readSettings
+        :: stm Settings
+        -- ^ Get the settings.
+
+    , modSettings
+        :: (Settings -> Settings)
+        -> stm ()
+        -- ^ Modify the settings.
+
     , cleanDB
         :: stm ()
         -- ^ Clean a database

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

@@ -28,6 +28,7 @@ import Cardano.Pool.DB.Model
     , mListPoolLifeCycleData
     , mListRegisteredPools
     , mListRetiredPools
+    , mModSettings
     , mPutFetchAttempt
     , mPutPoolMetadata
     , mPutPoolProduction
@@ -40,6 +41,7 @@ import Cardano.Pool.DB.Model
     , mReadPoolProduction
     , mReadPoolRegistration
     , mReadPoolRetirement
+    , mReadSettings
     , mReadStakeDistribution
     , mReadSystemSeed
     , mReadTotalProduction
@@ -146,6 +148,11 @@ newDBLayer timeInterpreter = do
                 . alterPoolDB (const Nothing) db
                 . mRemoveRetiredPools
 
+        readSettings = readPoolDB db $ mReadSettings
+
+        modSettings =
+            void . alterPoolDB (const Nothing) db . mModSettings
+
         cleanDB =
             void $ alterPoolDB (const Nothing) db mCleanDatabase
 

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

@@ -56,6 +56,8 @@ module Cardano.Pool.DB.Model
     , mReadCursor
     , mRemovePools
     , mRemoveRetiredPools
+    , mReadSettings
+    , mModSettings
     ) where
 
 import Prelude
@@ -73,10 +75,12 @@ import Cardano.Wallet.Primitive.Types
     , PoolOwner (..)
     , PoolRegistrationCertificate (..)
     , PoolRetirementCertificate (..)
+    , Settings
     , SlotNo (..)
     , StakePoolMetadata
     , StakePoolMetadataHash
     , StakePoolMetadataUrl
+    , defaultSettings
     )
 import Control.Monad.Trans.Class
     ( lift )
@@ -142,6 +146,8 @@ data PoolDatabase = PoolDatabase
 
     , seed :: !SystemSeed
     -- ^ Store an arbitrary random generator seed
+
+    , settings :: Settings
     } deriving (Generic, Show, Eq)
 
 data SystemSeed
@@ -159,6 +165,7 @@ instance Eq SystemSeed where
 emptyPoolDatabase :: PoolDatabase
 emptyPoolDatabase =
     PoolDatabase mempty mempty mempty mempty mempty mempty mempty NotSeededYet
+        defaultSettings
 
 {-------------------------------------------------------------------------------
                                   Model Operation Types
@@ -416,6 +423,15 @@ mRemoveRetiredPools epoch = do
     mRemovePools (view #poolId <$> certificates)
     pure certificates
 
+mReadSettings
+    :: ModelOp Settings
+mReadSettings = get #settings
+
+mModSettings
+    :: (Settings -> Settings)
+    -> ModelOp ()
+mModSettings f = modify #settings f
+
 --------------------------------------------------------------------------------
 -- Utilities
 --------------------------------------------------------------------------------

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

@@ -64,6 +64,7 @@ import Cardano.Wallet.Primitive.Types
     , PoolRetirementCertificate (..)
     , StakePoolMetadata (..)
     , StakePoolMetadataHash
+    , defaultSettings
     )
 import Cardano.Wallet.Unsafe
     ( unsafeMkPercentage )
@@ -136,6 +137,8 @@ import Cardano.Pool.DB.Sqlite.TH
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
 import qualified Database.Sqlite as Sqlite
+import qualified Cardano.Wallet.Primitive.Types as W
+
 
 -- | Return the preferred @FilePath@ for the stake pool .sqlite file, given a
 -- parent directory.
@@ -482,6 +485,22 @@ newDBLayer trace fp timeInterpreter = do
                 Just seed ->
                     return $ seedSeed $ entityVal seed
 
+        readSettings = do
+            l <- selectList
+                []
+                -- only ever read the first row
+                [Asc SettingsId, LimitTo 1]
+            case l of
+                [] -> pure defaultSettings
+                (x:_) -> pure . fromSettings . entityVal $ x
+
+        modSettings f = do
+            oldSettings <- readSettings
+            repsert
+                -- only ever write the first row
+                (SettingsKey 1)
+                (toSettings $ f oldSettings)
+
         cleanDB = do
             deleteWhere ([] :: [Filter PoolProduction])
             deleteWhere ([] :: [Filter PoolOwner])
@@ -490,6 +509,7 @@ newDBLayer trace fp timeInterpreter = do
             deleteWhere ([] :: [Filter StakeDistribution])
             deleteWhere ([] :: [Filter PoolMetadata])
             deleteWhere ([] :: [Filter PoolMetadataFetchAttempts])
+            deleteWhere ([] :: [Filter Settings])
 
         atomically :: forall a. (SqlPersistT IO a -> IO a)
         atomically = runQuery
@@ -866,3 +886,14 @@ fromPoolMeta meta = (poolMetadataHash meta,) $
         , description = poolMetadataDescription meta
         , homepage = poolMetadataHomepage meta
         }
+
+fromSettings
+    :: Settings
+    -> W.Settings
+fromSettings (Settings pms) = W.Settings pms
+
+toSettings
+    :: W.Settings
+    -> Settings
+toSettings (W.Settings pms) = Settings pms
+

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

@@ -49,6 +49,11 @@ share
     ]
     [persistLowerCase|
 
+Settings sql=settings
+    settingsPoolMetadataSource       W.PoolMetadataSource   sql=metadata_source
+
+    deriving Show Generic
+
 -- A unique, but arbitrary, value for this particular device
 ArbitrarySeed sql=arbitrary_seed
     seedSeed                    StdGen       sql=seed

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

@@ -40,6 +40,7 @@ import Cardano.Wallet.Primitive.Types
     , FeePolicy
     , Hash (..)
     , PoolId
+    , PoolMetadataSource
     , PoolOwner (..)
     , StakeKeyCertificate (..)
     , StakePoolMetadataHash (..)
@@ -613,3 +614,15 @@ instance PersistField AddressState where
 
 instance PersistFieldSql AddressState where
     sqlType _ = sqlType (Proxy @Text)
+
+
+----------------------------------------------------------------------------
+-- Settings
+
+
+instance PersistField PoolMetadataSource where
+    toPersistValue = toPersistValue . toText
+    fromPersistValue = fromPersistValueFromText
+
+instance PersistFieldSql PoolMetadataSource where
+    sqlType _ = sqlType (Proxy @Text)

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

@@ -19,6 +19,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- |
 -- Copyright: © 2018-2020 IOHK
@@ -173,6 +174,11 @@ module Cardano.Wallet.Primitive.Types
     , invariant
     , distance
     , hashFromText
+
+    -- * Settings
+    , Settings(..)
+    , PoolMetadataSource (..)
+    , defaultSettings
     ) where
 
 import Prelude
@@ -263,6 +269,8 @@ import GHC.Stack
     ( HasCallStack )
 import GHC.TypeLits
     ( KnownNat, KnownSymbol, Symbol, natVal, symbolVal )
+import Network.URI
+    ( URI, parseURI, uriToString )
 import Numeric.Natural
     ( Natural )
 import System.Random
@@ -1870,3 +1878,32 @@ invariant msg a predicate =
 distance :: (Ord a, Num a) => a -> a -> a
 distance a b =
     if a < b then b - a else a - b
+
+data PoolMetadataSource
+    = None
+    | FetchDirect
+    | FetchSMASH URI
+    deriving (Show, Generic, Eq)
+
+instance ToText PoolMetadataSource where
+    toText None = (T.pack "")
+    toText FetchDirect = (T.pack "direct")
+    toText (FetchSMASH uri) = T.pack $ uriToString id uri ""
+
+instance FromText PoolMetadataSource where
+    fromText "" = Right None
+    fromText "direct" = Right FetchDirect
+    fromText (T.unpack -> uri) =
+        case parseURI uri of
+            Nothing -> Left $ TextDecodingError ("Could not parse URI: " <> uri)
+            Just uri' -> Right (FetchSMASH uri')
+
+data Settings = Settings {
+    sPoolMetadataSource :: PoolMetadataSource
+} deriving (Show, Generic, Eq)
+
+defaultSettings :: Settings
+defaultSettings = Settings {
+    sPoolMetadataSource = None
+}
+

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

@@ -29,9 +29,12 @@ import Cardano.Wallet.Primitive.Types
     , Hash (..)
     , PoolCertificate (..)
     , PoolId (..)
+    , PoolMetadataSource (..)
+    , PoolMetadataSource (..)
     , PoolOwner (..)
     , PoolRegistrationCertificate (..)
     , PoolRetirementCertificate (..)
+    , Settings (..)
     , SlotInEpoch (..)
     , SlotNo (..)
     , SlotNo (..)
@@ -50,6 +53,8 @@ import Data.Function
     ( (&) )
 import Data.Generics.Internal.VL.Lens
     ( (^.) )
+import Data.Maybe
+    ( fromJust )
 import Data.Ord
     ( Down (..) )
 import Data.Quantity
@@ -60,6 +65,8 @@ import Data.Word
     ( Word32, Word64 )
 import Data.Word.Odd
     ( Word31 )
+import Network.URI
+    ( URI, parseURI )
 import Test.QuickCheck
     ( Arbitrary (..)
     , Gen
@@ -371,3 +378,16 @@ instance Arbitrary StakePoolsFixture where
         appendPair pools pairs slot = do
             pool <- elements pools
             return $ (pool,slot):pairs
+
+instance Arbitrary URI where
+    arbitrary = elements
+        [fromJust (parseURI "https://my.little.friend")
+        ,fromJust (parseURI "http://its-friday.com:8000")]
+
+instance Arbitrary PoolMetadataSource where
+    arbitrary = oneof [ pure None
+        , pure FetchDirect
+        , fmap FetchSMASH arbitrary]
+
+instance Arbitrary Settings where
+    arbitrary = fmap Settings arbitrary

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

@@ -41,7 +41,9 @@ import Cardano.Wallet.Primitive.Types
     , PoolLifeCycleStatus (..)
     , PoolRegistrationCertificate (..)
     , PoolRetirementCertificate (..)
+    , Settings
     , SlotNo (..)
+    , defaultSettings
     , getPoolCertificatePoolId
     , getPoolRetirementCertificate
     )
@@ -203,6 +205,10 @@ properties = do
         it "MultiPoolCertificateSequence coverage is adequate"
             (property . const prop_MultiPoolCertificateSequence_coverage)
 
+        it "modSettings . readSettings == id"
+            (property . prop_modSettingsReadSettings)
+
+
 {-------------------------------------------------------------------------------
                                     Properties
 -------------------------------------------------------------------------------}
@@ -1284,6 +1290,24 @@ prop_MultiPoolCertificateSequence_coverage mpcs = checkCoverage
     certificateSequences = getSinglePoolSequences mpcs
     poolCount = length certificateSequences
 
+-- | read . put == pure
+prop_modSettingsReadSettings
+    :: DBLayer IO
+    -> Settings
+    -> Property
+prop_modSettingsReadSettings DBLayer{..} settings = do
+    monadicIO (setup >> prop)
+  where
+    setup = run $ atomically cleanDB
+    prop = do
+        defSettings <- run $ atomically $ readSettings
+        assertWith "Reading settings from empty table returns default settings"
+            (defSettings == defaultSettings)
+        run $ atomically $ modSettings (\_ -> settings)
+        modSettings' <- run $ atomically $ readSettings
+        assertWith "Modifying settings and reading afterwards works"
+            (modSettings' == settings)
+
 descSlotsPerPool :: Map PoolId [BlockHeader] -> Expectation
 descSlotsPerPool pools = do
     let checkIfDesc slots =