mirror of
https://github.com/input-output-hk/foliage.git
synced 2024-07-14 23:30:24 +03:00
Handle curl failure
This commit is contained in:
parent
31d2455f44
commit
637b266700
@ -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
|
||||
BS.writeFile fp oldETag
|
||||
createDirectoryIfMissing True (takeDirectory path)
|
||||
cmd_
|
||||
Shell
|
||||
[ "curl",
|
||||
-- Silent or quiet mode. Do not show progress meter or error messages. Makes Curl mute.
|
||||
"--silent",
|
||||
-- Fail fast with no output at all on server errors.
|
||||
"--fail",
|
||||
-- If the server reports that the requested page has moved to a different location this
|
||||
-- option will make curl redo the request on the new place.
|
||||
-- NOTE: This is needed because github always replies with a redirect
|
||||
"--location",
|
||||
-- This option makes a conditional HTTP request for the specific ETag read from the
|
||||
-- given file by sending a custom If-None-Match header using the stored ETag.
|
||||
-- For correct results, make sure that the specified file contains only a single line
|
||||
-- with the desired ETag. An empty file is parsed as an empty ETag.
|
||||
"--etag-compare",
|
||||
fp,
|
||||
-- This option saves an HTTP ETag to the specified file. If no ETag is sent by the server,
|
||||
-- an empty file is created.
|
||||
"--etag-save",
|
||||
fp,
|
||||
-- Write output to <file> instead of stdout.
|
||||
"--output",
|
||||
path,
|
||||
-- URL to fetch
|
||||
show uri
|
||||
]
|
||||
BS.readFile fp
|
||||
withTempFile $ \etagFile -> do
|
||||
liftIO $ BS.writeFile etagFile oldETag
|
||||
liftIO $ createDirectoryIfMissing True (takeDirectory path)
|
||||
(Exit exitCode, Stdout out) <-
|
||||
traced "curl" $
|
||||
cmd
|
||||
Shell
|
||||
[ "curl",
|
||||
-- Silent or quiet mode. Do not show progress meter or error messages. Makes Curl mute.
|
||||
"--silent",
|
||||
-- Fail fast with no output at all on server errors.
|
||||
"--fail",
|
||||
-- If the server reports that the requested page has moved to a different location this
|
||||
-- option will make curl redo the request on the new place.
|
||||
-- NOTE: This is needed because github always replies with a redirect
|
||||
"--location",
|
||||
-- This option makes a conditional HTTP request for the specific ETag read from the
|
||||
-- given file by sending a custom If-None-Match header using the stored ETag.
|
||||
-- For correct results, make sure that the specified file contains only a single line
|
||||
-- with the desired ETag. An empty file is parsed as an empty ETag.
|
||||
"--etag-compare",
|
||||
etagFile,
|
||||
-- This option saves an HTTP ETag to the specified file. If no ETag is sent by the server,
|
||||
-- an empty file is created.
|
||||
"--etag-save",
|
||||
etagFile,
|
||||
-- Write output to <file> instead of stdout.
|
||||
"--output",
|
||||
path,
|
||||
"--write-out",
|
||||
"%{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)
|
||||
|
Loading…
Reference in New Issue
Block a user