Merge pull request #1256 from IntersectMBO/1234-provide-workers-to-fe…

…tch-and-validate-proposals-and-drep

[#1234] Add reddis support for storing metadata validation results

.github/workflows/build-and-deploy-beta.yml

@@ -57,6 +57,7 @@ jobs:
       TRAEFIK_LE_EMAIL: "[email protected]"
       USERSNAP_SPACE_API_KEY: ${{ secrets.USERSNAP_SPACE_API_KEY }}
       IS_PROPOSAL_DISCUSSION_FORUM_ENABLED: ${{ inputs.isProposalDiscussionForumEnabled == 'enabled' }}
+      REDIS_PASSWORD: ${{ secrets.REDIS_PASSWORD }}
     steps:
       - name: Checkout code
         uses: actions/checkout@v4

.github/workflows/build-and-deploy-dev.yml

@@ -57,6 +57,7 @@ jobs:
       TRAEFIK_LE_EMAIL: "[email protected]"
       USERSNAP_SPACE_API_KEY: ${{ secrets.USERSNAP_SPACE_API_KEY }}
       IS_PROPOSAL_DISCUSSION_FORUM_ENABLED: ${{ inputs.isProposalDiscussionForumEnabled == 'enabled' }}
+      REDIS_PASSWORD: ${{ secrets.REDIS_PASSWORD }}
     steps:
       - name: Checkout code
         uses: actions/checkout@v4

.github/workflows/build-and-deploy-staging.yml

@@ -60,6 +60,7 @@ jobs:
       TRAEFIK_LE_EMAIL: "[email protected]"
       USERSNAP_SPACE_API_KEY: ${{ secrets.USERSNAP_SPACE_API_KEY }}
       IS_PROPOSAL_DISCUSSION_FORUM_ENABLED: ${{github.event_name == 'push' && 'false' || inputs.isProposalDiscussionForumEnabled == 'enabled'}}
+      REDIS_PASSWORD: ${{ secrets.REDIS_PASSWORD }}
     steps:
       - name: Checkout code
         uses: actions/checkout@v4

.github/workflows/build-and-deploy-test.yml

@@ -60,6 +60,7 @@ jobs:
       TRAEFIK_LE_EMAIL: "[email protected]"
       USERSNAP_SPACE_API_KEY: ${{ secrets.USERSNAP_SPACE_API_KEY }}
       IS_PROPOSAL_DISCUSSION_FORUM_ENABLED: ${{github.event_name == 'push' && 'false' || inputs.isProposalDiscussionForumEnabled == 'enabled'}}
+      REDIS_PASSWORD: ${{ secrets.REDIS_PASSWORD }}
     steps:
       - name: Checkout code
         uses: actions/checkout@v4

CHANGELOG.md

@@ -25,6 +25,7 @@ changes.
 
 ### Added
 
+- added separate async process that fetches new voting_anchors, validates their metadata using metadata-validation service, and then stores it in Redis database [Issue 1234](https://github.com/IntersectMBO/govtool/issues/1234)
 - added `bio` `dRepName` `email` `references` `metadataValid` and `metadataStatus` fields to `drep/list`
 - added `metadatavalidationmaxconcurrentrequests` field to the backend config
 - added `metadata/validate` endpoint [Issue 876](https://github.com/IntersectMBO/govtool/issues/876)
@@ -110,6 +111,7 @@ changes.
 
 ### Changed
 
+- `redis` config fields changed [Issue 1234](https://github.com/IntersectMBO/govtool/issues/1234)
 - `proposal.about` changed to `proposal.abstract`
 - `drep/info` now returns 4 different tx hashes instead of one latest tx hash [Issue 688](https://github.com/IntersectMBO/govtool/issues/688)
 - `proposal/list` allows user to search by tx hash [Issue 603](https://github.com/IntersectMBO/govtool/issues/603)

govtool/backend/app/Main.hs

@@ -8,6 +8,7 @@
 
 module Main where
 
+import           Control.Concurrent                     (forkIO)
 import           Control.Concurrent.QSem                (newQSem)
 import           Control.Exception                      (Exception,
                                                          SomeException,
@@ -70,6 +71,7 @@ import           VVA.API
 import           VVA.API.Types
 import           VVA.CommandLine
 import           VVA.Config
+import           VVA.Metadata (startFetchProcess)
 import           VVA.Types                              (AppEnv (..),
                                                          AppError (CriticalError, NotFoundError, ValidationError, InternalError),
                                                          CacheEnv (..))
@@ -136,6 +138,13 @@ startApp vvaConfig = do
   vvaTlsManager <- newManager tlsManagerSettings
   qsem <- newQSem (metadataValidationMaxConcurrentRequests vvaConfig)
   let appEnv = AppEnv {vvaConfig=vvaConfig, vvaCache=cacheEnv, vvaConnectionPool=connectionPool, vvaTlsManager, vvaMetadataQSem=qsem}
+
+  _ <- forkIO $ do
+     result <- runReaderT (runExceptT startFetchProcess) appEnv
+     case result of
+        Left e -> throw e
+        Right _ -> return ()
+
   server' <- mkVVAServer appEnv
   runSettings settings server'
 

govtool/backend/example-config.json

@@ -13,5 +13,10 @@
     "sentryenv": "dev",
     "metadatavalidationhost": "localhost",
     "metadatavalidationport": 3001,
-    "metadatavalidationmaxconcurrentrequests": 10
+    "metadatavalidationmaxconcurrentrequests": 10,
+    "redisconfig" : {
+      "host"    : "localhost",
+      "port"    : 8094,
+      "password": null
+  }
 }

govtool/backend/sql/get-voting-anchors.sql

@@ -0,0 +1,3 @@
+select id, url, encode(data_hash, 'hex'), type::text
+from voting_anchor
+where voting_anchor.id > ?

govtool/backend/src/VVA/Config.hs

@@ -23,6 +23,9 @@ module VVA.Config
     , getDbSyncConnectionString
     , getServerHost
     , getServerPort
+    , getRedisHost
+    , getRedisPort
+    , getRedisPassword
     , vvaConfigToText
     , getMetadataValidationHost
     , getMetadataValidationPort
@@ -66,6 +69,14 @@ data DBConfig
 instance DefaultConfig DBConfig where
   configDef = DBConfig "localhost" "cexplorer" "postgres" "test" 9903
 
+data RedisInternalConfig
+  = RedisInternalConfig
+      { redisInternalConfigHost     :: Text
+      , redisInternalConfigPort     :: Int
+      , redisInternalConfigPassword :: Maybe Text
+      }
+  deriving (FromConfig, Generic, Show)
+
 -- | Internal, backend-dependent representation of configuration for DEX.  This
 -- data type should not be exported from this module.
 data VVAConfigInternal
@@ -88,6 +99,8 @@ data VVAConfigInternal
       , vVAConfigInternalMetadataValidationPort :: Int
         -- | Maximum number of concurrent metadata requests
       , vVAConfigInternalMetadataValidationMaxConcurrentRequests :: Int
+        -- | Redis config
+      , vVAConfigInternalRedisConfig :: RedisInternalConfig
       }
   deriving (FromConfig, Generic, Show)
 
@@ -102,9 +115,18 @@ instance DefaultConfig VVAConfigInternal where
         vVAConfigInternalSentryEnv = "development",
         vVAConfigInternalMetadataValidationHost = "localhost",
         vVAConfigInternalMetadataValidationPort = 3001,
-        vVAConfigInternalMetadataValidationMaxConcurrentRequests = 10
+        vVAConfigInternalMetadataValidationMaxConcurrentRequests = 10,
+        vVAConfigInternalRedisConfig = RedisInternalConfig "localhost" 6379 Nothing
       }
 
+data RedisConfig
+  = RedisConfig
+      { redisHost :: Text
+      , redisPort :: Int
+      , redisPassword :: Maybe Text
+      }
+  deriving (Generic, Show, ToJSON)
+
 -- | DEX configuration.
 data VVAConfig
   = VVAConfig
@@ -126,6 +148,8 @@ data VVAConfig
       , metadataValidationPort :: Int
         -- | Maximum number of concurrent metadata requests
       , metadataValidationMaxConcurrentRequests :: Int
+        -- | Redis config
+      , redisConfig :: RedisConfig
       }
   deriving (Generic, Show, ToJSON)
 
@@ -169,7 +193,12 @@ convertConfig VVAConfigInternal {..} =
       sentryEnv = vVAConfigInternalSentryEnv,
       metadataValidationHost = vVAConfigInternalMetadataValidationHost,
       metadataValidationPort = vVAConfigInternalMetadataValidationPort,
-      metadataValidationMaxConcurrentRequests = vVAConfigInternalMetadataValidationMaxConcurrentRequests
+      metadataValidationMaxConcurrentRequests = vVAConfigInternalMetadataValidationMaxConcurrentRequests,
+      redisConfig = RedisConfig
+        { redisHost = redisInternalConfigHost $ vVAConfigInternalRedisConfig,
+          redisPort = redisInternalConfigPort $ vVAConfigInternalRedisConfig,
+          redisPassword = redisInternalConfigPassword $ vVAConfigInternalRedisConfig
+        }
     }
 
 -- | Load configuration from a file specified on the command line.  Load from
@@ -208,6 +237,23 @@ getServerHost ::
   m Text
 getServerHost = asks (serverHost . getter)
 
+-- | Access redis host
+getRedisHost ::
+  (Has VVAConfig r, MonadReader r m) =>
+  m Text
+getRedisHost = asks (redisHost . redisConfig . getter)
+
+-- | Access redis port
+getRedisPort ::
+  (Has VVAConfig r, MonadReader r m) =>
+  m Int
+getRedisPort = asks (redisPort . redisConfig .  getter)
+
+getRedisPassword ::
+  (Has VVAConfig r, MonadReader r m) =>
+  m (Maybe Text)
+getRedisPassword = asks (redisPassword . redisConfig . getter)
+
 -- | Access MetadataValidationService host
 getMetadataValidationHost ::
   (Has VVAConfig r, MonadReader r m) =>

govtool/backend/src/VVA/Metadata.hs

@@ -1,27 +1,32 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeApplications  #-}
 
 module VVA.Metadata where
 
-import Prelude hiding (lookup)
+import qualified Database.Redis as Redis
+import Control.Concurrent (threadDelay)
+import           Prelude hiding (lookup)
 import           Control.Monad.Except       (MonadError, throwError)
 import           Control.Monad.Reader
 import           Control.Exception          (try, Exception)
 
 import           Data.Typeable              (Typeable)
 import           Data.Vector                (toList)
 import           Data.Aeson.KeyMap          (lookup)
-import           Data.Aeson                 (Value(..), decode, encode, object, (.=))
+import           Data.Aeson                 (FromJSON, ToJSON, Value(..), decode, encode, object, (.=))
 import           Data.Maybe                 (fromJust)
-import           Data.ByteString            (ByteString)
+import           Data.ByteString            (ByteString, fromStrict, toStrict)
 import           Data.FileEmbed             (embedFile)
 import           Data.Has                   (Has, getter)
 import           Data.String                (fromString)
 import           Data.Text                  (Text, unpack, pack)
 import qualified Data.Text.Encoding         as Text
 import           Data.Time.Clock
-
+import           Data.List                  (partition)
 import qualified Database.PostgreSQL.Simple as SQL
 
 import           VVA.Config
@@ -30,9 +35,97 @@ import           VVA.Types
 import Network.HTTP.Client
 import Network.HTTP.Client.TLS
 import Data.Aeson (encode, object, (.=))
+import           Data.Scientific
+
+sqlFrom :: ByteString -> SQL.Query
+sqlFrom bs = fromString $ unpack $ Text.decodeUtf8 bs
+
+getVotingAnchorsSql :: SQL.Query
+getVotingAnchorsSql = sqlFrom $(embedFile "sql/get-voting-anchors.sql")
+
+getNewVotingAnchors ::
+    (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m)
+    => Integer
+    -> m [VotingAnchor]
+getNewVotingAnchors lastId = do
+    anchors <- withPool $ \conn -> do
+        liftIO $ SQL.query conn getVotingAnchorsSql $ SQL.Only (lastId :: Integer)
+    return $ map (\(id, url, hash, type') -> VotingAnchor (floor @Scientific id) url hash type') anchors
+
+startFetchProcess ::
+    (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m)
+    => m ()
+startFetchProcess = go 0
+    where
+        go latestKnownId = do
+            liftIO $ putStrLn "Fetching metadata..."
+
+            anchors <- getNewVotingAnchors latestKnownId
+            if null anchors
+                then do
+                    liftIO $ threadDelay (20 * 1000000)
+                    go latestKnownId
+                else do
+                    (drepMetadata, proposalMetadata) <- processAnchors anchors
+                    storeMetadata drepMetadata
+                    storeMetadata proposalMetadata
+
+                    let newId = maximum $ map votingAnchorId anchors
+
+                    liftIO $ putStrLn ("Stored " <> show (length anchors) <> " voting anchors")
+
+                    liftIO $ threadDelay (20 * 1000000)
+                    go newId
+
+
+processAnchors ::
+   (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m)
+   => [VotingAnchor]
+   -> m ( [(Text, MetadataValidationResult DRepMetadata)]
+        , [(Text, MetadataValidationResult ProposalMetadata)]
+        )
+processAnchors anchors = do
+    let (drepAnchors, proposalAnchors) = partition ((== "other") . votingAnchorType) anchors
+    drepMetadata <- mapM (\(VotingAnchor id url hash _) -> (url<>"#"<>hash, ) <$> getDRepMetadataValidationResult' url hash) drepAnchors
+    proposalMetadata <- mapM (\(VotingAnchor id url hash _) -> (url<>"#"<>hash, ) <$> getProposalMetadataValidationResult' url hash) proposalAnchors
+    return (drepMetadata, proposalMetadata)
+
+storeMetadata ::
+    (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m, ToJSON a)
+    => [(Text, MetadataValidationResult a)]
+    -> m ()
+storeMetadata metadataResults = do
+    port <- getRedisPort
+    host <- getRedisHost
+    pass <- fmap Text.encodeUtf8 <$> getRedisPassword
+    conn <- liftIO $ Redis.checkedConnect $ Redis.defaultConnectInfo
+        { Redis.connectHost = unpack host
+        , Redis.connectPort = Redis.PortNumber $ fromIntegral port
+        , Redis.connectAuth = pass
+        }
+    liftIO $ Redis.runRedis conn $ do
+        forM metadataResults $ \(reddisId, metadataValidationResult) -> do
+                _ <- Redis.set (Text.encodeUtf8 reddisId) (toStrict $ encode metadataValidationResult)
+                return ()
+    return ()
+
+fetchMetadataValidationResult ::
+    (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m, FromJSON a)
+    => Text
+    -> Text
+    -> m (Maybe (MetadataValidationResult a))
+fetchMetadataValidationResult url hash = do
+    conn <- liftIO $ Redis.checkedConnect Redis.defaultConnectInfo
+    result <- liftIO $ Redis.runRedis conn $ Redis.get (Text.encodeUtf8 $ url<>"#"<>hash)
+    case result of
+        Left _ -> return Nothing
+        Right (Just x) -> case decode $ fromStrict x of
+            Nothing -> return Nothing
+            Just x -> return $ Just x
+        Right Nothing -> return Nothing
 
-validateMetadata
-    :: (Has VVAConfig r, Has Manager r, MonadReader r m, MonadIO m, MonadError AppError m)
+validateMetadata ::
+    (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m)
     => Text
     -> Text
     -> Maybe Text
@@ -55,12 +148,25 @@ validateMetadata url hash standard = do
             Nothing -> throwError $ InternalError "Failed to validate metadata"
             Just x -> return $ Right x
 
+
 getProposalMetadataValidationResult ::
     (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m) =>
     Text ->
     Text ->
     m (MetadataValidationResult ProposalMetadata)
 getProposalMetadataValidationResult url hash = do
+    result <- fetchMetadataValidationResult url hash
+    case result of
+        Just x -> return x
+        Nothing -> getProposalMetadataValidationResult' url hash
+
+
+getProposalMetadataValidationResult' ::
+    (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m) =>
+    Text ->
+    Text ->
+    m (MetadataValidationResult ProposalMetadata)
+getProposalMetadataValidationResult' url hash = do
         result <- validateMetadata url hash (Just "CIP108")
         case result of
             Left e -> return $ MetadataValidationResult False (Just e) Nothing
@@ -83,14 +189,24 @@ getProposalMetadataValidationResult url hash = do
                     ProposalMetadata <$> abstract <*> motivation <*> rationale <*> title <*> references
                 return $ MetadataValidationResult valid status proposalMetadata
 
-
-
 getDRepMetadataValidationResult ::
     (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m) =>
     Text ->
     Text ->
     m (MetadataValidationResult DRepMetadata)
 getDRepMetadataValidationResult url hash = do
+    result <- fetchMetadataValidationResult url hash
+    case result of
+        Just x -> return x
+        Nothing -> getDRepMetadataValidationResult' url hash
+
+
+getDRepMetadataValidationResult' ::
+    (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m) =>
+    Text ->
+    Text ->
+    m (MetadataValidationResult DRepMetadata)
+getDRepMetadataValidationResult' url hash = do
         result <- validateMetadata url hash (Just "CIPQQQ")
         case result of
             Left e -> return $ MetadataValidationResult False (Just e) Nothing