fix(#1612): Fix connection to the metadata-validation service

* fix(#1417): handle thread killed by timeout manager exception
IntersectMBO · Jul 29, 2024 · 20ba77a · 20ba77a
1 parent 2067137
commit 20ba77a
Show file tree

Hide file tree

Showing 3 changed files with 71 additions and 58 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -17,7 +17,8 @@ changes.
 
 ### Fixed
 
--
+- Fix querying metadata-validation service from haskell backend [Issue 1612](https://github.com/IntersectMBO/govtool/issues/1612)
+- Fix thread killed by timeout manager [Issue 1417](https://github.com/IntersectMBO/govtool/issues/1417)
 
 ### Changed
 

diff --git a/govtool/backend/src/VVA/Metadata.hs b/govtool/backend/src/VVA/Metadata.hs
@@ -4,12 +4,12 @@
 
 module VVA.Metadata where
 
-import           Control.Exception          (Exception, try)
+import           Control.Exception          (SomeException, Exception, try)
 import           Control.Monad.Except       (MonadError, throwError)
 import           Control.Monad.Reader
 
 import           Data.Aeson                 (Value (..), decode, encode, object, (.=))
-import           Data.Aeson.KeyMap          (lookup)
+import           Data.Aeson.KeyMap          (KeyMap, lookup)
 import           Data.ByteString            (ByteString)
 import           Data.FileEmbed             (embedFile)
 import           Data.Has                   (Has, getter)
@@ -23,7 +23,7 @@ import           Data.Vector                (toList)
 
 import qualified Database.PostgreSQL.Simple as SQL
 
-import           Network.HTTP.Client
+import           Network.HTTP.Client        (httpLbs, parseRequest, Request(..), RequestBody(..), Response, Manager, newManager, managerResponseTimeout, responseTimeoutMicro, defaultManagerSettings, responseBody)
 import           Network.HTTP.Client.TLS
 
 import           Prelude                    hiding (lookup)
@@ -32,31 +32,51 @@ import           VVA.Config
 import           VVA.Pool                   (ConnectionPool, withPool)
 import           VVA.Types
 
+
+logException :: (MonadIO m) => Text -> SomeException -> m ()
+logException url ex = liftIO $ putStrLn $ "Failed to validate metadata for URL: " ++ unpack url ++ " with error: " ++ show ex
+
 validateMetadata
     :: (Has VVAConfig r, Has Manager r, MonadReader r m, MonadIO m, MonadError AppError m)
     => Text
     -> Text
     -> Maybe Text
-    -> m (Either Text Value)
+    -> m (MetadataValidationResult Value)
 validateMetadata url hash standard = do
     metadataEnabled <- getMetadataValidationEnabled
-    metadataHost <- getMetadataValidationHost
-    metadataPort <- getMetadataValidationPort
-    manager <- asks getter
-    (if metadataEnabled then (do
-      let requestBody = encode $ object (["url" .= unpack url, "hash" .= unpack hash] ++ maybe [] (\x -> ["standard" .= unpack x]) standard)
-      initialRequest <- liftIO $ parseRequest (unpack metadataHost <> ":" <> show metadataPort <> "/validate")
-      let request = initialRequest
-              { method = "POST"
-              , requestBody = RequestBodyLBS requestBody
-              , requestHeaders = [("Content-Type", "application/json")]
-              }
-      response <- liftIO $ try $ httpLbs request manager
-      case response of
-          Left (e :: HttpException) -> return $ Left (pack $ show e)
-          Right r -> case decode $ responseBody r of
-              Nothing -> throwError $ InternalError "Failed to validate metadata"
-              Just x  -> return $ Right x) else return $ Right "")
+    if not metadataEnabled
+      then return $ MetadataValidationResult True (Just "Metadata validation disabled") Nothing
+      else do
+        metadataHost <- getMetadataValidationHost
+        metadataPort <- getMetadataValidationPort
+
+        let timeout = responseTimeoutMicro 1000
+        manager <- liftIO $ newManager $ tlsManagerSettings { managerResponseTimeout = timeout }
+
+        let requestBody = encode $ object $
+                ["url" .= url, "hash" .= hash] ++ maybe [] (\x -> ["standard" .= x]) standard
+            requestUrl = unpack metadataHost ++ ":" ++ show metadataPort ++ "/validate"
+
+        parsedRequestResult <- liftIO $ try $ parseRequest requestUrl
+        case parsedRequestResult of
+            Left (e :: SomeException) -> do
+                logException url e
+                return $ MetadataValidationResult False (Just "VALIDATION_FAILED") Nothing
+            Right initialRequest -> do
+                let request = initialRequest
+                        { method = "POST"
+                        , requestBody = RequestBodyLBS requestBody
+                        , requestHeaders = [("Content-Type", "application/json")]
+                        }
+
+                responseResult <- liftIO $ try $ httpLbs request manager
+                case responseResult of
+                    Left (e :: SomeException) -> do
+                        logException url e
+                        return $ MetadataValidationResult False (Just "VALIDATION_FAILED") Nothing
+                    Right response -> case decode (responseBody response) of
+                        Nothing -> return $ MetadataValidationResult False (Just "VALIDATION_FAILED") Nothing
+                        Just x  -> return $ MetadataValidationResult True (Just "VALIDATION_SUCCESS") (Just x)
 
 getProposalMetadataValidationResult ::
     (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m) =>
@@ -66,27 +86,23 @@ getProposalMetadataValidationResult ::
 getProposalMetadataValidationResult url hash = do
         result <- validateMetadata url hash (Just "CIP108")
         case result of
-            Left e -> return $ MetadataValidationResult False (Just e) Nothing
-            Right (Object r) -> case go r of
+            MetadataValidationResult False status _ -> return $ MetadataValidationResult False status Nothing
+            MetadataValidationResult True status (Just (Object r)) -> case go r of
                 Nothing -> throwError $ InternalError "Failed to validate metadata"
-                Just x  -> return x
-            Right "" -> return $ MetadataValidationResult True (Just "200") Nothing
+                Just x  -> return $ MetadataValidationResult True status (Just x)
+            _ -> return $ MetadataValidationResult False (Just "VALIDATION_FAILED") Nothing
     where
+        go :: KeyMap Value -> Maybe ProposalMetadata
         go result = do
-                (Bool valid) <- lookup "valid" result
-                let status = case lookup "status" result of
-                                Just (String s) -> Just s
-                                _               -> Nothing
-                (Object m) <- lookup "metadata" result
-                let abstract = (\(String s) -> s) <$> lookup "abstract" m
-                let motivation = (\(String s) -> s) <$> lookup "motivation" m
-                let rationale = (\(String s) -> s) <$> lookup "rationale" m
-                let title = (\(String s) -> s) <$> lookup "title" m
-                let references = (\(Array references') -> map (\(String x) -> x) $ toList references') <$> lookup "references" m
-                let proposalMetadata = ProposalMetadata <$> abstract <*> motivation <*> rationale <*> title <*> references
-                return $ MetadataValidationResult valid status proposalMetadata
-
-
+            (Bool valid) <- lookup "valid" result
+            (Object metadata) <- lookup "metadata" result
+            (String abstract) <- lookup "abstract" metadata
+            (String motivation) <- lookup "motivation" metadata
+            (String rationale) <- lookup "rationale" metadata
+            (String title) <- lookup "title" metadata
+            (Array references') <- lookup "references" metadata
+            let references = map (\(String x) -> x) (toList references')
+            return $ ProposalMetadata abstract motivation rationale title references
 
 getDRepMetadataValidationResult ::
     (Has ConnectionPool r, Has Manager r, Has VVAConfig r, MonadReader r m, MonadIO m, MonadFail m, MonadError AppError m) =>
@@ -96,21 +112,19 @@ getDRepMetadataValidationResult ::
 getDRepMetadataValidationResult url hash = do
         result <- validateMetadata url hash (Just "CIPQQQ")
         case result of
-            Left e -> return $ MetadataValidationResult False (Just e) Nothing
-            Right (Object r) -> case go r of
+            MetadataValidationResult False status _ -> return $ MetadataValidationResult False status Nothing
+            MetadataValidationResult True status (Just (Object r)) -> case go r of
                 Nothing -> throwError $ InternalError "Failed to validate metadata"
-                Just x  -> return x
-            Right "" -> return $ MetadataValidationResult True (Just "200") Nothing
+                Just x  -> return $ MetadataValidationResult True status (Just x)
+            _ -> return $ MetadataValidationResult False (Just "VALIDATION_FAILED") Nothing
     where
+        go :: KeyMap Value -> Maybe DRepMetadata
         go result = do
-                (Bool valid) <- lookup "valid" result
-                let status = case lookup "status" result of
-                                Just (String s) -> Just s
-                                _               -> Nothing
-                (Object m) <- lookup "metadata" result
-                let bio = (\(String s) -> s) <$> lookup "bio" m
-                let dRepName = (\(String s) -> s) <$> lookup "dRepName" m
-                let email = (\(String s) -> s) <$> lookup "email" m
-                let references = (\(Array references') -> map (\(String x) -> x) $ toList references') <$> lookup "references" m
-                let proposalMetadata = DRepMetadata <$> bio <*> dRepName <*> email <*> references
-                return $ MetadataValidationResult valid status proposalMetadata
+            (Bool valid) <- lookup "valid" result
+            (Object metadata) <- lookup "metadata" result
+            (String bio) <- lookup "bio" metadata
+            (String dRepName) <- lookup "dRepName" metadata
+            (String email) <- lookup "email" metadata
+            (Array references') <- lookup "references" metadata
+            let references = map (\(String x) -> x) (toList references')
+            return $ DRepMetadata bio dRepName email references
diff --git a/govtool/backend/src/VVA/Types.hs b/govtool/backend/src/VVA/Types.hs
@@ -168,9 +168,7 @@ data MetadataValidationResult a
       , metadataValidationResultMetadata :: Maybe a
       }
   deriving (Show)
-
-
-
+
 
 data CacheEnv
   = CacheEnv