mirror of
https://github.com/input-output-hk/foliage.git
synced 2024-08-17 16:00:38 +03:00
Handle curl failure
This commit is contained in:
parent
31d2455f44
commit
637b266700
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DerivingVia #-}
|
{-# LANGUAGE DerivingVia #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
@ -8,6 +9,7 @@ module Foliage.RemoteAsset
|
|||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Data.Aeson qualified as Aeson
|
||||||
import Data.ByteString qualified as BS
|
import Data.ByteString qualified as BS
|
||||||
import Data.Char (isAlpha)
|
import Data.Char (isAlpha)
|
||||||
import Data.List (dropWhileEnd)
|
import Data.List (dropWhileEnd)
|
||||||
@ -16,9 +18,11 @@ import Development.Shake
|
|||||||
import Development.Shake.Classes
|
import Development.Shake.Classes
|
||||||
import Development.Shake.FilePath
|
import Development.Shake.FilePath
|
||||||
import Development.Shake.Rule
|
import Development.Shake.Rule
|
||||||
|
import GHC.Generics (Generic)
|
||||||
import Network.URI (URI (..), URIAuth (..), pathSegments)
|
import Network.URI (URI (..), URIAuth (..), pathSegments)
|
||||||
import Network.URI.Orphans ()
|
import Network.URI.Orphans ()
|
||||||
import System.Directory (createDirectoryIfMissing)
|
import System.Directory (createDirectoryIfMissing)
|
||||||
|
import System.Exit (ExitCode (..))
|
||||||
|
|
||||||
newtype RemoteAsset = RemoteAsset URI
|
newtype RemoteAsset = RemoteAsset URI
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
@ -50,37 +54,61 @@ addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run
|
|||||||
let oldETag = fromMaybe BS.empty old
|
let oldETag = fromMaybe BS.empty old
|
||||||
|
|
||||||
newETag <-
|
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
|
let changed = if newETag == oldETag then ChangedRecomputeSame else ChangedRecomputeDiff
|
||||||
return $ RunResult {runChanged = changed, runStore = newETag, runValue = path}
|
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