diff --git a/schema/force-resync.sql b/schema/force-resync.sql new file mode 100644 index 0000000..40f69e0 --- /dev/null +++ b/schema/force-resync.sql @@ -0,0 +1,7 @@ +-- Clear block information, force re-sync. +TRUNCATE pool_metadata; +TRUNCATE pool_metadata_reference CASCADE; +TRUNCATE pool; +TRUNCATE retired_pool; +TRUNCATE pool_metadata_fetch_error CASCADE; +TRUNCATE block; diff --git a/schema/migration-2-0006-20210108.sql b/schema/migration-2-0006-20210108.sql new file mode 100644 index 0000000..773c786 --- /dev/null +++ b/schema/migration-2-0006-20210108.sql @@ -0,0 +1,22 @@ +-- Persistent generated migration. + +CREATE FUNCTION migrate() RETURNS void AS $$ +DECLARE + next_version int ; +BEGIN + SELECT stage_two + 1 INTO next_version FROM schema_version ; + IF next_version = 6 THEN + -- Fix the pool table. + DROP TABLE "pool"; + CREATe TABLE "pool"("id" SERIAL8 PRIMARY KEY UNIQUE,"pool_id" text NOT NULL); + ALTER TABLE "pool" ADD CONSTRAINT "unique_pool_id" UNIQUE("pool_id"); + -- Hand written SQL statements can be added here. + UPDATE schema_version SET stage_two = 6 ; + RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ; + END IF ; +END ; +$$ LANGUAGE plpgsql ; + +SELECT migrate() ; + +DROP FUNCTION migrate() ; diff --git a/smash-servant-types/src/Cardano/SMASH/API.hs b/smash-servant-types/src/Cardano/SMASH/API.hs index f5a4e00..b3f39fe 100644 --- a/smash-servant-types/src/Cardano/SMASH/API.hs +++ b/smash-servant-types/src/Cardano/SMASH/API.hs @@ -104,6 +104,7 @@ type EnlistPoolAPI = BasicAuthURL :> "api" :> APIVersion :> "enlist" :> ReqBody type RetiredPoolsAPI = "api" :> APIVersion :> "retired" :> ApiRes Get [PoolId] +type CheckPoolAPI = "api" :> APIVersion :> "exists" :> Capture "poolId" PoolId :> ApiRes Get PoolId -- The full API. type SmashAPI = OfflineMetadataAPI @@ -113,6 +114,7 @@ type SmashAPI = OfflineMetadataAPI :<|> EnlistPoolAPI :<|> FetchPoolErrorAPI :<|> RetiredPoolsAPI + :<|> CheckPoolAPI #ifdef TESTING_MODE :<|> RetirePoolAPI :<|> AddPoolAPI diff --git a/smash/app/Main.hs b/smash/app/Main.hs index 6902918..239eb8a 100644 --- a/smash/app/Main.hs +++ b/smash/app/Main.hs @@ -34,6 +34,7 @@ import Options.Applicative (Parser, ParserInfo, ParserPrefs) import qualified Options.Applicative as Opt +import System.FilePath (()) import qualified System.Metrics.Prometheus.Metric.Gauge as Gauge import qualified Cardano.BM.Setup as Logging @@ -67,9 +68,10 @@ main = do data Command = CreateAdminUser !ApplicationUser | DeleteAdminUser !ApplicationUser - | CreateMigration MigrationDir - | RunMigrations ConfigFile MigrationDir (Maybe LogFileDir) - | RunApplication + | CreateMigration !MigrationDir + | RunMigrations !ConfigFile !MigrationDir !(Maybe LogFileDir) + | ForceResync !ConfigFile !MigrationDir !(Maybe LogFileDir) + | RunApplication !ConfigFile #ifdef TESTING_MODE | RunStubApplication #endif @@ -85,13 +87,21 @@ runCommand :: Command -> IO () runCommand cmd = case cmd of CreateAdminUser applicationUser -> do - adminUserE <- createAdminUser DB.postgresqlDataLayer applicationUser + + let dataLayer :: DB.DataLayer + dataLayer = DB.postgresqlDataLayer Nothing + + adminUserE <- createAdminUser dataLayer applicationUser case adminUserE of Left err -> panic $ DB.renderLookupFail err Right adminUser -> putTextLn $ "Created admin user: " <> show adminUser DeleteAdminUser applicationUser -> do - adminUserE <- deleteAdminUser DB.postgresqlDataLayer applicationUser + + let dataLayer :: DB.DataLayer + dataLayer = DB.postgresqlDataLayer Nothing + + adminUserE <- deleteAdminUser dataLayer applicationUser case adminUserE of Left err -> panic $ DB.renderLookupFail err Right adminUser -> putTextLn $ "Deleted admin user: " <> show adminUser @@ -106,7 +116,21 @@ runCommand cmd = Just (LogFileDir dir) -> return $ DB.SmashLogFileDir dir DB.runMigrations trce (\pgConfig -> pgConfig) (DB.SmashMigrationDir mdir) smashLogFileDir - RunApplication -> runApp defaultConfiguration + -- We could reuse the log file dir in the future + ForceResync configFile (MigrationDir mdir) _mldir -> do + trce <- setupTraceFromConfig configFile + pgConfig <- DB.readPGPassFileEnv + + -- Just run the force-resync which deletes all the state tables. + DB.runSingleScript trce pgConfig (mdir "force-resync.sql") + + RunApplication configFile -> do + trce <- setupTraceFromConfig configFile + + let dataLayer :: DB.DataLayer + dataLayer = DB.postgresqlDataLayer (Just trce) + + runApp dataLayer defaultConfiguration #ifdef TESTING_MODE RunStubApplication -> runAppStubbed defaultConfiguration #endif @@ -140,8 +164,11 @@ runCardanoSyncWithSmash dbSyncNodeParams = do Gauge.set queuePostWrite $ mQueuePostWrite metrics } + let dataLayer :: DB.DataLayer + dataLayer = DB.postgresqlDataLayer (Just tracer) + -- The plugin requires the @DataLayer@. - let smashDbSyncNodePlugin = poolMetadataDbSyncNodePlugin DB.postgresqlDataLayer + let smashDbSyncNodePlugin = poolMetadataDbSyncNodePlugin dataLayer let runDbStartupCall = runDbStartup smashDbSyncNodePlugin @@ -171,7 +198,7 @@ runCardanoSyncWithSmash dbSyncNodeParams = do -- This is how all the calls should work, implemented on the base @DataLayer@. , csdlAddGenesisMetaBlock = \meta block -> runExceptT $ do - let addGenesisMetaBlock = DB.dlAddGenesisMetaBlock DB.postgresqlDataLayer + let addGenesisMetaBlock = DB.dlAddGenesisMetaBlock dataLayer let metaDB = convertToDB meta let blockDB = convertToDB block @@ -190,7 +217,7 @@ runCardanoSyncWithSmash dbSyncNodeParams = do race_ (runDbSyncNode cardanoSyncDataLayer metricsLayer runDbStartupCall smashDbSyncNodePlugin dbSyncNodeParams runDBThreadFunction) - (runApp defaultConfiguration) + (runApp dataLayer defaultConfiguration) -- Finish and close the metrics server -- TODO(KS): Bracket! @@ -330,6 +357,10 @@ pCommand = ( Opt.info pRunMigrations $ Opt.progDesc "Run the database migrations (which are idempotent)." ) + <> Opt.command "force-resync" + ( Opt.info pForceResync + $ Opt.progDesc "Clears all the block information and forces a resync." + ) <> Opt.command "run-app" ( Opt.info pRunApp $ Opt.progDesc "Run the application that just serves the pool info." @@ -363,10 +394,14 @@ pCommand = pRunMigrations = RunMigrations <$> pConfigFile <*> pSmashMigrationDir <*> optional pLogFileDir + pForceResync :: Parser Command + pForceResync = + ForceResync <$> pConfigFile <*> pSmashMigrationDir <*> optional pLogFileDir + -- Empty right now but we might add some params over time. Like ports and stuff? pRunApp :: Parser Command pRunApp = - pure RunApplication + RunApplication <$> pConfigFile #ifdef TESTING_MODE pRunStubApp :: Parser Command diff --git a/smash/smash.cabal b/smash/smash.cabal index 0a3ae55..ca0c360 100644 --- a/smash/smash.cabal +++ b/smash/smash.cabal @@ -133,6 +133,7 @@ executable smash-exe , esqueleto , transformers , prometheus + , filepath default-language: Haskell2010 default-extensions: diff --git a/smash/src/Cardano/SMASH/DB.hs b/smash/src/Cardano/SMASH/DB.hs index b679921..3da3b9c 100644 --- a/smash/src/Cardano/SMASH/DB.hs +++ b/smash/src/Cardano/SMASH/DB.hs @@ -21,6 +21,7 @@ module Cardano.SMASH.DB import Cardano.Prelude +import Cardano.BM.Trace (Trace, logInfo) import Control.Monad.Trans.Except.Extra (left, newExceptT) import Data.IORef (IORef, modifyIORef, @@ -37,6 +38,7 @@ import Cardano.SMASH.DBSync.Db.Insert (insertAdminUser, insertBlock, insertDelistedPool, insertMeta, + insertPool, insertPoolMetadata, insertPoolMetadataFetchError, insertPoolMetadataReference, @@ -58,6 +60,7 @@ import Cardano.SMASH.DBSync.Db.Schema as X (AdminUser (..), DelistedPool (..), Meta (..), MetaId, + Pool (..), PoolMetadata (..), PoolMetadataFetchError (..), PoolMetadataFetchErrorId, @@ -97,6 +100,9 @@ data DataLayer = DataLayer , dlAddFetchError :: PoolMetadataFetchError -> IO (Either DBFail PoolMetadataFetchErrorId) , dlGetFetchErrors :: PoolId -> Maybe UTCTime -> IO (Either DBFail [PoolFetchError]) + , dlGetPool :: PoolId -> IO (Either DBFail PoolId) + , dlAddPool :: PoolId -> IO (Either DBFail PoolId) + , dlAddGenesisMetaBlock :: X.Meta -> X.Block -> IO (Either DBFail (MetaId, BlockId)) , dlGetSlotHash :: SlotNo -> IO (Maybe (SlotNo, ByteString)) @@ -156,6 +162,9 @@ stubbedDataLayer ioDataMap (DelistedPoolsIORef ioDelistedPool) (RetiredPoolsIORe , dlAddFetchError = \_ -> panic "!" , dlGetFetchErrors = \_ -> panic "!" + , dlGetPool = \_ -> panic "!" + , dlAddPool = \_ -> panic "!" + , dlAddGenesisMetaBlock = \_ _ -> panic "!" , dlGetSlotHash = \_ -> panic "!" @@ -189,23 +198,23 @@ createStubbedDataLayer = do return dataLayer -- TODO(KS): Passing the optional tracer. -postgresqlDataLayer :: DataLayer -postgresqlDataLayer = DataLayer +postgresqlDataLayer :: Maybe (Trace IO Text) -> DataLayer +postgresqlDataLayer tracer = DataLayer { dlGetPoolMetadata = \poolId poolMetadataHash' -> do - poolMetadata <- runDbAction Nothing $ queryPoolMetadata poolId poolMetadataHash' + poolMetadata <- runDbAction tracer $ queryPoolMetadata poolId poolMetadataHash' let poolTickerName = poolMetadataTickerName <$> poolMetadata let poolMetadata' = poolMetadataMetadata <$> poolMetadata return $ (,) <$> poolTickerName <*> poolMetadata' , dlAddPoolMetadata = \mRefId poolId poolHash poolMetadata poolTicker -> do let poolTickerName = TickerName $ getPoolTicker poolTicker - poolMetadataId <- runDbAction Nothing $ insertPoolMetadata $ PoolMetadata poolId poolTickerName poolHash poolMetadata mRefId + poolMetadataId <- runDbAction tracer $ insertPoolMetadata $ PoolMetadata poolId poolTickerName poolHash poolMetadata mRefId case poolMetadataId of Left err -> return $ Left err Right _id -> return $ Right poolMetadata , dlAddMetaDataReference = \poolId poolUrl poolMetadataHash' -> do - poolMetadataRefId <- runDbAction Nothing $ insertPoolMetadataReference $ + poolMetadataRefId <- runDbAction tracer $ insertPoolMetadataReference $ PoolMetadataReference { poolMetadataReferenceUrl = poolUrl , poolMetadataReferenceHash = poolMetadataHash' @@ -214,78 +223,92 @@ postgresqlDataLayer = DataLayer return poolMetadataRefId , dlAddReservedTicker = \tickerName poolMetadataHash' -> - runDbAction Nothing $ insertReservedTicker $ ReservedTicker tickerName poolMetadataHash' + runDbAction tracer $ insertReservedTicker $ ReservedTicker tickerName poolMetadataHash' , dlCheckReservedTicker = \tickerName -> - runDbAction Nothing $ queryReservedTicker tickerName + runDbAction tracer $ queryReservedTicker tickerName , dlGetDelistedPools = do - delistedPoolsDB <- runDbAction Nothing queryAllDelistedPools + delistedPoolsDB <- runDbAction tracer queryAllDelistedPools -- Convert from DB-specific type to the "general" type return $ map (\delistedPoolDB -> PoolId . getPoolId $ delistedPoolPoolId delistedPoolDB) delistedPoolsDB , dlCheckDelistedPool = \poolId -> do - runDbAction Nothing $ queryDelistedPool poolId + runDbAction tracer $ queryDelistedPool poolId , dlAddDelistedPool = \poolId -> do - delistedPoolId <- runDbAction Nothing $ insertDelistedPool $ DelistedPool poolId + delistedPoolId <- runDbAction tracer $ insertDelistedPool $ DelistedPool poolId case delistedPoolId of Left err -> return $ Left err Right _id -> return $ Right poolId , dlRemoveDelistedPool = \poolId -> do - isDeleted <- runDbAction Nothing $ deleteDelistedPool poolId + isDeleted <- runDbAction tracer $ deleteDelistedPool poolId -- Up for a discussion, but this might be more sensible in the lower DB layer. if isDeleted then return $ Right poolId else return $ Left RecordDoesNotExist , dlAddRetiredPool = \poolId -> do - retiredPoolId <- runDbAction Nothing $ insertRetiredPool $ RetiredPool poolId + retiredPoolId <- runDbAction tracer $ insertRetiredPool $ RetiredPool poolId case retiredPoolId of Left err -> return $ Left err Right _id -> return $ Right poolId , dlGetRetiredPools = do - retiredPools <- runDbAction Nothing $ queryAllRetiredPools + retiredPools <- runDbAction tracer $ queryAllRetiredPools return $ Right $ map retiredPoolPoolId retiredPools , dlGetAdminUsers = do - adminUsers <- runDbAction Nothing $ queryAdminUsers + adminUsers <- runDbAction tracer $ queryAdminUsers return $ Right adminUsers , dlAddAdminUser = \(ApplicationUser user pass') -> do let adminUser = AdminUser user pass' - adminUserId <- runDbAction Nothing $ insertAdminUser adminUser + adminUserId <- runDbAction tracer $ insertAdminUser adminUser case adminUserId of Left err -> return $ Left err Right _id -> return $ Right adminUser , dlRemoveAdminUser = \(ApplicationUser user pass') -> do let adminUser = AdminUser user pass' - isDeleted <- runDbAction Nothing $ deleteAdminUser adminUser + isDeleted <- runDbAction tracer $ deleteAdminUser adminUser if isDeleted then return $ Right adminUser else return $ Left $ UnknownError "Admin user not deleted. Both username and password must match." , dlAddFetchError = \poolMetadataFetchError -> do - poolMetadataFetchErrorId <- runDbAction Nothing $ insertPoolMetadataFetchError poolMetadataFetchError + poolMetadataFetchErrorId <- runDbAction tracer $ insertPoolMetadataFetchError poolMetadataFetchError return poolMetadataFetchErrorId , dlGetFetchErrors = \poolId mTimeFrom -> do - poolMetadataFetchErrors <- runDbAction Nothing (queryPoolMetadataFetchErrorByTime poolId mTimeFrom) + poolMetadataFetchErrors <- runDbAction tracer (queryPoolMetadataFetchErrorByTime poolId mTimeFrom) pure $ sequence $ Right <$> map convertPoolMetadataFetchError poolMetadataFetchErrors + , dlGetPool = \poolId -> do + pool <- runDbAction tracer $ queryPoolByPoolId poolId + case pool of + Left err -> return $ Left err + Right _val -> return $ Right poolId + , dlAddPool = \poolId -> do + case tracer of + Nothing -> pure () + Just trcr -> logInfo trcr $ "Inserting pool, pool id -'" <> show poolId <> "'." + poolId' <- runDbAction tracer $ insertPool (Pool poolId) + case poolId' of + Left err -> return $ Left err + Right _val -> return $ Right poolId + , dlAddGenesisMetaBlock = \meta block -> do -- This whole function has to be atomic! runExceptT $ do -- Well, in theory this should be handled differently. - count <- newExceptT (Right <$> (runDbAction Nothing $ queryBlockCount)) + count <- newExceptT (Right <$> (runDbAction tracer $ queryBlockCount)) when (count > 0) $ left $ UnknownError "Shelley.insertValidateGenesisDist: Genesis data mismatch." - metaId <- newExceptT $ runDbAction Nothing $ insertMeta $ meta - blockId <- newExceptT $ runDbAction Nothing $ insertBlock $ block + metaId <- newExceptT $ runDbAction tracer $ insertMeta $ meta + blockId <- newExceptT $ runDbAction tracer $ insertBlock $ block pure (metaId, blockId) , dlGetSlotHash = \slotNo -> - runDbAction Nothing $ querySlotHash slotNo + runDbAction tracer $ querySlotHash slotNo } diff --git a/smash/src/Cardano/SMASH/DBSync/Db/Insert.hs b/smash/src/Cardano/SMASH/DBSync/Db/Insert.hs index c084f08..b8e5f42 100644 --- a/smash/src/Cardano/SMASH/DBSync/Db/Insert.hs +++ b/smash/src/Cardano/SMASH/DBSync/Db/Insert.hs @@ -4,6 +4,7 @@ module Cardano.SMASH.DBSync.Db.Insert ( insertBlock , insertMeta + , insertPool , insertPoolMetadata , insertPoolMetadataReference , insertReservedTicker @@ -38,6 +39,9 @@ insertBlock = insertByReturnKey insertMeta :: (MonadIO m) => Meta -> ReaderT SqlBackend m (Either DBFail MetaId) insertMeta meta = insertByReturnKey meta +insertPool :: (MonadIO m) => Pool -> ReaderT SqlBackend m (Either DBFail PoolId) +insertPool pool = insertByReturnKey pool + insertPoolMetadata :: (MonadIO m) => PoolMetadata -> ReaderT SqlBackend m (Either DBFail PoolMetadataId) insertPoolMetadata = insertByReturnKey diff --git a/smash/src/Cardano/SMASH/DBSync/Db/Migration.hs b/smash/src/Cardano/SMASH/DBSync/Db/Migration.hs index fb008c7..5997221 100644 --- a/smash/src/Cardano/SMASH/DBSync/Db/Migration.hs +++ b/smash/src/Cardano/SMASH/DBSync/Db/Migration.hs @@ -6,6 +6,7 @@ module Cardano.SMASH.DBSync.Db.Migration , createMigration , applyMigration , runMigrations + , runSingleScript ) where import Cardano.Prelude @@ -22,7 +23,7 @@ import Cardano.BM.Trace (Trace, logInfo) import qualified Data.ByteString.Char8 as BS import Data.Conduit.Binary (sinkHandle) -import Data.Conduit.Process (sourceCmdWithConsumer) +import Data.Conduit.Process (sourceCmdWithConsumer, system) import Data.Either (partitionEithers) import qualified Data.List as List import Data.Text (Text) @@ -92,6 +93,40 @@ runMigrations tracer cfgOverride migrationDir mLogfiledir = do . formatTime defaultTimeLocale ("migrate-" ++ iso8601DateFormat (Just "%H%M%S") ++ ".log") <$> getCurrentTime +-- A simple way to run a single script +runSingleScript :: Trace IO Text -> PGConfig -> FilePath -> IO () +runSingleScript tracer pgConfig script = do + -- This assumes that the credentials for 'psql' are already sorted out. + -- One way to achive this is via a 'PGPASSFILE' environment variable + -- as per the PostgreSQL documentation. + let command = + List.intercalate " " + [ "psql" + , BS.unpack (pgcDbname pgConfig) + , "--no-password" + , "--quiet" + , "--username=" <> BS.unpack (pgcUser pgConfig) + , "--host=" <> BS.unpack (pgcHost pgConfig) + , "--port=" <> BS.unpack (pgcPort pgConfig) + , "--no-psqlrc" -- Ignore the ~/.psqlrc file. + , "--single-transaction" -- Run the file as a transaction. + , "--set ON_ERROR_STOP=on" -- Exit with non-zero on error. + , "--file='" ++ script ++ "'" + , "2>&1" -- Pipe stderr to stdout. + ] + + logInfo tracer $ toS $ "Running: " ++ takeFileName script + + hFlush stdout + exitCode <- system command + + case exitCode of + ExitSuccess -> + logInfo tracer "ExitSuccess." + ExitFailure _ -> do + print exitCode + exitFailure + applyMigration :: Trace IO Text -> PGConfig -> Maybe FilePath -> Handle -> (MigrationVersion, FilePath) -> IO () applyMigration tracer pgconfig mLogFilename logHandle (version, script) = do -- This assumes that the credentials for 'psql' are already sorted out. diff --git a/smash/src/Cardano/SMASH/DBSync/Db/Query.hs b/smash/src/Cardano/SMASH/DBSync/Db/Query.hs index 3b519bd..b4c1ac0 100644 --- a/smash/src/Cardano/SMASH/DBSync/Db/Query.hs +++ b/smash/src/Cardano/SMASH/DBSync/Db/Query.hs @@ -7,6 +7,8 @@ module Cardano.SMASH.DBSync.Db.Query ( DBFail (..) , querySchemaVersion , querySlotHash + , queryAllPools + , queryPoolByPoolId , queryPoolMetadata , queryBlockCount , queryBlockNo @@ -68,6 +70,27 @@ querySlotHash slotNo = do pure (blk ^. BlockHash) pure $ (\vh -> (slotNo, unValue vh)) <$> listToMaybe res +-- |Return all pools. +queryAllPools :: MonadIO m => ReaderT SqlBackend m [Pool] +queryAllPools = do + res <- selectList [] [] + pure $ entityVal <$> res + +-- |Return pool, that is not RETIRED! +queryPoolByPoolId :: MonadIO m => Types.PoolId -> ReaderT SqlBackend m (Either DBFail Pool) +queryPoolByPoolId poolId = do + res <- select . from $ \(pool :: SqlExpr (Entity Pool)) -> do + where_ (pool ^. PoolPoolId ==. val poolId + &&. pool ^. PoolPoolId `notIn` retiredPoolsPoolId) + pure pool + pure $ maybeToEither RecordDoesNotExist entityVal (listToMaybe res) + where + -- |Subselect that selects all the retired pool ids. + retiredPoolsPoolId :: SqlExpr (ValueList (Types.PoolId)) + retiredPoolsPoolId = + subList_select . from $ \(retiredPool :: SqlExpr (Entity RetiredPool)) -> + return $ retiredPool ^. RetiredPoolPoolId + -- | Get the 'Block' associated with the given hash. -- We use the @Types.PoolId@ to get the nice error message out. queryPoolMetadata :: MonadIO m => Types.PoolId -> Types.PoolMetadataHash -> ReaderT SqlBackend m (Either DBFail PoolMetadata) diff --git a/smash/src/Cardano/SMASH/DBSync/Db/Schema.hs b/smash/src/Cardano/SMASH/DBSync/Db/Schema.hs index dc64114..6f1312b 100644 --- a/smash/src/Cardano/SMASH/DBSync/Db/Schema.hs +++ b/smash/src/Cardano/SMASH/DBSync/Db/Schema.hs @@ -78,7 +78,7 @@ share -- The pools themselves (identified by the owner vkey hash) Pool - poolId PoolId sqltype=text + poolId Types.PoolId sqltype=text UniquePoolId poolId -- The retired pools. @@ -88,6 +88,7 @@ share UniqueRetiredPoolId poolId -- The pool metadata fetch error. We duplicate the poolId for easy access. + -- TODO(KS): Debatable whether we need to persist this between migrations! PoolMetadataFetchError fetchTime UTCTime sqltype=timestamp @@ -107,8 +108,13 @@ share blockNo Word64 Maybe sqltype=uinteger UniqueBlock hash + -------------------------------------------------------------------------- + -- Tables below should be preserved when migration occurs! + -------------------------------------------------------------------------- + -- A table containing metadata about the chain. There will probably only ever be one -- row in this table. + -- TODO(KS): This can be left alone when migration occurs since it should be the same! Meta protocolConst Word64 -- The block security parameter. slotDuration Word64 -- Slot duration in milliseconds. diff --git a/smash/src/Cardano/SMASH/DBSyncPlugin.hs b/smash/src/Cardano/SMASH/DBSyncPlugin.hs index ad914d7..8e36bef 100644 --- a/smash/src/Cardano/SMASH/DBSyncPlugin.hs +++ b/smash/src/Cardano/SMASH/DBSyncPlugin.hs @@ -174,7 +174,7 @@ insertTx -> DbSyncEnv -> Word64 -> Generic.Tx - -> ExceptT DbSyncNodeError (ReaderT SqlBackend m) () + -> ExceptT DbSyncNodeError m () insertTx dataLayer tracer env _blockIndex tx = mapM_ (insertCertificate dataLayer tracer env) $ Generic.txCertificates tx @@ -184,12 +184,13 @@ insertCertificate -> Trace IO Text -> DbSyncEnv -> Generic.TxCertificate - -> ExceptT DbSyncNodeError (ReaderT SqlBackend m) () + -> ExceptT DbSyncNodeError m () insertCertificate dataLayer tracer _env (Generic.TxCertificate _idx cert) = case cert of Shelley.DCertDeleg _deleg -> liftIO $ logInfo tracer "insertCertificate: DCertDeleg" - Shelley.DCertPool pool -> insertPoolCert dataLayer tracer pool + Shelley.DCertPool pool -> + insertPoolCert dataLayer tracer pool Shelley.DCertMir _mir -> liftIO $ logInfo tracer "insertCertificate: DCertMir" Shelley.DCertGenesis _gen -> @@ -200,10 +201,22 @@ insertPoolCert => DataLayer -> Trace IO Text -> Shelley.PoolCert StandardShelley - -> ExceptT DbSyncNodeError (ReaderT SqlBackend m) () + -> ExceptT DbSyncNodeError m () insertPoolCert dataLayer tracer pCert = case pCert of - Shelley.RegPool pParams -> insertPoolRegister dataLayer tracer pParams + Shelley.RegPool pParams -> do + let poolIdHash = B16.encode . Generic.unKeyHashRaw $ Shelley._poolId pParams + let poolId = PoolId . decodeUtf8 $ poolIdHash + + -- Insert pool id + let addPool = dlAddPool dataLayer + addedPool <- liftIO $ addPool poolId + + case addedPool of + Left _err -> liftIO . logInfo tracer $ "Pool already registered with pool id: " <> decodeUtf8 poolIdHash + Right _pool -> liftIO . logInfo tracer $ "Inserting pool register with pool id: " <> decodeUtf8 poolIdHash + + insertPoolRegister dataLayer tracer pParams -- RetirePool (KeyHash 'StakePool era) _ = PoolId Shelley.RetirePool poolPubKey _epochNum -> do @@ -225,12 +238,11 @@ insertPoolRegister => DataLayer -> Trace IO Text -> Shelley.PoolParams StandardShelley - -> ExceptT DbSyncNodeError (ReaderT SqlBackend m) () + -> ExceptT DbSyncNodeError m () insertPoolRegister dataLayer tracer params = do let poolIdHash = B16.encode . Generic.unKeyHashRaw $ Shelley._poolId params let poolId = PoolId . decodeUtf8 $ poolIdHash - liftIO . logInfo tracer $ "Inserting pool register with pool id: " <> decodeUtf8 poolIdHash case strictMaybeToMaybe $ Shelley._poolMD params of Just md -> do diff --git a/smash/src/Cardano/SMASH/Lib.hs b/smash/src/Cardano/SMASH/Lib.hs index 75b1e53..e9d9bc5 100644 --- a/smash/src/Cardano/SMASH/Lib.hs +++ b/smash/src/Cardano/SMASH/Lib.hs @@ -53,7 +53,6 @@ import Cardano.SMASH.API (API, fullAPI, smashApi) import Cardano.SMASH.DB (AdminUser (..), DBFail (..), DataLayer (..), createStubbedDataLayer, - postgresqlDataLayer, reservedTickerPoolHash) import Cardano.SMASH.Types (ApiResult (..), @@ -100,15 +99,15 @@ todoSwagger = , _infoVersion = smashVersion } -runApp :: Configuration -> IO () -runApp configuration = do +runApp :: DataLayer -> Configuration -> IO () +runApp dataLayer configuration = do let port = cPortNumber configuration let settings = setPort port $ setBeforeMainLoop (hPutStrLn stderr ("listening on port " ++ show port)) $ defaultSettings - runSettings settings =<< mkApp configuration + runSettings settings =<< (mkApp dataLayer configuration) runAppStubbed :: Configuration -> IO () runAppStubbed configuration = do @@ -130,11 +129,8 @@ mkAppStubbed configuration = do (basicAuthServerContext stubbedApplicationUsers) (server configuration dataLayer) -mkApp :: Configuration -> IO Application -mkApp configuration = do - - let dataLayer :: DataLayer - dataLayer = postgresqlDataLayer +mkApp :: DataLayer -> Configuration -> IO Application +mkApp dataLayer configuration = do -- Ugly hack, wait 2s for migrations to run for the admin user to be created. -- You can always run the migrations first. @@ -210,6 +206,7 @@ server _configuration dataLayer :<|> enlistPool dataLayer :<|> getPoolErrorAPI dataLayer :<|> getRetiredPools dataLayer + :<|> checkPool dataLayer #ifdef TESTING_MODE :<|> retirePool dataLayer :<|> addPool dataLayer @@ -344,6 +341,15 @@ getRetiredPools dataLayer = convertIOToHandler $ do return . ApiResult $ retiredPools +checkPool :: DataLayer -> PoolId -> Handler (ApiResult DBFail PoolId) +checkPool dataLayer poolId = convertIOToHandler $ do + + let getPool = dlGetPool dataLayer + existingPoolId <- getPool poolId + + return . ApiResult $ existingPoolId + + #ifdef TESTING_MODE retirePool :: DataLayer -> PoolId -> Handler (ApiResult DBFail PoolId) retirePool dataLayer poolId = convertIOToHandler $ do diff --git a/smash/src/Cardano/SMASH/Offline.hs b/smash/src/Cardano/SMASH/Offline.hs index ce2d334..eb5dca7 100644 --- a/smash/src/Cardano/SMASH/Offline.hs +++ b/smash/src/Cardano/SMASH/Offline.hs @@ -190,7 +190,8 @@ fetchInsertDefault poolId tracer pfr = do then left $ FEHashMismatch poolId expectedHash (renderByteStringHex hashFromMetadata) poolMetadataURL else liftIO . logInfo tracer $ "Inserting pool data with hash: " <> expectedHash - let addPoolMetadata = dlAddPoolMetadata postgresqlDataLayer + let dataLayer = postgresqlDataLayer (Just tracer) + let addPoolMetadata = dlAddPoolMetadata dataLayer _ <- liftIO $ addPoolMetadata @@ -206,7 +207,8 @@ fetchInsertDefault poolId tracer pfr = do runOfflineFetchThread :: Trace IO Text -> IO () runOfflineFetchThread trce = do liftIO $ logInfo trce "Runing Offline fetch thread" - fetchLoop postgresqlDataLayer FetchLoopForever trce queryPoolFetchRetryDefault + let dataLayer = postgresqlDataLayer (Just trce) + fetchLoop dataLayer FetchLoopForever trce queryPoolFetchRetryDefault --------------------------------------------------------------------------------------------------- diff --git a/smash/test/MigrationSpec.hs b/smash/test/MigrationSpec.hs index 4f51ab1..878a46d 100644 --- a/smash/test/MigrationSpec.hs +++ b/smash/test/MigrationSpec.hs @@ -68,7 +68,7 @@ migrationSpec = do , pfrRetry = retry' } - let dataLayer = postgresqlDataLayer + let dataLayer = postgresqlDataLayer Nothing let fetchInsert = \_ _ _ -> left $ FEIOException "Dunno" @@ -97,7 +97,7 @@ migrationTest = do -- TODO(KS): This version HAS to be changed manually so we don't mess up the -- migration. - let expected = SchemaVersion 1 5 0 + let expected = SchemaVersion 1 6 0 actual <- getDbSchemaVersion unless (expected == actual) $ panic $ mconcat