WIP

IntersectMBO · Jul 26, 2024 · 9c09c34 · 9c09c34
1 parent 1514cb0
commit 9c09c34
Show file tree

Hide file tree

Showing 3 changed files with 46 additions and 47 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -16,7 +16,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
@@ -9,7 +9,7 @@ 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)
@@ -32,23 +32,25 @@ 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
     if not metadataEnabled
-      then return $ Right ""
+      then return $ MetadataValidationResult True (Just "Metadata validation disabled") Nothing
       else do
         metadataHost <- getMetadataValidationHost
         metadataPort <- getMetadataValidationPort
 
-        -- Configure the HTTP manager with a custom timeout
-        -- due to timeout manager errors
-        let timeout =  responseTimeoutMicro 5000000
+        let timeout = responseTimeoutMicro 1000
         manager <- liftIO $ newManager $ tlsManagerSettings { managerResponseTimeout = timeout }
 
         let requestBody = encode $ object $
@@ -57,7 +59,9 @@ validateMetadata url hash standard = do
 
         parsedRequestResult <- liftIO $ try $ parseRequest requestUrl
         case parsedRequestResult of
-            Left (e :: SomeException) -> return $ Left (pack $ "Failed to parse request: " ++ show e)
+            Left (e :: SomeException) -> do
+                logException url e
+                return $ MetadataValidationResult False (Just "VALIDATION_FAILED") Nothing
             Right initialRequest -> do
                 let request = initialRequest
                         { method = "POST"
@@ -67,10 +71,12 @@ validateMetadata url hash standard = do
 
                 responseResult <- liftIO $ try $ httpLbs request manager
                 case responseResult of
-                    Left (e :: SomeException) -> return $ Left (pack $ "Failed to make HTTP request: " ++ show e)
+                    Left (e :: SomeException) -> do
+                        logException url e
+                        return $ MetadataValidationResult False (Just "VALIDATION_FAILED") Nothing
                     Right response -> case decode (responseBody response) of
-                        Nothing -> throwError $ InternalError "Failed to validate metadata"
-                        Just x  -> return $ Right x
+                        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) =>
@@ -80,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) =>
@@ -110,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