From 66c7dd2f7821ea3f2c68ea0c92cd38a212a643dc Mon Sep 17 00:00:00 2001 From: ksaric Date: Fri, 3 Jul 2020 14:35:56 +0200 Subject: [PATCH] [CAD-1330] Add http client for fetching JSON metadata. --- app/Main.hs | 5 +- smash.cabal | 3 + src/Cardano/Db/Query.hs | 44 ++++++------- src/Cardano/Db/Schema.hs | 3 +- src/Cardano/SmashDbSync.hs | 3 +- src/DB.hs | 41 ++++-------- src/DbSyncPlugin.hs | 125 ++++++++++++++++++++++++++++++------- 7 files changed, 141 insertions(+), 83 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index b3a87af..03293db 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -48,7 +48,10 @@ runCommand cmd = CreateMigration mdir -> doCreateMigration mdir RunMigrations mdir mldir -> runMigrations (\pgConfig -> pgConfig) False mdir mldir RunApplication -> runApp defaultConfiguration - RunApplicationWithDbSync dbSyncNodeParams -> runDbSyncNode poolMetadataDbSyncNodePlugin dbSyncNodeParams + RunApplicationWithDbSync dbSyncNodeParams -> + race_ + (runDbSyncNode poolMetadataDbSyncNodePlugin dbSyncNodeParams) + (runApp defaultConfiguration) InsertPool poolMetadataJsonPath poolHash -> do putTextLn "Inserting pool metadata!" result <- runPoolInsertion poolMetadataJsonPath poolHash diff --git a/smash.cabal b/smash.cabal index 8936827..538438d 100644 --- a/smash.cabal +++ b/smash.cabal @@ -88,6 +88,9 @@ library , ouroboros-network-framework , typed-protocols -- REST + , http-client + , http-client-tls + , http-types , base16-bytestring , monad-logger , transformers diff --git a/src/Cardano/Db/Query.hs b/src/Cardano/Db/Query.hs index ab64fdd..6b0d74f 100644 --- a/src/Cardano/Db/Query.hs +++ b/src/Cardano/Db/Query.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Db.Query @@ -12,30 +12,22 @@ module Cardano.Db.Query , queryCheckPoints ) where -import Cardano.Prelude hiding (from, maybeToEither, isJust, isNothing) +import Cardano.Prelude hiding (from, isJust, isNothing, + maybeToEither) -import Control.Monad (join) -import Control.Monad.Extra (mapMaybeM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Control.Monad (join) +import Control.Monad.Extra (mapMaybeM) import Control.Monad.Trans.Reader (ReaderT) -import Data.ByteString.Char8 (ByteString) -import Data.Fixed (Micro) -import Data.Maybe (catMaybes, fromMaybe, listToMaybe) -import Data.Ratio ((%), numerator) -import Data.Text (Text) -import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime, getCurrentTime) -import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) -import Data.Word (Word16, Word64) - -import Database.Esqueleto (Entity (..), From, InnerJoin (..), LeftOuterJoin (..), - PersistField, SqlExpr, SqlQuery, Value (..), ValueList, - (^.), (==.), (<=.), (&&.), (||.), (>.), - count, countRows, desc, entityKey, entityVal, from, exists, - in_, isNothing, just, limit, max_, min_, not_, notExists, on, orderBy, - select, subList_select, sum_, unValue, unSqlBackendKey, val, where_) -import Database.Persist.Sql (SqlBackend) +import Data.ByteString.Char8 (ByteString) +import Data.Maybe (catMaybes, listToMaybe) +import Data.Word (Word64) + +import Database.Esqueleto (PersistField, SqlExpr, Value, desc, + entityVal, from, isNothing, just, + limit, not_, orderBy, select, + unValue, val, where_, (==.), (^.)) +import Database.Persist.Sql (SqlBackend) import Cardano.Db.Error import Cardano.Db.Schema @@ -82,7 +74,7 @@ queryCheckPoints limitCount = do limit 1 pure $ (blk ^. BlockSlotNo) case join (unValue <$> listToMaybe latest) of - Nothing -> pure [] + Nothing -> pure [] Just slotNo -> mapMaybeM querySpacing (calcSpacing slotNo) where querySpacing :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe (Word64, ByteString)) @@ -96,7 +88,7 @@ queryCheckPoints limitCount = do convert (va, vb) = case (unValue va, unValue vb) of (Nothing, _ ) -> Nothing - (Just a, b) -> Just (a, b) + (Just a, b) -> Just (a, b) calcSpacing :: Word64 -> [Word64] calcSpacing end = diff --git a/src/Cardano/Db/Schema.hs b/src/Cardano/Db/Schema.hs index eb1a3fc..d76a9aa 100644 --- a/src/Cardano/Db/Schema.hs +++ b/src/Cardano/Db/Schema.hs @@ -20,8 +20,7 @@ import Cardano.Prelude hiding (Meta) import Data.ByteString.Char8 (ByteString) import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import Data.Word (Word16, Word64) +import Data.Word (Word64) -- Do not use explicit imports from this module as the imports can change -- from version to version due to changes to the TH code in Persistent. diff --git a/src/Cardano/SmashDbSync.hs b/src/Cardano/SmashDbSync.hs index a5a8f91..8161070 100644 --- a/src/Cardano/SmashDbSync.hs +++ b/src/Cardano/SmashDbSync.hs @@ -38,9 +38,8 @@ import qualified Cardano.Crypto as Crypto import qualified DB as DB -import Cardano.DbSync (MigrationDir (..), - getMigrationDir) import Cardano.Db.Database +import Cardano.DbSync (MigrationDir (..)) import Cardano.DbSync.Config import Cardano.DbSync.Era import Cardano.DbSync.Error diff --git a/src/DB.hs b/src/DB.hs index e6139b7..8bfb90e 100644 --- a/src/DB.hs +++ b/src/DB.hs @@ -17,26 +17,14 @@ module DB import Cardano.Prelude -import Control.Monad.Trans.Except.Exit (orDie) -import Control.Monad.Trans.Except.Extra (newExceptT) - -import Data.Aeson (eitherDecode') import qualified Data.Map as Map import Data.IORef (IORef, readIORef, modifyIORef) -import qualified Data.Text as T -import qualified Data.ByteString.Lazy as BL - import Types import Cardano.Db.Insert (insertTxMetadata) import Cardano.Db.Query (DBFail (..), queryTxMetadata) -import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Crypto.Hash.Blake2b as Crypto - -import qualified Data.ByteString.Base16 as B16 - import Cardano.Db.Migration as X import Cardano.Db.Migration.Version as X import Cardano.Db.PGConfig as X @@ -82,7 +70,7 @@ stubbedDataLayer ioDataMap ioBlacklistedPool = DataLayer , dlAddBlacklistedPool = \poolHash -> do _ <- modifyIORef ioBlacklistedPool (\pool -> [poolHash] ++ pool) -- TODO(KS): Do I even need to query this? - blacklistedPool <- readIORef ioBlacklistedPool + _blacklistedPool <- readIORef ioBlacklistedPool return $ Right poolHash } @@ -104,27 +92,20 @@ postgresqlDataLayer = DataLayer , dlAddPoolMetadata = \poolHash poolMetadata -> do - let poolOfflineMetadataByteString = BL.fromStrict . encodeUtf8 $ poolMetadata - - -- Let us try to decode the contents to JSON. - let decodedPoolMetadataJSON :: Either DBFail PoolOfflineMetadata - decodedPoolMetadataJSON = case (eitherDecode' poolOfflineMetadataByteString) of - Left err -> Left $ UnableToEncodePoolMetadataToJSON $ toS err - Right result -> return result + let poolHashBytestring = encodeUtf8 $ getPoolHash poolHash - -- If unable to decode into JSON object, fails! - _ <- orDie (\e -> renderLookupFail e) (newExceptT $ pure decodedPoolMetadataJSON) + runDbAction Nothing $ insertTxMetadata $ TxMetadata poolHashBytestring poolMetadata + return $ Right poolMetadata - let poolHashBytestring = encodeUtf8 $ getPoolHash poolHash - let hashFromMetadata = B16.encode $ Crypto.digest (Proxy :: Proxy Crypto.Blake2b_256) (encodeUtf8 poolMetadata) - if hashFromMetadata /= poolHashBytestring - then return $ Left PoolMetadataHashMismatch - else do - _poolMetadata <- runDbAction Nothing $ insertTxMetadata $ TxMetadata poolHashBytestring poolMetadata - return $ Right poolMetadata +-- let hashFromMetadata = B16.encode $ Crypto.digest (Proxy :: Proxy Crypto.Blake2b_256) (encodeUtf8 poolMetadata) +-- if hashFromMetadata /= poolHashBytestring +-- then return $ Left PoolMetadataHashMismatch +-- else do +-- _poolMetadata <- +-- return $ Right poolMetadata , dlGetBlacklistedPools = panic "To implement!" - , dlAddBlacklistedPool = \poolHash -> panic "To implement!" + , dlAddBlacklistedPool = \_poolHash -> panic "To implement!" } diff --git a/src/DbSyncPlugin.hs b/src/DbSyncPlugin.hs index c97fae6..8411ad3 100644 --- a/src/DbSyncPlugin.hs +++ b/src/DbSyncPlugin.hs @@ -1,38 +1,47 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} + module DbSyncPlugin ( poolMetadataDbSyncNodePlugin ) where import Cardano.Prelude -import Cardano.BM.Trace (Trace, logInfo) +import Cardano.BM.Trace (Trace, logInfo, logError) import Control.Monad.Logger (LoggingT) import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.Except.Extra (firstExceptT, newExceptT, runExceptT, handleExceptT, left) + +import DB (DataLayer (..), DBFail (..), postgresqlDataLayer) +import Types (PoolHash (..), PoolOfflineMetadata) + +import Data.Aeson (eitherDecode') +import qualified Data.ByteString.Lazy as BL + +import qualified Cardano.Crypto.Hash.Class as Crypto +import qualified Cardano.Crypto.Hash.Blake2b as Crypto + +import qualified Data.ByteString.Base16 as B16 + +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types.Status (statusCode) import Database.Persist.Sql (SqlBackend) import qualified Cardano.Db.Schema as DB import Cardano.Db.Insert (insertPoolMetaData) -import Cardano.Db.Run import Cardano.DbSync.Error ---import qualified Cardano.DbSync.Plugin.Default.Byron.Insert as Byron ---import qualified Cardano.DbSync.Plugin.Default.Shelley.Insert as Shelley import Cardano.DbSync.Types import Cardano.DbSync (DbSyncNodePlugin (..), defDbSyncNodePlugin) -import Cardano.DbSync.Plugin.Epoch (epochPluginOnStartup, epochPluginInsertBlock, - epochPluginRollbackBlock) - -import Ouroboros.Consensus.Byron.Ledger (ByronBlock (..)) -import qualified Cardano.DbSync.Era.Byron.Util as Byron import qualified Cardano.DbSync.Era.Shelley.Util as Shelley -import qualified Shelley.Spec.Ledger.Address as Shelley import Shelley.Spec.Ledger.BaseTypes (strictMaybeToMaybe) import qualified Shelley.Spec.Ledger.BaseTypes as Shelley -import qualified Shelley.Spec.Ledger.Coin as Shelley import qualified Shelley.Spec.Ledger.Tx as Shelley import qualified Shelley.Spec.Ledger.TxData as Shelley @@ -55,7 +64,7 @@ insertCardanoBlock -> ReaderT SqlBackend (LoggingT IO) (Either DbSyncNodeError ()) insertCardanoBlock tracer _env blkTip = do case blkTip of - ByronBlockTip blk tip -> pure $ Right () --insertByronBlock tracer blk tip + ByronBlockTip _blk _tip -> pure $ Right () --insertByronBlock tracer blk tip ShelleyBlockTip blk tip -> insertShelleyBlock tracer blk tip -- We don't care about Byron, no pools there @@ -75,7 +84,7 @@ insertCardanoBlock tracer _env blkTip = do insertShelleyBlock :: Trace IO Text -> ShelleyBlock -> Tip ShelleyBlock -> ReaderT SqlBackend (LoggingT IO) (Either DbSyncNodeError ()) -insertShelleyBlock tracer blk tip = do +insertShelleyBlock tracer blk _tip = do runExceptT $ do zipWithM_ (insertTx tracer) [0 .. ] (Shelley.blockTxs blk) @@ -91,7 +100,7 @@ insertTx :: (MonadIO m) => Trace IO Text -> Word64 -> ShelleyTx -> ExceptT DbSyncNodeError (ReaderT SqlBackend m) () -insertTx tracer blockIndex tx = +insertTx tracer _blockIndex tx = mapM_ (insertPoolCert tracer) (Shelley.txPoolCertificates $ Shelley._body tx) insertPoolCert @@ -101,27 +110,101 @@ insertPoolCert insertPoolCert tracer pCert = case pCert of Shelley.RegPool pParams -> void $ insertPoolRegister tracer pParams - Shelley.RetirePool keyHash epochNum -> pure () + Shelley.RetirePool _keyHash _epochNum -> pure () -- Currently we just maintain the data for the pool, we might not want to -- know whether it's registered insertPoolRegister - :: (MonadIO m) + :: forall m. (MonadIO m) => Trace IO Text -> ShelleyPoolParams -> ExceptT DbSyncNodeError (ReaderT SqlBackend m) (Maybe DB.PoolMetaDataId) insertPoolRegister tracer params = do liftIO . logInfo tracer $ "Inserting pool register." poolMetadataId <- case strictMaybeToMaybe $ Shelley._poolMD params of Just md -> do - -- Fetch the JSON info! - liftIO . logInfo tracer $ "Fetching JSON metadata." - liftIO . logInfo tracer $ "Inserting JSON offline metadata." + + let eitherPoolMetadata :: IO (Either DbSyncNodeError (Response BL.ByteString)) + eitherPoolMetadata = runExceptT (fetchInsertPoolMetadata tracer md) + + liftIO $ eitherPoolMetadata >>= \case + Left err -> logError tracer $ renderDbSyncNodeError err + Right response -> logInfo tracer (decodeUtf8 . BL.toStrict $ responseBody response) + liftIO . logInfo tracer $ "Inserting metadata." - Just <$> insertMetaData tracer md + pmId <- Just <$> insertMetaData tracer md + liftIO . logInfo tracer $ "Metadata inserted." + + return pmId + Nothing -> pure Nothing + liftIO . logInfo tracer $ "Inserted pool register." return poolMetadataId +fetchInsertPoolMetadata + :: Trace IO Text + -> Shelley.PoolMetaData + -> ExceptT DbSyncNodeError IO (Response BL.ByteString) +fetchInsertPoolMetadata tracer md = do + -- Fetch the JSON info! + liftIO . logInfo tracer $ "Fetching JSON metadata." + + let poolUrl = Shelley.urlToText (Shelley._poolMDUrl md) + + -- This is a bit bad to do each time, but good enough for now. + manager <- liftIO $ newManager tlsManagerSettings + + liftIO . logInfo tracer $ "Request created with URL '" <> poolUrl <> "'." + + let exceptRequest :: ExceptT DbSyncNodeError IO Request + exceptRequest = handleExceptT (\(e :: HttpException) -> NEError $ show e) (parseRequest $ toS poolUrl) + + request <- exceptRequest + + liftIO . logInfo tracer $ "HTTP Client GET request." + + let httpRequest :: MonadIO n => n (Response BL.ByteString) + httpRequest = liftIO $ httpLbs request manager + + response <- handleExceptT (\(e :: HttpException) -> NEError $ show e) httpRequest + + liftIO . logInfo tracer $ "HTTP GET request complete." + liftIO . logInfo tracer $ "The status code was: " <> (show $ statusCode $ responseStatus response) + + let poolMetadataJson = decodeUtf8 . BL.toStrict $ responseBody response + + let mdHash :: ByteString + mdHash = Shelley._poolMDHash md + + let poolHash :: Text + poolHash = decodeUtf8 . B16.encode $ mdHash + + liftIO . logInfo tracer $ "Inserting pool with hash: " <> poolHash + + let dataLayer :: DataLayer + dataLayer = postgresqlDataLayer + + -- Let us try to decode the contents to JSON. + let decodedPoolMetadataJSON :: Either DBFail PoolOfflineMetadata + decodedPoolMetadataJSON = case (eitherDecode' (responseBody response)) of + Left err -> Left $ UnableToEncodePoolMetadataToJSON $ toS err + Right result -> return result + + _exceptDecodedMetadata <- firstExceptT (\e -> NEError $ show e) (newExceptT $ pure decodedPoolMetadataJSON) + + -- Let's check the hash + let poolHashBytestring = encodeUtf8 poolHash + let hashFromMetadata = B16.encode $ Crypto.digest (Proxy :: Proxy Crypto.Blake2b_256) (encodeUtf8 poolMetadataJson) + + when (hashFromMetadata /= poolHashBytestring) $ + left $ NEError ("The pool hash does not match. '" <> poolHash <> "'") + + + liftIO . logInfo tracer $ "Inserting JSON offline metadata." + _ <- liftIO $ (dlAddPoolMetadata dataLayer) (PoolHash poolHash) poolMetadataJson + + pure response + insertMetaData :: (MonadIO m) => Trace IO Text -> Shelley.PoolMetaData @@ -145,5 +228,3 @@ insertMetaData _tracer md = -- , DB.poolRetireRetiringEpoch = unEpochNo epochNum -- } - -