Handle curl failure

app/Foliage/RemoteAsset.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -8,6 +9,7 @@ module Foliage.RemoteAsset
 where
 
 import Control.Monad
+import Data.Aeson qualified as Aeson
 import Data.ByteString qualified as BS
 import Data.Char (isAlpha)
 import Data.List (dropWhileEnd)
@@ -16,9 +18,11 @@ import Development.Shake
 import Development.Shake.Classes
 import Development.Shake.FilePath
 import Development.Shake.Rule
+import GHC.Generics (Generic)
 import Network.URI (URI (..), URIAuth (..), pathSegments)
 import Network.URI.Orphans ()
 import System.Directory (createDirectoryIfMissing)
+import System.Exit (ExitCode (..))
 
 newtype RemoteAsset = RemoteAsset URI
   deriving (Show, Eq)
@@ -50,37 +54,61 @@ addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run
       let oldETag = fromMaybe BS.empty old
 
       newETag <-
-        withTempFile $ \fp -> traced "curl" $ do
+        withTempFile $ \etagFile -> do
-          BS.writeFile fp oldETag
+          liftIO $ BS.writeFile etagFile oldETag
-          createDirectoryIfMissing True (takeDirectory path)
+          liftIO $ createDirectoryIfMissing True (takeDirectory path)
-          cmd_
+          (Exit exitCode, Stdout out) <-
-            Shell
+            traced "curl" $
-            [ "curl",
+              cmd
-              -- Silent or quiet mode. Do not show progress meter or error messages. Makes Curl mute.
+                Shell
-              "--silent",
+                [ "curl",
-              -- Fail fast with no output at all on server errors.
+                  -- Silent or quiet mode. Do not show progress meter or error messages. Makes Curl mute.
-              "--fail",
+                  "--silent",
-              -- If the server reports that the requested page has moved to a different location this
+                  -- Fail fast with no output at all on server errors.
-              -- option will make curl redo the request on the new place.
+                  "--fail",
-              -- NOTE: This is needed because github always replies with a redirect
+                  -- If the server reports that the requested page has moved to a different location this
-              "--location",
+                  -- option will make curl redo the request on the new place.
-              -- This  option  makes  a conditional HTTP request for the specific ETag read from the
+                  -- NOTE: This is needed because github always replies with a redirect
-              -- given file by sending a custom If-None-Match header using the stored ETag.
+                  "--location",
-              -- For correct results, make sure that the specified file contains only a single line
+                  -- This  option  makes  a conditional HTTP request for the specific ETag read from the
-              -- with the desired ETag. An empty file is parsed as an empty ETag.
+                  -- given file by sending a custom If-None-Match header using the stored ETag.
-              "--etag-compare",
+                  -- For correct results, make sure that the specified file contains only a single line
-              fp,
+                  -- with the desired ETag. An empty file is parsed as an empty ETag.
-              -- This option saves an HTTP ETag to the specified file. If no ETag is sent by the server,
+                  "--etag-compare",
-              -- an empty file is created.
+                  etagFile,
-              "--etag-save",
+                  -- This option saves an HTTP ETag to the specified file. If no ETag is sent by the server,
-              fp,
+                  -- an empty file is created.
-              -- Write output to <file> instead of stdout.
+                  "--etag-save",
-              "--output",
+                  etagFile,
-              path,
+                  -- Write output to <file> instead of stdout.
-              -- URL to fetch
+                  "--output",
-              show uri
+                  path,
-            ]
+                  "--write-out",
-          BS.readFile fp
+                  "%{json}",
+                  -- URL to fetch
+                  show uri
+                ]
+          case exitCode of
+            ExitSuccess -> liftIO $ BS.readFile etagFile
+            ExitFailure c -> do
+              -- We show the curl exit code only if we cannot parse curl's write-out.
+              -- If we can parse it, we can craft a better error message.
+              case Aeson.eitherDecode out :: Either String CurlWriteOut of
+                Left err ->
+                  error $
+                    unlines
+                      [ "curl failed with return code " ++ show c ++ " while fetching " ++ show uri,
+                        "Error while reading curl diagnostic: " ++ err
+                      ]
+                -- We can consider displaying different messages based on some fields (e.g. response_code)
+                Right CurlWriteOut {errormsg} ->
+                  error errormsg
 
       let changed = if newETag == oldETag then ChangedRecomputeSame else ChangedRecomputeDiff
       return $ RunResult {runChanged = changed, runStore = newETag, runValue = path}
+
+-- Add what you need. See https://everything.curl.dev/usingcurl/verbose/writeout.
+newtype CurlWriteOut = CurlWriteOut
+  {errormsg :: String}
+  deriving (Show, Generic)
+  deriving anyclass (Aeson.FromJSON)