Catch all synchronous exceptions when making network requests. (#1038)

* Catch all synchronous exceptions when making network requests.

* Wrap all of getLatestVersion.

* wrapErr wraps sync exceptions as well.

* Pass through exit codes.

daml-assistant/exe/DAML/Assistant.hs

@@ -82,12 +82,12 @@ main = displayErrors $ do
         Builtin (Install options) -> wrapErr "Installing the SDK." $ do
             install options envDamlPath envProjectPath
 
-        Builtin (Exec cmd args) ->
+        Builtin (Exec cmd args) -> do
             wrapErr "Running executable in daml environment." $ do
                 path <- fromMaybe cmd <$> findExecutable cmd
                 exitWith =<< dispatch env path args
 
-        Dispatch SdkCommandInfo{..} cmdArgs ->
+        Dispatch SdkCommandInfo{..} cmdArgs -> do
             wrapErr ("Running " <> unwrapSdkCommandName sdkCommandName <> " command.") $ do
                 sdkPath <- required "Could not determine SDK path." envSdkPath
                 let path = unwrapSdkPath sdkPath </> unwrapSdkCommandPath sdkCommandPath

daml-assistant/src/DAML/Assistant/Install.hs

@@ -318,8 +318,8 @@ extractAndInstall env source =
 httpInstall :: InstallEnv -> InstallURL -> IO ()
 httpInstall env@InstallEnv{..} (InstallURL url) = do
     unlessQuiet env $ output "Downloading SDK release."
-    request <- requiredHttps "Failed to parse HTTPS request." $ parseRequest ("GET " <> unpack url)
-    requiredHttps "Failed to download SDK release." $ withResponse request $ \response -> do
+    request <- requiredAny "Failed to parse HTTPS request." $ parseRequest ("GET " <> unpack url)
+    requiredAny "Failed to download SDK release." $ withResponse request $ \response -> do
         when (getResponseStatusCode response /= 200) $
             throwIO . assistantErrorBecause "Failed to download release."
                     . pack . show $ getResponseStatus response

daml-assistant/src/DAML/Assistant/Install/Github.hs

@@ -57,12 +57,10 @@ tagToVersion (Tag t) =
 -- So we take that URL to get the tag, and from there the version of
 -- the latest stable release.
 getLatestVersion :: IO SdkVersion
-getLatestVersion = do
-
-    manager <- newTlsManager -- TODO: share a single manager throughout the daml install process.
+getLatestVersion = requiredAny "Failed to get latest SDK version from Github." $ do
+    manager <- newTlsManager
     request <- parseRequest "HEAD https://github.com/digital-asset/daml/releases/latest"
-    finalRequest <- requiredHttps "Failed to get latest SDK version from GitHub." $
-        withResponseHistory request manager $ pure . hrFinalRequest
+    finalRequest <- withResponseHistory request manager $ pure . hrFinalRequest
 
     let pathText = T.decodeUtf8 (path finalRequest)
         (parent, tag) = T.breakOnEnd "/" pathText

daml-assistant/src/DAML/Assistant/Util.hs

@@ -9,12 +9,11 @@ module DAML.Assistant.Util
 
 import DAML.Assistant.Types
 import DAML.Project.Util
+import System.Exit
 import System.FilePath
 import Control.Exception.Safe
 import Control.Applicative
 import Control.Monad.Extra hiding (fromMaybeM)
-import Network.HTTP.Client
-import Network.TLS
 
 -- | Calculate the ascendants of a path, i.e. the successive parents of a path,
 -- including the path itself, all the way to its root. For example:
@@ -38,19 +37,21 @@ ascendants p =
 throwErr :: Text -> IO a
 throwErr msg = throwIO (assistantError msg)
 
--- | Handle IOExceptions by wrapping them in an AssistantError, and
+-- | Handle synchronous exceptions by wrapping them in an AssistantError,
 -- add context to any assistant errors that are missing context.
-wrapErr :: Text -> (IO a -> IO a)
-wrapErr ctx = handleIO (throwIO . wrapIOException)
-            . handle   (throwIO . addErrorContext)
-
+wrapErr :: Text -> IO a -> IO a
+wrapErr ctx m = m `catches`
+    [ Handler $ throwIO @IO @ExitCode
+    , Handler $ throwIO . addErrorContext
+    , Handler $ throwIO . wrapException
+    ]
     where
-        wrapIOException :: IOException -> AssistantError
-        wrapIOException ioErr =
+        wrapException :: SomeException -> AssistantError
+        wrapException err =
             AssistantError
                 { errContext  = Just ctx
                 , errMessage  = Nothing
-                , errInternal = Just (pack (show ioErr))
+                , errInternal = Just (pack (show err))
                 }
 
         addErrorContext :: AssistantError -> AssistantError
@@ -77,19 +78,18 @@ requiredE msg = fromRightM (throwIO . assistantErrorBecause msg . pack . display
 
 -- | Catch IOExceptions and re-throw them as AssistantError with a helpful message.
 requiredIO :: Text -> IO t -> IO t
-requiredIO msg m = requiredE msg =<< tryIO m
+requiredIO msg m = catchIO m (rethrow msg)
 
--- | Same as requiredIO but also catches and re-throws TLSException and HttpExceptions.
-requiredHttps :: Text -> IO a -> IO a
-requiredHttps msg m = m `catches`
-    [ Handler $ \ (e :: IOException) -> rethrow e
-    , Handler $ \ (e :: HttpException) -> rethrow e
-    , Handler $ \ (e :: TLSException) -> rethrow e
+-- | Same as requiredIO but also catches and re-throws any synchronous exception.
+requiredAny :: Text -> IO a -> IO a
+requiredAny msg m = m `catches`
+    [ Handler $ \ (e :: AssistantError) -> throwIO e
+    , Handler $ \ (e :: SomeException) -> rethrow msg e
     ]
-    where
-        rethrow :: Exception e => e -> IO a
-        rethrow = throwIO . assistantErrorBecause msg . pack . displayException
 
+-- | Rethrow an exception with helpful message.
+rethrow :: Exception e => Text -> e -> IO a
+rethrow msg = throwIO . assistantErrorBecause msg . pack . displayException
 
 -- | Like 'whenMaybeM' but only returns a 'Just' value if the test is false.
 unlessMaybeM :: Monad m => m Bool -> m t -> m (Maybe t)