From 862b025fdb5ec45bc47d7f07df60305e850f1ff4 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Sep 2023 11:04:04 +0800 Subject: [PATCH 1/7] Make curl fail on HTTP code >=400 --- app/Foliage/RemoteAsset.hs | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/app/Foliage/RemoteAsset.hs b/app/Foliage/RemoteAsset.hs index f054256..e5498fb 100644 --- a/app/Foliage/RemoteAsset.hs +++ b/app/Foliage/RemoteAsset.hs @@ -53,7 +53,33 @@ addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run withTempFile $ \fp -> traced "curl" $ do BS.writeFile fp oldETag createDirectoryIfMissing True (takeDirectory path) - cmd_ Shell ["curl", "--silent", "--location", "--etag-compare", fp, "--etag-save", fp, "--output", path, show uri] + 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 instead of stdout. + "--output", + path, + -- URL to fetch + show uri + ] BS.readFile fp let changed = if newETag == oldETag then ChangedRecomputeSame else ChangedRecomputeDiff From e34511eb8868f91b4371d3c2fe6aa316f57d7aab Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Sep 2023 11:48:13 +0800 Subject: [PATCH 2/7] Handle curl failure --- app/Foliage/RemoteAsset.hs | 90 +++++++++++++++++++++++++------------- 1 file changed, 59 insertions(+), 31 deletions(-) diff --git a/app/Foliage/RemoteAsset.hs b/app/Foliage/RemoteAsset.hs index e5498fb..31fd782 100644 --- a/app/Foliage/RemoteAsset.hs +++ b/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 - 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 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 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) From ba4fafea117e131c928b18c1b65e42f1411bd7df Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Sep 2023 10:34:05 +0800 Subject: [PATCH 3/7] Update flake config --- flake.nix | 4 ---- 1 file changed, 4 deletions(-) diff --git a/flake.nix b/flake.nix index 4117584..4119729 100644 --- a/flake.nix +++ b/flake.nix @@ -72,13 +72,9 @@ nixConfig = { extra-substituters = [ "https://cache.iog.io" - "https://foliage.cachix.org" - "https://cache.zw3rk.com" ]; extra-trusted-public-keys = [ "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" - "foliage.cachix.org-1:kAFyYLnk8JcRURWReWZCatM9v3Rk24F5wNMpEj14Q/g=" - "loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk=" ]; }; } From 10f13b7cebe59cd16ce8e098e5d7d1c1cfd12ad2 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Sep 2023 12:02:13 +0800 Subject: [PATCH 4/7] Improve some instances of Show --- app/Foliage/PrepareSource.hs | 9 ++++++++- app/Foliage/RemoteAsset.hs | 5 ++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/app/Foliage/PrepareSource.hs b/app/Foliage/PrepareSource.hs index 34443a6..f7a3e5f 100644 --- a/app/Foliage/PrepareSource.hs +++ b/app/Foliage/PrepareSource.hs @@ -23,9 +23,16 @@ import System.Directory qualified as IO import System.FilePath ((<.>), ()) data PrepareSourceRule = PrepareSourceRule PackageId PackageVersionSpec - deriving (Show, Eq, Generic) + deriving (Eq, Generic) deriving (Hashable, Binary, NFData) +instance Show PrepareSourceRule where + show (PrepareSourceRule pkgId pkgSpec) = + "prepareSource " + ++ prettyShow pkgId + ++ " " + ++ show pkgSpec + type instance RuleResult PrepareSourceRule = FilePath prepareSource :: PackageId -> PackageVersionSpec -> Action FilePath diff --git a/app/Foliage/RemoteAsset.hs b/app/Foliage/RemoteAsset.hs index 31fd782..5ac3256 100644 --- a/app/Foliage/RemoteAsset.hs +++ b/app/Foliage/RemoteAsset.hs @@ -25,9 +25,12 @@ import System.Directory (createDirectoryIfMissing) import System.Exit (ExitCode (..)) newtype RemoteAsset = RemoteAsset URI - deriving (Show, Eq) + deriving (Eq) deriving (Hashable, Binary, NFData) via URI +instance Show RemoteAsset where + show (RemoteAsset uri) = "fetchRemoteAsset " ++ show uri + type instance RuleResult RemoteAsset = FilePath fetchRemoteAsset :: URI -> Action FilePath From 4f6b4196bebc78f8f4671e241d44886cd7818432 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Sep 2023 12:30:37 +0800 Subject: [PATCH 5/7] Bump workflows/nix.yml a bit --- .github/workflows/nix.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml index f84d069..a66fd97 100644 --- a/.github/workflows/nix.yml +++ b/.github/workflows/nix.yml @@ -12,18 +12,18 @@ jobs: - ubuntu-latest steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - - uses: cachix/install-nix-action@v20 + - name: Install Nix + uses: DeterminateSystems/nix-installer-action@v4 with: - extra_nix_config: | - access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} + github-token: ${{ secrets.GITHUB_TOKEN }} + + - uses: DeterminateSystems/magic-nix-cache-action@v2 - uses: cachix/cachix-action@v12 with: name: foliage authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - - uses: DeterminateSystems/magic-nix-cache-action@v2 - - run: nix build --accept-flake-config From 9f96dfb7ec36451faa8e63416997ca541921ebc0 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Sep 2023 13:31:05 +0800 Subject: [PATCH 6/7] Retry few times if curl fails --- app/Foliage/RemoteAsset.hs | 100 ++++++++++++++++++++----------------- 1 file changed, 53 insertions(+), 47 deletions(-) diff --git a/app/Foliage/RemoteAsset.hs b/app/Foliage/RemoteAsset.hs index 5ac3256..065bc26 100644 --- a/app/Foliage/RemoteAsset.hs +++ b/app/Foliage/RemoteAsset.hs @@ -58,58 +58,64 @@ addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run newETag <- 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 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 + liftIO $ BS.writeFile etagFile oldETag + actionRetry 5 $ runCurl uri path etagFile let changed = if newETag == oldETag then ChangedRecomputeSame else ChangedRecomputeDiff return $ RunResult {runChanged = changed, runStore = newETag, runValue = path} +runCurl :: URI -> String -> String -> Action ETag +runCurl uri path etagFile = do + (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 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 + +type ETag = BS.ByteString + -- Add what you need. See https://everything.curl.dev/usingcurl/verbose/writeout. newtype CurlWriteOut = CurlWriteOut {errormsg :: String} From b3e8d6fee1156ff322a14d95482290c2c51c9ca6 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Sep 2023 16:15:34 +0800 Subject: [PATCH 7/7] Disable aarch64-linux because Hydra --- flake.nix | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/flake.nix b/flake.nix index 4119729..f9e9c77 100644 --- a/flake.nix +++ b/flake.nix @@ -11,8 +11,17 @@ flake-utils.follows = "haskell-nix/flake-utils"; }; - outputs = { self, nixpkgs, flake-utils, haskell-nix, ... }: - flake-utils.lib.eachDefaultSystem (system: + outputs = { nixpkgs, flake-utils, haskell-nix, ... }: + let + systems = [ + "x86_64-linux" + "x86_64-darwin" + # TODO switch back on when ci.iog.io has builders for aarch64-linux + # "aarch64-linux" + "aarch64-darwin" + ]; + in + flake-utils.lib.eachSystem systems (system: let pkgs = import nixpkgs { inherit system; @@ -39,9 +48,10 @@ # Wrap the foliage executable with the needed dependencies in PATH. # See #71. wrapExe = drv: - pkgs.runCommand "foliage" { - nativeBuildInputs = [ pkgs.makeWrapper ]; - } '' + pkgs.runCommand "foliage" + { + nativeBuildInputs = [ pkgs.makeWrapper ]; + } '' mkdir -p $out/bin makeWrapper ${drv}/bin/foliage $out/bin/foliage \ --prefix PATH : ${with pkgs; lib.makeBinPath [ curl patch ]}:$out/bin