diff --git a/CHANGELOG.md b/CHANGELOG.md index bad396a54..b4a7c65db 100644 --- 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 index 3b8c80121..e41774896 100644 --- 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 \ No newline at end of file diff --git a/govtool/backend/src/VVA/Types.hs b/govtool/backend/src/VVA/Types.hs index 140d451c4..85b52d976 100644 --- 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