[CAD-1330] Add http client for fetching JSON metadata.

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

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

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 =

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.

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

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!"
     }
 

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
 --      }
 
-
-