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

* fix(#1417): handle thread killed by timeout manager exception

govtool/backend/app/Main.hs

@@ -134,14 +134,6 @@ exceptionHandler :: VVAConfig -> Maybe Request -> SomeException -> IO ()
 exceptionHandler vvaConfig mRequest exception = do
   print mRequest
   print exception
-  let isNotTimeoutThread x = case fromException x of
-        Just TimeoutThread -> False
-        _                  -> True
-      isNotConnectionClosedByPeer x = case fromException x of
-        Just ConnectionClosedByPeer -> False
-        _                           -> True
-  guard . isNotTimeoutThread $ exception
-  guard . isNotConnectionClosedByPeer $ exception
   let env = sentryEnv vvaConfig
   sentryService <-
     initRaven

govtool/backend/src/VVA/Metadata.hs

@@ -4,7 +4,7 @@
 
 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
 
@@ -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)
@@ -40,23 +40,37 @@ validateMetadata
     -> m (Either Text 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 $ Right ""
+      else do
+        metadataHost <- getMetadataValidationHost
+        metadataPort <- getMetadataValidationPort
+
+        -- Configure the HTTP manager with a custom timeout
+        -- due to timeout manager errors
+        let timeout =  responseTimeoutMicro 5000000
+        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) -> return $ Left (pack $ "Failed to parse request: " ++ show e)
+            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) -> return $ Left (pack $ "Failed to make HTTP request: " ++ show e)
+                    Right response -> case decode (responseBody response) of
+                        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) =>