Implement 'ghcup test ghc' based on the bindist testsuite

Merge branch 'HF-errors'
Merge remote-tracking branch 'origin/pr/739'
2023-01-12 12:58:10 +08:00 · 2023-01-05 21:39:23 +08:00 · 2023-01-05 21:32:07 +08:00 · 2023-01-05 07:32:51 +08:00 · 2023-01-04 21:08:10 +08:00 · 2023-01-04 18:51:40 +08:00
39 changed files with 9674 additions and 5617 deletions
--- a/.cirrus.yml
+++ b/.cirrus.yml
@@ -17,6 +17,8 @@ task:
    S3_HOST: ENCRYPTED[ce961780a33159f7d1d8046956b5ac6ebc3bfc8149428e5f538576cda51d9f3d0c35b79cdd1e325793639ff6e31f889d]
  install_script: pkg install -y ghc hs-cabal-install git bash misc/compat10x misc/compat11x misc/compat12x gmake
  script:
+    - tzsetup Etc/GMT
+    - adjkerntz -a
    - bash .github/scripts/build.sh
    - bash .github/scripts/test.sh
  binaries_artifacts:
--- a/.github/scripts/common.sh
+++ b/.github/scripts/common.sh
@@ -87,39 +87,29 @@ download_cabal_cache() {
 	cd /tmp
 	case "${RUNNER_OS}" in
 		"Linux")
-			case "${DISTRO}" in
-				"Alpine")
-					case "${ARCH}" in
-						"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/i386-linux-alpine-cabal-cache-1.0.5.1
-							;;
-						"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-linux-alpine-cabal-cache-1.0.5.1
-							;;
-					esac
+			case "${ARCH}" in
+				"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/i386-linux-cabal-cache
 					;;
-				*)
-					case "${ARCH}" in
-						"64") url=https://github.com/haskell-works/cabal-cache/releases/download/v1.0.5.1/cabal-cache-x86_64-linux.gz
-							;;
-						"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/aarch64-linux-cabal-cache-1.0.5.1
-							;;
-						"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/armv7-linux-cabal-cache-1.0.5.1
-							;;
-					esac
+				"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-linux-cabal-cache
+					;;
+				"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/aarch64-linux-cabal-cache
+					;;
+				"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/armv7-linux-cabal-cache
 					;;
 			esac
 			;;
 		"FreeBSD")
-			url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-freebsd-cabal-cache-1.0.5.1
+			url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-portbld-freebsd-cabal-cache
 			;;
 		"Windows")
 			exe=".exe"
-			url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-mingw64-cabal-cache-1.0.5.1.exe
+			url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-mingw64-cabal-cache
 			;;
 		"macOS")
 			case "${ARCH}" in
-				"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/aarch64-apple-darwin-cabal-cache-1.0.5.1
+				"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/aarch64-apple-darwin-cabal-cache
 					;;
-				"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/1.0.5.1/x86_64-apple-darwin-cabal-cache-1.0.5.1
+				"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-apple-darwin-cabal-cache
 					;;
 			esac
 			;;
@@ -134,8 +124,9 @@ download_cabal_cache() {
 				curl -o cabal-cache${exe} -L "${url}"
 				;;
 		esac
-		chmod +x cabal-cache${exe}
-		cp "cabal-cache${exe}" "${dest}${exe}"
+		sha_sum cabal-cache${exe}
+		mv "cabal-cache${exe}" "${dest}${exe}"
+		chmod +x "${dest}${exe}"
 	fi
    )
 }
@@ -160,7 +151,7 @@ install_ghcup() {
 		chmod +x ghcup
 		mv ghcup "$HOME/.local/bin/ghcup"
 	else
-		curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
+		curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 BOOTSTRAP_HASKELL_INSTALL_NO_STACK=yes sh
 	fi
 }

--- a/.github/workflows/release.yaml
+++ b/.github/workflows/release.yaml
@@ -102,7 +102,7 @@ jobs:
      - uses: docker://arm64v8/ubuntu:focal
        name: Cleanup (aarch64 linux)
        with:
-          args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
+          args: "find . -mindepth 1 -maxdepth 1 -exec rm -rf -- {} +"

      - name: git config
        run: |
@@ -272,6 +272,14 @@ jobs:
          DISTRO: ${{ matrix.DISTRO }}
          APT_GET: "sudo apt-get"

+      - if: failure()
+        name: Upload artifact
+        uses: actions/upload-artifact@v3
+        with:
+          name: testfiles
+          path: |
+            ./test/golden/unix/GHCupInfo*json
+
  test-arm:
    name: Test ARM
    needs: "build-arm"
@@ -297,7 +305,7 @@ jobs:
      - uses: docker://arm64v8/ubuntu:focal
        name: Cleanup (aarch64 linux)
        with:
-          args: rm -rf .ghcup/ cabal/ dist-newstyle/ out/
+          args: "find . -mindepth 1 -maxdepth 1 -exec rm -rf -- {} +"

      - name: Checkout code
        uses: actions/checkout@v3
@@ -331,6 +339,14 @@ jobs:
          GHC_VER: ${{ matrix.GHC_VER }}
          DISTRO: Ubuntu

+      - if: failure()
+        name: Upload artifact
+        uses: actions/upload-artifact@v3
+        with:
+          name: testfiles
+          path: |
+            ./test/golden/unix/GHCupInfo*json
+
  test-macwin:
    name: Test Mac/Win
    needs: "build-macwin"
@@ -377,6 +393,22 @@ jobs:
          GHC_VER: ${{ matrix.GHC_VER }}
          DISTRO: ${{ matrix.DISTRO }}
          HOMEBREW_CHANGE_ARCH_TO_ARM: 1
+
+      - if: failure() && runner.os == 'Windows'
+        name: Upload artifact
+        uses: actions/upload-artifact@v3
+        with:
+          name: testfiles
+          path: |
+            ./test/golden/windows/GHCupInfo*json
+
+      - if: failure() && runner.os != 'Windows'
+        name: Upload artifact
+        uses: actions/upload-artifact@v3
+        with:
+          name: testfiles
+          path: |
+            ./test/golden/unix/GHCupInfo*json
  hls:
    name: hls
    needs: build-linux
--- a/app/ghcup/BrickMain.hs
+++ b/app/ghcup/BrickMain.hs
@@ -434,6 +434,7 @@ install' _ (_, ListResult {..}) = do
              , BuildFailed
              , TagNotFound
              , DigestError
+              , ContentLengthError
              , GPGError
              , DownloadFailed
              , DirNotEmpty
@@ -486,7 +487,7 @@ install' _ (_, ListResult {..}) = do
            pure $ Right ()
          VLeft  (V (AlreadyInstalled _ _)) -> pure $ Right ()
          VLeft (V NoUpdate) -> pure $ Right ()
-          VLeft e -> pure $ Left $ prettyShow e <> "\n"
+          VLeft e -> pure $ Left $ prettyHFError e <> "\n"
            <> "Also check the logs in ~/.ghcup/logs"


@@ -523,7 +524,7 @@ set' bs input@(_, ListResult {..}) = do
                      logInfo "Setting now..."
                      set' bs input

-                PromptNo -> pure $ Left (prettyShow e)
+                PromptNo -> pure $ Left (prettyHFError e)
              where
                userPrompt = L.toStrict . B.toLazyText . B.fromString $
                  "This Version of "
@@ -531,7 +532,7 @@ set' bs input@(_, ListResult {..}) = do
                  <> " you are trying to set is not installed.\n"
                  <> "Would you like to install it first? [Y/N]: "

-            _ -> pure $ Left (prettyShow e)
+            _ -> pure $ Left (prettyHFError e)



@@ -559,7 +560,7 @@ del' _ (_, ListResult {..}) = do
            forM_ (_viPostRemove =<< vi) $ \msg ->
              logInfo msg
            pure $ Right ()
-          VLeft  e -> pure $ Left (prettyShow e)
+          VLeft  e -> pure $ Left (prettyHFError e)


 changelog' :: (MonadReader AppState m, MonadIO m)
@@ -579,7 +580,7 @@ changelog' _ (_, ListResult {..}) = do
            Windows -> "start"
      exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
        Right _ -> pure $ Right ()
-        Left  e -> pure $ Left $ prettyShow e
+        Left  e -> pure $ Left $ prettyHFError e


 settings' :: IORef AppState
@@ -632,12 +633,12 @@ getGHCupInfo = do

  r <-
    flip runReaderT settings
-    . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
+    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
    $ liftE getDownloadsF

  case r of
    VRight a -> pure $ Right a
-    VLeft  e -> pure $ Left (prettyShow e)
+    VLeft  e -> pure $ Left (prettyHFError e)


 getAppData :: Maybe GHCupInfo
--- a/app/ghcup/GHCup/OptParse.hs
+++ b/app/ghcup/GHCup/OptParse.hs
@@ -8,6 +8,7 @@
 module GHCup.OptParse (
    module GHCup.OptParse.Common
  , module GHCup.OptParse.Install
+  , module GHCup.OptParse.Test
  , module GHCup.OptParse.Set
  , module GHCup.OptParse.UnSet
  , module GHCup.OptParse.Rm
@@ -31,6 +32,7 @@ module GHCup.OptParse (

 import           GHCup.OptParse.Common
 import           GHCup.OptParse.Install
+import           GHCup.OptParse.Test
 import           GHCup.OptParse.Set
 import           GHCup.OptParse.UnSet
 import           GHCup.OptParse.Rm
@@ -87,6 +89,7 @@ data Options = Options

 data Command
  = Install (Either InstallCommand InstallOptions)
+  | Test TestCommand
  | InstallCabalLegacy InstallOptions
  | Set (Either SetCommand SetOptions)
  | UnSet UnsetCommand
@@ -108,6 +111,7 @@ data Command
  | Prefetch PrefetchCommand
  | GC GCOptions
  | Run RunOptions
+  | PrintAppErrors



@@ -204,6 +208,14 @@ com =
                <> footerDoc (Just $ text installToolFooter)
                )
          )
+      <> command
+           "test"
+           (info
+             (Test <$> testParser <**> helper)
+             (  progDesc "Run tests for a tool (if any) [EXPERIMENTAL!]"
+             <> footerDoc (Just $ text testFooter)
+             )
+           )
      <> command
           "set"
           (info
@@ -341,3 +353,10 @@ com =
           <> commandGroup "Nuclear Commands:"
           <> hidden
          )
+     <|> subparser
+          (command
+              "print-app-errors"
+               (info (pure PrintAppErrors <**> helper)
+                     (progDesc ""))
+           <> internal
+          )
--- a/app/ghcup/GHCup/OptParse/ChangeLog.hs
+++ b/app/ghcup/GHCup/OptParse/ChangeLog.hs
@@ -12,6 +12,7 @@ module GHCup.OptParse.ChangeLog where


 import           GHCup.Types
+import           GHCup.Errors
 import           GHCup.OptParse.Common
 import           GHCup.Prelude
 import           GHCup.Prelude.Logger
@@ -148,6 +149,6 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
                 Nothing
              >>= \case
                    Right _ -> pure ExitSuccess
-                    Left  e -> logError (T.pack $ prettyShow e)
+                    Left  e -> logError (T.pack $ prettyHFError e)
                      >> pure (ExitFailure 13)
        else liftIO $ putStrLn uri' >> pure ExitSuccess
--- a/app/ghcup/GHCup/OptParse/Compile.hs
+++ b/app/ghcup/GHCup/OptParse/Compile.hs
@@ -40,7 +40,6 @@ import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import           URI.ByteString          hiding ( uriParser )
 import qualified Data.Text                     as T
@@ -420,6 +419,7 @@ hlsCompileOpts =
 type GHCEffects = '[ AlreadyInstalled
                  , BuildFailed
                  , DigestError
+                  , ContentLengthError
                  , GPGError
                  , DownloadFailed
                  , GHCupSetError
@@ -443,6 +443,7 @@ type GHCEffects = '[ AlreadyInstalled
 type HLSEffects = '[ AlreadyInstalled
                  , BuildFailed
                  , DigestError
+                  , ContentLengthError
                  , GPGError
                  , DownloadFailed
                  , GHCupSetError
@@ -544,14 +545,14 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                pure ExitSuccess
              VLeft err@(V (BuildFailed tmpdir _)) -> do
                case keepDirs settings of
-                  Never -> runLogger $ logError $ T.pack $ prettyShow err
-                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
+                  Never -> runLogger $ logError $ T.pack $ prettyHFError err
+                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
                        "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
                        <> T.pack tmpdir <> " for more clues." <> "\n" <>
                        "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                pure $ ExitFailure 9
              VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyShow e
+                runLogger $ logError $ T.pack $ prettyHFError e
                pure $ ExitFailure 9
    (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
      runLogger $ logError "Hadrian cross compile support is not yet implemented!"
@@ -606,12 +607,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
                pure $ ExitFailure 3
              VLeft err@(V (BuildFailed tmpdir _)) -> do
                case keepDirs settings of
-                  Never -> runLogger $ logError $ T.pack $ prettyShow err
-                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
+                  Never -> runLogger $ logError $ T.pack $ prettyHFError err
+                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
                        "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
                        <> T.pack tmpdir <> " for more clues." <> "\n" <>
                        "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                pure $ ExitFailure 9
              VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyShow e
+                runLogger $ logError $ T.pack $ prettyHFError e
                pure $ ExitFailure 9
--- a/app/ghcup/GHCup/OptParse/DInfo.hs
+++ b/app/ghcup/GHCup/OptParse/DInfo.hs
@@ -115,5 +115,5 @@ dinfo runAppState runLogger = do
            liftIO $ putStrLn $ prettyDebugInfo di
            pure ExitSuccess
          VLeft e -> do
-            runLogger $ logError $ T.pack $ prettyShow e
+            runLogger $ logError $ T.pack $ prettyHFError e
            pure $ ExitFailure 8
--- a/app/ghcup/GHCup/OptParse/GC.hs
+++ b/app/ghcup/GHCup/OptParse/GC.hs
@@ -27,7 +27,6 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -139,5 +138,5 @@ gc GCOptions{..} runAppState runLogger = runGC runAppState (do
            VRight _ -> do
                  pure ExitSuccess
            VLeft e -> do
-              runLogger $ logError $ T.pack $ prettyShow e
+              runLogger $ logError $ T.pack $ prettyHFError e
              pure $ ExitFailure 27
--- a/app/ghcup/GHCup/OptParse/Install.hs
+++ b/app/ghcup/GHCup/OptParse/Install.hs
@@ -38,7 +38,6 @@ import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           URI.ByteString          hiding ( uriParser )

 import qualified Data.Text                     as T
@@ -243,6 +242,7 @@ type InstallEffects = '[ AlreadyInstalled
                       , BuildFailed
                       , TagNotFound
                       , DigestError
+                       , ContentLengthError
                       , GPGError
                       , DownloadFailed
                       , TarDirDoesNotExist
@@ -271,6 +271,7 @@ type InstallGHCEffects = '[ AlreadyInstalled
                          , BuildFailed
                          , CopyError
                          , DigestError
+                          , ContentLengthError
                          , DirNotEmpty
                          , DownloadFailed
                          , FileAlreadyExistsError
@@ -332,7 +333,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
         runInstGHC s'{ settings = settings {noVerify = True}} $ do
           (v, vi) <- liftE $ fromVersion instVer GHC
           liftE $ runBothE' (installGHCBindist
-                       (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
+                       (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing)
                       (_tvVersion v)
                       (maybe GHCupInternal IsolateDir isolateDir)
                       forceInstall
@@ -349,10 +350,10 @@ install installCommand settings getAppState' runLogger = case installCommand of
                pure ExitSuccess

              VLeft e@(V (AlreadyInstalled _ _)) -> do
-                runLogger $ logWarn $ T.pack $ prettyShow e
+                runLogger $ logWarn $ T.pack $ prettyHFError e
                pure ExitSuccess
              VLeft e@(V (AlreadyInstalled _ _)) -> do
-                runLogger $ logWarn $ T.pack $ prettyShow e
+                runLogger $ logWarn $ T.pack $ prettyHFError e
                pure ExitSuccess

              VLeft (V (DirNotEmpty fp)) -> do
@@ -366,22 +367,22 @@ install installCommand settings getAppState' runLogger = case installCommand of

              VLeft err@(V (BuildFailed tmpdir _)) -> do
                case keepDirs settings of
-                  Never -> runLogger (logError $ T.pack $ prettyShow err)
-                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
+                  Never -> runLogger (logError $ T.pack $ prettyHFError err)
+                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
                    "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
                    "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                pure $ ExitFailure 3
              VLeft err@(V (BuildFailed tmpdir _)) -> do
                case keepDirs settings of
-                  Never -> runLogger (logError $ T.pack $ prettyShow err)
-                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
+                  Never -> runLogger (logError $ T.pack $ prettyHFError err)
+                  _ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
                    "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
                    "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                pure $ ExitFailure 3

              VLeft e -> do
                runLogger $ do
-                  logError $ T.pack $ prettyShow e
+                  logError $ T.pack $ prettyHFError e
                  logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
                pure $ ExitFailure 3

@@ -402,7 +403,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
         runInstTool s'{ settings = settings { noVerify = True}} $ do
           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
           liftE $ runBothE' (installCabalBindist
-                                      (DownloadInfo uri Nothing "")
+                                      (DownloadInfo uri Nothing "" Nothing)
                                      v
                                      (maybe GHCupInternal IsolateDir isolateDir)
                                      forceInstall
@@ -416,14 +417,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
                runLogger $ logInfo msg
              pure ExitSuccess
            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $ T.pack $ prettyHFError e
              pure ExitSuccess
            VLeft (V (FileAlreadyExistsError fp)) -> do
              runLogger $ logWarn $
                "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
              pure $ ExitFailure 3
            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $ T.pack $ prettyHFError e
              pure ExitSuccess
            VLeft (V (FileAlreadyExistsError fp)) -> do
              runLogger $ logWarn $
@@ -431,7 +432,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
              pure $ ExitFailure 3
            VLeft e -> do
              runLogger $ do
-                logError $ T.pack $ prettyShow e
+                logError $ T.pack $ prettyHFError e
                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
              pure $ ExitFailure 4

@@ -452,7 +453,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
           -- TODO: support legacy
           liftE $ runBothE' (installHLSBindist
-                                      (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
+                                      (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing)
                                      v
                                      (maybe GHCupInternal IsolateDir isolateDir)
                                      forceInstall
@@ -466,14 +467,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
                runLogger $ logInfo msg
              pure ExitSuccess
            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $ T.pack $ prettyHFError e
              pure ExitSuccess
            VLeft (V (FileAlreadyExistsError fp)) -> do
              runLogger $ logWarn $
                "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
              pure $ ExitFailure 3
            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $ T.pack $ prettyHFError e
              pure ExitSuccess
            VLeft (V (FileAlreadyExistsError fp)) -> do
              runLogger $ logWarn $
@@ -481,7 +482,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
              pure $ ExitFailure 3
            VLeft e -> do
              runLogger $ do
-                logError $ T.pack $ prettyShow e
+                logError $ T.pack $ prettyHFError e
                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
              pure $ ExitFailure 4

@@ -501,7 +502,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
          runInstTool s'{ settings = settings { noVerify = True}} $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
            liftE $ runBothE' (installStackBindist
-                                       (DownloadInfo uri Nothing "")
+                                       (DownloadInfo uri Nothing "" Nothing)
                                       v
                                       (maybe GHCupInternal IsolateDir isolateDir)
                                       forceInstall
@@ -515,14 +516,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
                runLogger $ logInfo msg
              pure ExitSuccess
            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $ T.pack $ prettyHFError e
              pure ExitSuccess
            VLeft (V (FileAlreadyExistsError fp)) -> do
              runLogger $ logWarn $
                "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
              pure $ ExitFailure 3
            VLeft e@(V (AlreadyInstalled _ _)) -> do
-              runLogger $ logWarn $ T.pack $ prettyShow e
+              runLogger $ logWarn $ T.pack $ prettyHFError e
              pure ExitSuccess
            VLeft (V (FileAlreadyExistsError fp)) -> do
              runLogger $ logWarn $
@@ -530,6 +531,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
              pure $ ExitFailure 3
            VLeft e -> do
              runLogger $ do
-                logError $ T.pack $ prettyShow e
+                logError $ T.pack $ prettyHFError e
                logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
              pure $ ExitFailure 4
--- a/app/ghcup/GHCup/OptParse/Nuke.hs
+++ b/app/ghcup/GHCup/OptParse/Nuke.hs
@@ -26,7 +26,6 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -95,5 +94,5 @@ nuke appState runLogger = do
                      pure ExitSuccess

                VLeft e -> do
-                  runLogger $ logError $ T.pack $ prettyShow e
+                  runLogger $ logError $ T.pack $ prettyHFError e
                  pure $ ExitFailure 15
--- a/app/ghcup/GHCup/OptParse/Prefetch.hs
+++ b/app/ghcup/GHCup/OptParse/Prefetch.hs
@@ -30,7 +30,6 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -153,6 +152,7 @@ type PrefetchEffects = '[ TagNotFound
                        , NoToolVersionSet
                        , NoDownload
                        , DigestError
+                        , ContentLengthError
                        , GPGError
                        , DownloadFailed
                        , JSONError
@@ -215,5 +215,5 @@ prefetch prefetchCommand runAppState runLogger =
                VRight _ -> do
                      pure ExitSuccess
                VLeft e -> do
-                  runLogger $ logError $ T.pack $ prettyShow e
+                  runLogger $ logError $ T.pack $ prettyHFError e
                  pure $ ExitFailure 15
--- a/app/ghcup/GHCup/OptParse/Rm.hs
+++ b/app/ghcup/GHCup/OptParse/Rm.hs
@@ -34,7 +34,6 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -179,7 +178,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
              postRmLog vi
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyShow e
+              runLogger $ logError $ T.pack $ prettyHFError e
              pure $ ExitFailure 7

  rmCabal' tv =
@@ -194,7 +193,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
              postRmLog vi
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyShow e
+              runLogger $ logError $ T.pack $ prettyHFError e
              pure $ ExitFailure 15

  rmHLS' tv =
@@ -209,7 +208,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
              postRmLog vi
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyShow e
+              runLogger $ logError $ T.pack $ prettyHFError e
              pure $ ExitFailure 15

  rmStack' tv =
@@ -224,7 +223,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
              postRmLog vi
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyShow e
+              runLogger $ logError $ T.pack $ prettyHFError e
              pure $ ExitFailure 15

  postRmLog vi =
--- a/app/ghcup/GHCup/OptParse/Run.hs
+++ b/app/ghcup/GHCup/OptParse/Run.hs
@@ -40,7 +40,6 @@ import           Prelude                 hiding ( appendFile )
 import           System.FilePath
 import           System.Environment
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T
@@ -177,6 +176,7 @@ type RunEffects = '[ AlreadyInstalled
                   , BuildFailed
                   , TagNotFound
                   , DigestError
+                   , ContentLengthError
                   , GPGError
                   , DownloadFailed
                   , TarDirDoesNotExist
@@ -254,7 +254,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
               liftIO $ putStr tmp
               pure ExitSuccess
             (cmd:args) -> do
-               newEnv <- liftIO $ addToPath tmp
+               newEnv <- liftIO $ addToPath tmp runAppendPATH
 #ifndef IS_WINDOWS
               void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
               pure ExitSuccess
@@ -265,11 +265,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
               case r' of
                 VRight _ -> pure ExitSuccess
                 VLeft e -> do
-                   runLogger $ logError $ T.pack $ prettyShow e
+                   runLogger $ logError $ T.pack $ prettyHFError e
                   pure $ ExitFailure 28
 #endif
         VLeft e -> do
-           runLogger $ logError $ T.pack $ prettyShow e
+           runLogger $ logError $ T.pack $ prettyHFError e
           pure $ ExitFailure 27

  where
@@ -343,6 +343,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                              , DownloadFailed
                              , DirNotEmpty
                              , DigestError
+                              , ContentLengthError
                              , BuildFailed
                              , ArchiveResult
                              , AlreadyInstalled
@@ -440,17 +441,6 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
            liftE $ setHLS v SetHLS_XYZ (Just tmp)
            liftE $ setHLS v SetHLSOnly (Just tmp)

-   addToPath path = do
-    cEnv <- Map.fromList <$> getEnvironment
-    let paths          = ["PATH", "Path"]
-        curPaths       = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
-        newPath        = intercalate [searchPathSeparator] (if runAppendPATH then (curPaths ++ [path]) else (path : curPaths))
-        envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
-        pathVar        = if isWindows then "Path" else "PATH"
-        envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
-    liftIO $ setEnv pathVar newPath
-    return envWithNewPath
-
   createTmpDir :: ( MonadUnliftIO m
                   , MonadCatch m
                   , MonadThrow m
--- a/app/ghcup/GHCup/OptParse/Set.hs
+++ b/app/ghcup/GHCup/OptParse/Set.hs
@@ -35,7 +35,6 @@ import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Text                     as T
 import Data.Bifunctor (second)
@@ -286,7 +285,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
                    "GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
              pure ExitSuccess
            VLeft e -> do
-              runLogger $ logError $ T.pack $ prettyShow e
+              runLogger $ logError $ T.pack $ prettyHFError e
              pure $ ExitFailure 5


@@ -307,7 +306,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
                    "Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version"
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyShow e
+              runLogger $ logError $ T.pack $ prettyHFError e
              pure $ ExitFailure 14

  setHLS' :: SetOptions
@@ -327,7 +326,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
                    "HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version"
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyShow e
+              runLogger $ logError $ T.pack $ prettyHFError e
              pure $ ExitFailure 14


@@ -348,5 +347,5 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
                    "Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version"
              pure ExitSuccess
            VLeft  e -> do
-              runLogger $ logError $ T.pack $ prettyShow e
+              runLogger $ logError $ T.pack $ prettyHFError e
              pure $ ExitFailure 14
--- a/app/ghcup/GHCup/OptParse/Test.hs
+++ b/app/ghcup/GHCup/OptParse/Test.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE TypeOperators     #-}
+
+module GHCup.OptParse.Test where
+
+
+
+
+import           GHCup.OptParse.Common
+
+import           GHCup
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils.Dirs
+import           GHCup.Prelude.Logger
+import           GHCup.Prelude.String.QQ
+
+import           Codec.Archive
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Functor
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           Options.Applicative.Help.Pretty ( text )
+import           Prelude                 hiding ( appendFile )
+import           System.Exit
+import           URI.ByteString          hiding ( uriParser )
+
+import qualified Data.Text                     as T
+
+
+
+
+    ----------------
+    --[ Commands ]--
+    ----------------
+
+
+data TestCommand = TestGHC TestOptions
+
+
+
+
+    ---------------
+    --[ Options ]--
+    ---------------
+
+
+data TestOptions = TestOptions
+  { testVer      :: Maybe ToolVersion
+  , testBindist  :: Maybe URI
+  , addMakeArgs  :: [T.Text]
+  }
+
+
+
+    ---------------
+    --[ Footers ]--
+    ---------------
+
+testFooter :: String
+testFooter = [s|Discussion:
+  Runs test suites from the test bindist.|]
+
+
+
+
+    ---------------
+    --[ Parsers ]--
+    ---------------
+
+testParser :: Parser TestCommand
+testParser =
+  subparser
+      (  command
+          "ghc"
+          (   TestGHC
+          <$> info
+                (testOpts (Just GHC) <**> helper)
+                (  progDesc "Test GHC"
+                <> footerDoc (Just $ text testGHCFooter)
+                )
+          )
+        )
+ where
+  testGHCFooter :: String
+  testGHCFooter = [s|Discussion:
+  Runs the GHC test suite from the test bindist.|]
+
+
+testOpts :: Maybe Tool -> Parser TestOptions
+testOpts tool =
+  (\(u, v) args -> TestOptions v u args)
+    <$> (   (   (,)
+            <$> optional
+                  (option
+                    (eitherReader uriParser)
+                    (short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
+                      "Install the specified version from this bindist"
+                      <> completer (toolDlCompleter (fromMaybe GHC tool))
+                    )
+                  )
+            <*> (Just <$> toolVersionTagArgument Nothing tool)
+            )
+        <|> pure (Nothing, Nothing)
+        )
+    <*> many (argument str (metavar "MAKE_ARGS" <> help "Additional arguments to 'make', prefix with '-- ' (longopts)"))
+
+
+
+
+
+
+
+    ---------------------------
+    --[ Effect interpreters ]--
+    ---------------------------
+
+
+type TestGHCEffects = [ DigestError
+                      , ContentLengthError
+                      , GPGError
+                      , DownloadFailed
+                      , NoDownload
+                      , ArchiveResult
+                      , TarDirDoesNotExist
+                      , UnknownArchive
+                      , TestFailed
+                      , NextVerNotFound
+                      , TagNotFound
+                      , NoToolVersionSet
+                      ]
+
+runTestGHC :: AppState
+           -> Excepts TestGHCEffects (ResourceT (ReaderT AppState IO)) a
+           -> IO (VEither TestGHCEffects a)
+runTestGHC appstate' =
+  flip runReaderT appstate'
+  . runResourceT
+  . runE
+    @TestGHCEffects
+
+
+    -------------------
+    --[ Entrypoints ]--
+    -------------------
+
+
+test :: TestCommand -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
+test testCommand settings getAppState' runLogger = case testCommand of
+  (TestGHC iopts) -> go iopts
+ where
+  go :: TestOptions -> IO ExitCode
+  go TestOptions{..} = do
+    s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
+    (case testBindist of
+       Nothing -> runTestGHC s' $ do
+         (v, vi) <- liftE $ fromVersion testVer GHC
+         liftE $ testGHCVer (_tvVersion v) addMakeArgs
+         pure vi
+       Just uri -> do
+         runTestGHC s'{ settings = settings {noVerify = True}} $ do
+           (v, vi) <- liftE $ fromVersion testVer GHC
+           liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing) (_tvVersion v) addMakeArgs
+           pure vi
+      )
+        >>= \case
+              VRight _ -> do
+                runLogger $ logInfo "GHC test successful"
+                pure ExitSuccess
+              VLeft e -> do
+                runLogger $ do
+                  logError $ T.pack $ prettyHFError e
+                  logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
+                pure $ ExitFailure 3
+
--- a/app/ghcup/GHCup/OptParse/ToolRequirements.hs
+++ b/app/ghcup/GHCup/OptParse/ToolRequirements.hs
@@ -23,7 +23,6 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
@@ -118,5 +117,5 @@ toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements run
    >>= \case
          VRight _ -> pure ExitSuccess
          VLeft  e -> do
-            runLogger $ logError $ T.pack $ prettyShow e
+            runLogger $ logError $ T.pack $ prettyHFError e
            pure $ ExitFailure 12
--- a/app/ghcup/GHCup/OptParse/UnSet.hs
+++ b/app/ghcup/GHCup/OptParse/UnSet.hs
@@ -31,7 +31,6 @@ import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -189,7 +188,7 @@ unset unsetCommand runLeanAppState runLogger = case unsetCommand of
                runLogger $ logInfo "GHC successfully unset"
                pure ExitSuccess
              VLeft  e -> do
-                runLogger $ logError $ T.pack $ prettyShow e
+                runLogger $ logError $ T.pack $ prettyHFError e
                pure $ ExitFailure 14
  (UnsetCabal (UnsetOptions _)) -> do
    void $ runLeanAppState (VRight <$> unsetCabal)
--- a/app/ghcup/GHCup/OptParse/Upgrade.hs
+++ b/app/ghcup/GHCup/OptParse/Upgrade.hs
@@ -28,7 +28,6 @@ import           Haskus.Utils.Variant.Excepts
 import           Options.Applicative     hiding ( style )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -88,6 +87,7 @@ upgradeOptsP =


 type UpgradeEffects = '[ DigestError
+                       , ContentLengthError
                       , GPGError
                       , NoDownload
                       , NoUpdate
@@ -151,5 +151,5 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
        runLogger $ logWarn "No GHCup update available"
        pure ExitSuccess
      VLeft e -> do
-        runLogger $ logError $ T.pack $ prettyShow e
+        runLogger $ logError $ T.pack $ prettyHFError e
        pure $ ExitFailure 11
--- a/app/ghcup/GHCup/OptParse/Whereis.hs
+++ b/app/ghcup/GHCup/OptParse/Whereis.hs
@@ -34,7 +34,6 @@ import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Environment
 import           System.Exit
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )

 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
@@ -288,7 +287,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                liftIO $ putStr r
                pure ExitSuccess
              VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyShow e
+                runLogger $ logError $ T.pack $ prettyHFError e
                pure $ ExitFailure 30
    (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
      runLeanWhereIs leanAppstate (do
@@ -302,7 +301,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                liftIO $ putStr r
                pure ExitSuccess
              VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyShow e
+                runLogger $ logError $ T.pack $ prettyHFError e
                pure $ ExitFailure 30

    (WhereisTool tool whereVer, WhereisOptions{..}) -> do
@@ -318,7 +317,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                liftIO $ putStr r
                pure ExitSuccess
              VLeft e -> do
-                runLogger $ logError $ T.pack $ prettyShow e
+                runLogger $ logError $ T.pack $ prettyHFError e
                pure $ ExitFailure 30

    (WhereisBaseDir, _) -> do
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@@ -206,19 +206,19 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                                          VRight r -> pure r
                                          VLeft e -> do
                                            runLogger
-                                              (logError $ T.pack $ prettyShow e)
+                                              (logError $ T.pack $ prettyHFError e)
                                            exitWith (ExitFailure 2)

                ghcupInfo <-
                  ( flip runReaderT leanAppstate
-                    . runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
+                    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
                    $ liftE getDownloadsF
                    )
                    >>= \case
                          VRight r -> pure r
                          VLeft  e -> do
                            runLogger
-                              (logError $ T.pack $ prettyShow e)
+                              (logError $ T.pack $ prettyHFError e)
                            exitWith (ExitFailure 2)
                let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig

@@ -266,7 +266,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                  VRight _ -> pure ()
                  VLeft e -> do
                    runLogger
-                      (logError $ T.pack $ prettyShow e)
+                      (logError $ T.pack $ prettyHFError e)
                    exitWith (ExitFailure 30)
                pure s'

@@ -295,6 +295,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
 #endif
            Install installCommand     -> install installCommand settings appState runLogger
            InstallCabalLegacy iopts   -> install (Left (InstallCabal iopts)) settings appState runLogger
+            Test testCommand           -> test testCommand settings appState runLogger
            Set setCommand             -> set setCommand runAppState runLeanAppState runLogger
            UnSet unsetCommand         -> unset unsetCommand runLeanAppState runLogger
            List lo                    -> list lo no_color runAppState
@@ -311,6 +312,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
            Prefetch pfCom             -> prefetch pfCom runAppState runLogger
            GC gcOpts                  -> gc gcOpts runAppState runLogger
            Run runCommand             -> run runCommand appState leanAppstate runLogger
+            PrintAppErrors             -> putStrLn allHFError >> pure ExitSuccess

          case res of
            ExitSuccess        -> pure ()
--- a/cabal.project
+++ b/cabal.project
@@ -14,7 +14,7 @@ source-repository-package

 constraints: http-io-streams -brotli,
             any.Cabal ==3.6.2.0,
-             any.aeson >= 2.0.1.0,
+             any.aeson >= 2.0.1.0

 package libarchive
  flags: -system-libarchive
--- a/docs/about.md
+++ b/docs/about.md
@@ -60,6 +60,29 @@ All you wanted to know about GHCup.
 3. handling cabal projects
 4. being a stack alternative

+## Distribution policies
+
+Like most Linux distros and other distribution channels, GHCup also
+follows certain policies. These are as follows:
+
+1. The end-user experience is our primary concern
+    - ghcup in CI systems as a use case is a first class citizen
+2. We strive to collaborate with all maintainers of all the tools we support and maintain a good relationship
+3. We may fix build system or other distribution bugs in upstream bindists
+    - these are always communicated upstream
+4. We may even patch source code of supported tools in very rare cases if that is required to ensure that the end-user experience does not break
+    - we'll first try to upstream any such required patch and request a new release to avoid downstream patching
+    - patches will be communicated to the maintainers either way and we'll strive to get their review
+    - they will also be communicated to the end-user
+    - they will be uploaded along with the bindist
+    - we will avoid maintaining long-running downstream patches (currently zero)
+5. We may add bindists for platforms that upstream does not support
+    - this is currently the case for GHC for e.g. Alpine and possibly FreeBSD in the future
+    - this is currently also the case for stack on darwin M1
+    - we don't guarantee for unofficial bindists that the test suite passes at the moment (this may change in the future)
+6. We GPG sign all the GHCup metadata as well as the unofficial bindists
+    - any trust issues relating to missing checksums or GPG signatures is a bug and given high priority
+
 ## How

 Installs a specified GHC version into `~/.ghcup/ghc/<ver>`, and places `ghc-<ver>` symlinks in `~/.ghcup/bin/`.
@@ -75,15 +98,15 @@ cabal-install/HLS/stack are installed in `~/.ghcup/bin/<tool>-<ver>` and have un
 ## Known users

 * CI:
-	- [Github actions/virtual-environments](https://github.com/actions/virtual-environments)
-	- [Github haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
-	- [haskell-ci](https://github.com/haskell-CI/haskell-ci)
+    - [Github actions/virtual-environments](https://github.com/actions/virtual-environments)
+    - [Github haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
+    - [haskell-ci](https://github.com/haskell-CI/haskell-ci)
 * mirrors:
-	- [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
+    - [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
 * tools:
-	- [vscode-haskell](https://github.com/haskell/vscode-haskell)
-	- [nvim-lsp-installer](https://github.com/williamboman/nvim-lsp-installer)
-	- [vabal](https://github.com/Franciman/vabal)
+    - [vscode-haskell](https://github.com/haskell/vscode-haskell)
+    - [nvim-lsp-installer](https://github.com/williamboman/nvim-lsp-installer)
+    - [vabal](https://github.com/Franciman/vabal)

 ## Known problems

--- a/ghcup.cabal
+++ b/ghcup.cabal
@@ -1,4 +1,4 @@
-cabal-version:      3.0
+cabal-version:      2.4
 name:               ghcup
 version:            0.1.18.1
 license:            LGPL-3.0-only
@@ -219,6 +219,7 @@ executable ghcup
    GHCup.OptParse.Rm
    GHCup.OptParse.Run
    GHCup.OptParse.Set
+    GHCup.OptParse.Test
    GHCup.OptParse.ToolRequirements
    GHCup.OptParse.UnSet
    GHCup.OptParse.Upgrade
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@@ -78,7 +78,6 @@ import           Text.Regex.Posix

 import qualified Data.Text                     as T
 import qualified Streamly.Prelude              as S
-import Text.PrettyPrint.HughesPJClass (prettyShow)



@@ -106,6 +105,7 @@ fetchToolBindist :: ( MonadFail m
                 -> Maybe FilePath
                 -> Excepts
                      '[ DigestError
+                       , ContentLengthError
                       , GPGError
                       , DownloadFailed
                       , NoDownload
@@ -288,6 +288,7 @@ upgradeGHCup :: ( MonadMask m
             -> Excepts
                  '[ CopyError
                   , DigestError
+                   , ContentLengthError
                   , GPGError
                   , GPGError
                   , DownloadFailed
@@ -308,7 +309,7 @@ upgradeGHCup mtarget force' fatal = do
  dli   <- liftE $ getDownloadInfo GHCup latestVer
  tmp   <- fromGHCupPath <$> lift withGHCupTmpDir
  let fn = "ghcup" <> exeExt
-  p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False
+  p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) tmp (Just fn) False
  let destDir = takeDirectory destFile
      destFile = fromMaybe (binDir </> fn) mtarget
  lift $ logDebug $ "mkdir -p " <> T.pack destDir
@@ -326,7 +327,7 @@ upgradeGHCup mtarget force' fatal = do
    Just pa
      | fatal -> throwE (ToolShadowed GHCup pa destFile latestVer)
      | otherwise ->
-        lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHCup pa destFile latestVer)
+        lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHCup pa destFile latestVer)

  pure latestVer

--- a/lib/GHCup/Cabal.hs
+++ b/lib/GHCup/Cabal.hs
@@ -50,7 +50,6 @@ import           System.FilePath
 import           System.IO.Error

 import qualified Data.Text                     as T
-import Text.PrettyPrint.HughesPJClass (prettyShow)



@@ -81,6 +80,7 @@ installCabalBindist :: ( MonadMask m
                         '[ AlreadyInstalled
                          , CopyError
                          , DigestError
+                          , ContentLengthError
                          , GPGError
                          , DownloadFailed
                          , NoDownload
@@ -184,6 +184,7 @@ installCabalBin :: ( MonadMask m
                     '[ AlreadyInstalled
                      , CopyError
                      , DigestError
+                      , ContentLengthError
                      , GPGError
                      , DownloadFailed
                      , NoDownload
@@ -233,7 +234,7 @@ setCabal ver = do

  liftIO (isShadowed cabalbin) >>= \case
    Nothing -> pure ()
-    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa cabalbin ver)
+    Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa cabalbin ver)

  pure ()

--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@@ -75,7 +75,6 @@ import           System.Exit
 import           System.FilePath
 import           System.IO.Error
 import           System.IO.Temp
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           URI.ByteString

 import qualified Crypto.Hash.SHA256            as SHA256
@@ -114,7 +113,7 @@ getDownloadsF :: ( FromJSONKey Tool
                 , MonadMask m
                 )
              => Excepts
-                   '[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
+                   '[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
                   m
                   GHCupInfo
 getDownloadsF = do
@@ -162,7 +161,7 @@ getBase :: ( MonadReader env m
           , MonadMask m
           )
        => URI
-        -> Excepts '[DownloadFailed, GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo
+        -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo
 getBase uri = do
  Settings { noNetwork, downloader, metaMode } <- lift getSettings

@@ -176,7 +175,7 @@ getBase uri = do
                                  Lax -> lift (warnCache (displayException e) downloader) >> pure Nothing)
               . catchE @_ @_ @'[DownloadFailed] (\e@(DownloadFailed _) -> case metaMode of
                   Strict -> throwE e
-                   Lax -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
+                   Lax -> lift (warnCache (prettyHFError e) downloader) >> pure Nothing)
               . fmap Just
               . smartDl
               $ uri
@@ -188,7 +187,7 @@ getBase uri = do
  liftE
    . onE_ (onError actualYaml)
    . lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
-    . liftIO 
+    . liftIO
    . Y.decodeFileEither
    $ actualYaml
 where
@@ -233,6 +232,7 @@ getBase uri = do
          -> Excepts
               '[ DownloadFailed
                , DigestError
+                , ContentLengthError
                , GPGError
                ]
               m1
@@ -246,7 +246,7 @@ getBase uri = do
    Settings { metaCache } <- lift getSettings

       -- for local files, let's short-circuit and ignore access time
-    if | scheme == "file" -> liftE $ download uri' Nothing Nothing (fromGHCupPath cacheDir) Nothing True
+    if | scheme == "file" -> liftE $ download uri' Nothing Nothing Nothing (fromGHCupPath cacheDir) Nothing True
       | e -> do
          accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
          let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@@ -262,7 +262,7 @@ getBase uri = do
   where
    dlWithMod modTime json_file = do
      let (dir, fn) = splitFileName json_file
-      f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing dir (Just fn) True
+      f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing Nothing dir (Just fn) True
      liftIO $ setModificationTime f modTime
      liftIO $ setAccessTime f modTime
      pure f
@@ -328,13 +328,14 @@ download :: ( MonadReader env m
         => URI
         -> Maybe URI         -- ^ URI for gpg sig
         -> Maybe T.Text      -- ^ expected hash
+         -> Maybe Integer     -- ^ expected content length
         -> FilePath          -- ^ destination dir (ignored for file:// scheme)
         -> Maybe FilePath    -- ^ optional filename
         -> Bool              -- ^ whether to read an write etags
-         -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
-download uri gpgUri eDigest dest mfn etags
-  | scheme == "https" = dl
-  | scheme == "http"  = dl
+         -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
+download uri gpgUri eDigest eCSize dest mfn etags
+  | scheme == "https" = liftE dl
+  | scheme == "http"  = liftE dl
  | scheme == "file"  = do
      let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
      lift $ logDebug $ "using local file: " <> T.pack destFile'
@@ -355,7 +356,7 @@ download uri gpgUri eDigest dest mfn etags
    -- download
    flip onException
         (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile))
-     $ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError] @'[DigestError, DownloadFailed, GPGError]
+     $ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError, ContentLengthError] @'[DigestError, ContentLengthError, DownloadFailed, GPGError]
          (\e' -> do
            lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile)
            case e' of
@@ -390,7 +391,7 @@ download uri gpgUri eDigest dest mfn etags
                  liftE $ flip onException
                       (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
                   $ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
-                        (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyShow (GPGError e))
+                        (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e))
                        ) $ do
                      o' <- liftIO getGpgOpts
                      lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
@@ -405,19 +406,37 @@ download uri gpgUri eDigest dest mfn etags
                        CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
                _ -> pure ()

+              forM_ eCSize  (liftE . flip checkCSize  baseDestFile)
              forM_ eDigest (liftE . flip checkDigest baseDestFile)
    pure baseDestFile

-  curlDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
+  curlDL :: ( MonadCatch m
+            , MonadMask m
+            , MonadIO m
+            )
+         => [String]
+         -> FilePath
+         -> URI
+         -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
  curlDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
    let destFileTemp = tmpFile destFile
    flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
      liftE $ lEM @_ @'[ProcessError] $ exec "curl"
-        (o' ++ ["-fL", "-o", destFileTemp, T.unpack uri']) Nothing Nothing
+        (o' ++ ["-fL", "-o", destFileTemp, T.unpack uri']
+            ++ maybe [] (\s -> ["--max-filesize", show s]) eCSize
+        ) Nothing Nothing
      liftIO $ renameFile destFileTemp destFile

-  curlEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
-              => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
+  curlEtagsDL :: ( MonadReader env m
+                 , HasLog env
+                 , MonadCatch m
+                 , MonadMask m
+                 , MonadIO m
+                 )
+              => [String]
+              -> FilePath
+              -> URI
+              -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
  curlEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
    let destFileTemp = tmpFile destFile
    dh <- liftIO $ emptySystemTempFile "curl-header"
@@ -444,7 +463,14 @@ download uri gpgUri eDigest dest mfn etags

        lift $ writeEtags destFile (parseEtags headers)

-  wgetDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
+  wgetDL :: ( MonadCatch m
+            , MonadMask m
+            , MonadIO m
+            )
+         => [String]
+         -> FilePath
+         -> URI
+         -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
  wgetDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
    let destFileTemp = tmpFile destFile
    flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
@@ -453,8 +479,16 @@ download uri gpgUri eDigest dest mfn etags
      liftIO $ renameFile destFileTemp destFile


-  wgetEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
-              => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
+  wgetEtagsDL :: ( MonadReader env m
+                 , HasLog env
+                 , MonadCatch m
+                 , MonadMask m
+                 , MonadIO m
+                 )
+              => [String]
+              -> FilePath
+              -> URI
+              -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
  wgetEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
    let destFileTemp = tmpFile destFile
    flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
@@ -475,7 +509,10 @@ download uri gpgUri eDigest dest mfn etags
          | otherwise -> throwE (NonZeroExit i' "wget" opts)

 #if defined(INTERNAL_DOWNLOADER)
-  internalDL :: (MonadCatch m, MonadMask m, MonadIO m)
+  internalDL :: ( MonadCatch m
+                , MonadMask m
+                , MonadIO m
+                )
             => FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
  internalDL destFile uri' = do
    let destFileTemp = tmpFile destFile
@@ -485,11 +522,16 @@ download uri gpgUri eDigest dest mfn etags
                 @'[DownloadFailed]
            (\e@(HTTPNotModified _) ->
              throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
-        $ downloadToFile https host fullPath port destFileTemp mempty
+        $ downloadToFile https host fullPath port destFileTemp mempty eCSize
      liftIO $ renameFile destFileTemp destFile


-  internalEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
+  internalEtagsDL :: ( MonadReader env m
+                     , HasLog env
+                     , MonadCatch m
+                     , MonadMask m
+                     , MonadIO m
+                     )
                  => FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
  internalEtagsDL destFile uri' = do
    let destFileTemp = tmpFile destFile
@@ -501,7 +543,7 @@ download uri gpgUri eDigest dest mfn etags
      liftE
        $ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
        $ do
-          r <- downloadToFile https host fullPath port destFileTemp addHeaders
+          r <- downloadToFile https host fullPath port destFileTemp addHeaders eCSize
          liftIO $ renameFile destFileTemp destFile
          lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
 #endif
@@ -509,7 +551,7 @@ download uri gpgUri eDigest dest mfn etags

  -- Manage to find a file we can write the body into.
  getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath
-  getDestFile uri' mfn' = 
+  getDestFile uri' mfn' =
    let path = view pathL' uri'
    in case mfn' of
        Just fn -> pure (dest </> fn)
@@ -578,14 +620,14 @@ downloadCached :: ( MonadReader env m
                  )
               => DownloadInfo
               -> Maybe FilePath  -- ^ optional filename
-               -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
+               -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
 downloadCached dli mfn = do
  Settings{ cache } <- lift getSettings
  case cache of
    True -> downloadCached' dli mfn Nothing
    False -> do
      tmp <- lift withGHCupTmpDir
-      liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False
+      liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) mfn False


 downloadCached' :: ( MonadReader env m
@@ -600,7 +642,7 @@ downloadCached' :: ( MonadReader env m
                => DownloadInfo
                -> Maybe FilePath  -- ^ optional filename
                -> Maybe FilePath  -- ^ optional destination dir (default: cacheDir)
-                -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
+                -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
 downloadCached' dli mfn mDestDir = do
  Dirs { cacheDir } <- lift getDirs
  let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
@@ -609,9 +651,10 @@ downloadCached' dli mfn mDestDir = do
  fileExists <- liftIO $ doesFileExist cachfile
  if
    | fileExists -> do
+      forM_ (view dlCSize dli) $ \s -> liftE $ checkCSize s cachfile
      liftE $ checkDigest (view dlHash dli) cachfile
      pure cachfile
-    | otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) destDir mfn False
+    | otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) destDir mfn False



@@ -642,6 +685,25 @@ checkDigest eDigest file = do
    cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
    when ((cDigest /= eDigest) && verify) $ throwE (DigestError file cDigest eDigest)

+checkCSize :: ( MonadReader env m
+              , HasDirs env
+              , HasSettings env
+              , MonadIO m
+              , MonadThrow m
+              , HasLog env
+              )
+           => Integer
+           -> FilePath
+           -> Excepts '[ContentLengthError] m ()
+checkCSize eCSize file = do
+  Settings{ noVerify } <- lift getSettings
+  let verify = not noVerify
+  when verify $ do
+    let p' = takeFileName file
+    lift $ logInfo $ "verifying content length of: " <> T.pack p'
+    cSize <- liftIO $ getFileSize file
+    when ((eCSize /= cSize) && verify) $ throwE (ContentLengthError (Just file) (Just cSize) eCSize)
+

 -- | Get additional curl args from env. This is an undocumented option.
 getCurlOpts :: IO [String]
--- a/lib/GHCup/Download/IOStreams.hs
+++ b/lib/GHCup/Download/IOStreams.hs
@@ -17,14 +17,12 @@ import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.Reader
 import           Data.ByteString                ( ByteString )
-import           Data.ByteString.Builder
 import           Data.CaseInsensitive           ( CI, original, mk )
 import           Data.IORef
 import           Data.Maybe
 import           Data.Text.Read
 import           Haskus.Utils.Variant.Excepts
 import           Network.Http.Client     hiding ( URL )
-import           Optics
 import           Prelude                 hiding ( abs
                                                , readFile
                                                , writeFile
@@ -33,7 +31,6 @@ import           System.ProgressBar
 import           URI.ByteString

 import qualified Data.ByteString               as BS
-import qualified Data.ByteString.Lazy          as L
 import qualified Data.Map.Strict               as M
 import qualified System.IO.Streams             as Streams

@@ -46,27 +43,6 @@ import qualified System.IO.Streams             as Streams
    ----------------------------


-- | Load the result of this download into memory at once.
-downloadBS' :: MonadIO m
-            => Bool             -- ^ https?
-            -> ByteString       -- ^ host (e.g. "www.example.com")
-            -> ByteString       -- ^ path (e.g. "/my/file") including query
-            -> Maybe Int        -- ^ optional port (e.g. 3000)
-            -> Excepts
-                 '[ HTTPStatusError
-                  , URIParseError
-                  , UnsupportedScheme
-                  , NoLocationHeader
-                  , TooManyRedirs
-                  ]
-                 m
-                 L.ByteString
-downloadBS' https host path port = do
-  bref <- liftIO $ newIORef (mempty :: Builder)
-  let stepper bs = modifyIORef bref (<> byteString bs)
-  void $ downloadInternal False https host path port stepper (pure ()) mempty
-  liftIO (readIORef bref <&> toLazyByteString)
-

 downloadToFile :: (MonadMask m, MonadIO m)
               => Bool             -- ^ https?
@@ -75,8 +51,9 @@ downloadToFile :: (MonadMask m, MonadIO m)
               -> Maybe Int        -- ^ optional port (e.g. 3000)
               -> FilePath         -- ^ destination file to create and write to
               -> M.Map (CI ByteString) ByteString -- ^ additional headers
+               -> Maybe Integer    -- ^ expected content length
               -> Excepts '[DownloadFailed, HTTPNotModified] m Response
-downloadToFile https host fullPath port destFile addHeaders = do
+downloadToFile https host fullPath port destFile addHeaders eCSize = do
  let stepper = BS.appendFile destFile
      setup = BS.writeFile destFile mempty
  catchAllE (\case
@@ -84,7 +61,7 @@ downloadToFile https host fullPath port destFile addHeaders = do
                | i == 304
                , Just e <- M.lookup (mk "etag") headers -> throwE $ HTTPNotModified (decUTF8Safe e)
              v -> throwE $ DownloadFailed v
-            ) $ downloadInternal True https host fullPath port stepper setup addHeaders
+            ) $ downloadInternal True https host fullPath port stepper setup addHeaders eCSize


 downloadInternal :: MonadIO m
@@ -96,19 +73,21 @@ downloadInternal :: MonadIO m
                 -> (ByteString -> IO a)   -- ^ the consuming step function
                 -> IO a                   -- ^ setup action
                 -> M.Map (CI ByteString) ByteString -- ^ additional headers
+                 -> Maybe Integer
                 -> Excepts
                      '[ HTTPStatusError
                       , URIParseError
                       , UnsupportedScheme
                       , NoLocationHeader
                       , TooManyRedirs
+                       , ContentLengthError
                       ]
                      m
                      Response
 downloadInternal = go (5 :: Int)

 where
-  go redirs progressBar https host path port consumer setup addHeaders = do
+  go redirs progressBar https host path port consumer setup addHeaders eCSize = do
    r <- liftIO $ withConnection' https host port action
    veitherToExcepts r >>= \case
      Right r' ->
@@ -138,25 +117,39 @@ downloadInternal = go (5 :: Int)
    followRedirectURL bs = case parseURI strictURIParserOptions bs of
      Right uri' -> do
        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
-        go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders
+        go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders eCSize
      Left e -> throwE e

    downloadStream r i' = do
      void setup
      let size = case getHeader r "Content-Length" of
            Just x' -> case decimal $ decUTF8Safe x' of
-              Left  _       -> 0
-              Right (r', _) -> r'
-            Nothing -> 0
+              Left  _       -> Nothing
+              Right (r', _) -> Just r'
+            Nothing -> Nothing

-      (mpb :: Maybe (ProgressBar ())) <- if progressBar
-        then Just <$> newProgressBar defStyle 10 (Progress 0 size ())
-        else pure Nothing
+      forM_ size $ \s -> forM_ eCSize $ \es -> when (es /= s) $ throwIO (ContentLengthError Nothing (Just s) es)
+      let size' = eCSize <|> size
+
+      (mpb :: Maybe (ProgressBar ())) <- case (progressBar, size') of
+        (True, Just size'') -> Just <$> newProgressBar defStyle 10 (Progress 0 (fromInteger size'') ())
+        _ -> pure Nothing
+
+      ior <- liftIO $ newIORef 0

      outStream <- liftIO $ Streams.makeOutputStream
        (\case
          Just bs -> do
-            forM_ mpb $ \pb -> incProgress pb (BS.length bs)
+            let len = BS.length bs
+            forM_ mpb $ \pb -> incProgress pb len
+
+            -- check we don't exceed size
+            forM_ size' $ \s -> do
+              cs <- readIORef ior
+              when ((cs + toInteger len) > s) $ throwIO (ContentLengthError Nothing (Just (cs + toInteger len)) s)
+
+            modifyIORef ior (+ toInteger len)
+
            void $ consumer bs
          Nothing -> pure ()
        )
--- a/lib/GHCup/Errors.hs
+++ b/lib/GHCup/Errors.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeOperators           #-}
 {-# LANGUAGE FlexibleInstances           #-}
+{-# LANGUAGE RankNTypes           #-}

 {-|
 Module      : GHCup.Errors
@@ -34,9 +35,153 @@ import           URI.ByteString

 import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
+import           Data.Data (Proxy(..))



+allHFError :: String
+allHFError = unlines allErrors
+ where
+  format p = "GHCup-" <> show (eBase p) <> " " <>  eDesc p
+  format'' e p = "GHCup-" <> show (eNum e) <> " " <>  eDesc p
+  format' e  _ = "GHCup-" <> show (eNum e) <> " " <>  prettyShow e
+  format''' e  _ str' = "GHCup-" <> show (eNum e) <> " " <>  str'
+  allErrors =
+    [ "# low level errors (1 to 500)"
+    , let proxy = Proxy :: Proxy NoCompatiblePlatform in format proxy
+    , let proxy = Proxy :: Proxy NoDownload in format proxy
+    , let proxy = Proxy :: Proxy NoUpdate in format proxy
+    , let proxy = Proxy :: Proxy DistroNotFound in format proxy
+    , let proxy = Proxy :: Proxy UnknownArchive in format proxy
+    , let proxy = Proxy :: Proxy UnsupportedScheme in format proxy
+    , let proxy = Proxy :: Proxy CopyError in format proxy
+    , let proxy = Proxy :: Proxy MergeFileTreeError in format proxy
+    , let proxy = Proxy :: Proxy TagNotFound in format proxy
+    , let proxy = Proxy :: Proxy NextVerNotFound in format proxy
+    , let proxy = Proxy :: Proxy AlreadyInstalled in format proxy
+    , let proxy = Proxy :: Proxy DirNotEmpty in format proxy
+    , let proxy = Proxy :: Proxy NotInstalled in format proxy
+    , let proxy = Proxy :: Proxy UninstallFailed in format proxy
+    , let proxy = Proxy :: Proxy NotFoundInPATH in format proxy
+    , let proxy = Proxy :: Proxy JSONError in format proxy
+    , let proxy = Proxy :: Proxy FileDoesNotExistError in format proxy
+    , let proxy = Proxy :: Proxy FileAlreadyExistsError in format proxy
+    , let proxy = Proxy :: Proxy TarDirDoesNotExist in format proxy
+    , let proxy = Proxy :: Proxy DigestError in format proxy
+    , let proxy = Proxy :: Proxy GPGError in format proxy
+    , let proxy = Proxy :: Proxy HTTPStatusError in format proxy
+    , let proxy = Proxy :: Proxy MalformedHeaders in format proxy
+    , let proxy = Proxy :: Proxy HTTPNotModified in format proxy
+    , let proxy = Proxy :: Proxy NoLocationHeader in format proxy
+    , let proxy = Proxy :: Proxy TooManyRedirs in format proxy
+    , let proxy = Proxy :: Proxy PatchFailed in format proxy
+    , let proxy = Proxy :: Proxy NoToolRequirements in format proxy
+    , let proxy = Proxy :: Proxy InvalidBuildConfig in format proxy
+    , let proxy = Proxy :: Proxy NoToolVersionSet in format proxy
+    , let proxy = Proxy :: Proxy NoNetwork in format proxy
+    , let proxy = Proxy :: Proxy HadrianNotFound in format proxy
+    , let proxy = Proxy :: Proxy ToolShadowed in format proxy
+    , let proxy = Proxy :: Proxy ContentLengthError in format proxy
+    , ""
+    , "# high level errors (4000+)"
+    , let proxy = Proxy :: Proxy DownloadFailed in format proxy
+    , let proxy = Proxy :: Proxy InstallSetError in format proxy
+    , let proxy = Proxy :: Proxy TestFailed in format proxy
+    , let proxy = Proxy :: Proxy BuildFailed in format proxy
+    , let proxy = Proxy :: Proxy GHCupSetError in format proxy
+    , ""
+    , "# true exceptions (500+)"
+    , let proxy = Proxy :: Proxy ParseError in format proxy
+    , let proxy = Proxy :: Proxy UnexpectedListLength in format proxy
+    , let proxy = Proxy :: Proxy NoUrlBase in format proxy
+    , ""
+    , "# orphans (800+)"
+    , let proxy = Proxy :: Proxy URIParseError in format proxy
+    , let proxy = Proxy :: Proxy URIParseError
+          e     = MalformedScheme MissingColon
+      in format' e proxy
+    , let proxy = Proxy :: Proxy URIParseError
+          e     = MalformedUserInfo
+      in format' e proxy
+    , let proxy = Proxy :: Proxy URIParseError
+          e     = MalformedQuery
+      in format' e proxy
+    , let proxy = Proxy :: Proxy URIParseError
+          e     = MalformedFragment
+      in format' e proxy
+    , let proxy = Proxy :: Proxy URIParseError
+          e     = MalformedHost
+      in format' e proxy
+    , let proxy = Proxy :: Proxy URIParseError
+          e     = MalformedPort
+      in format' e proxy
+    , let proxy = Proxy :: Proxy URIParseError
+          e     = MalformedPath
+      in format' e proxy
+    , let proxy = Proxy :: Proxy URIParseError
+          e     = OtherError ""
+      in format'' e proxy
+    , let proxy = Proxy :: Proxy ArchiveResult in format proxy
+    , let proxy = Proxy :: Proxy ArchiveResult
+          e     = ArchiveFatal
+      in format' e proxy
+    , let proxy = Proxy :: Proxy ArchiveResult
+          e     = ArchiveFailed
+      in format' e proxy
+    , let proxy = Proxy :: Proxy ArchiveResult
+          e     = ArchiveWarn
+      in format' e proxy
+    , let proxy = Proxy :: Proxy ArchiveResult
+          e     = ArchiveRetry
+      in format' e proxy
+    , let proxy = Proxy :: Proxy ArchiveResult
+          e     = ArchiveOk
+      in format' e proxy
+    , let proxy = Proxy :: Proxy ArchiveResult
+          e     = ArchiveEOF
+      in format' e proxy
+
+    , let proxy = Proxy :: Proxy ProcessError in format proxy
+    , let proxy = Proxy :: Proxy ProcessError
+          e     = NonZeroExit 0 "" []
+      in format''' e proxy "A process returned a non-zero exit code."
+    , let proxy = Proxy :: Proxy ProcessError
+          e     = PTerminated "" []
+      in format''' e proxy "A process terminated prematurely."
+    , let proxy = Proxy :: Proxy ProcessError
+          e     = PStopped "" []
+      in format''' e proxy "A process stopped prematurely."
+    , let proxy = Proxy :: Proxy ProcessError
+          e     = NoSuchPid "" []
+      in format''' e proxy "Could not find PID for this process."
+    ]
+
+
+prettyHFError :: (Pretty e, HFErrorProject e) => e -> String
+prettyHFError e =
+  let errorCode = "GHCup-" <> padIntAndShow (eNum e)
+  in ("[" <> linkEscapeCode errorCode  (hfErrorLink errorCode) <> "] ") <> prettyShow e
+ where
+  hfErrorLink errorCode = "https://errors.haskell.org/messages/" <> errorCode
+  padIntAndShow i
+    | i < 10    = "0000" <> show i
+    | i < 100   = "000"  <> show i
+    | i < 1000  = "00"   <> show i
+    | i < 10000 = "0"    <> show i
+    | otherwise =           show i
+
+class HFErrorProject a where
+  eNum :: a -> Int
+  eNum _ = eBase (Proxy :: Proxy a)
+
+  eBase :: Proxy a -> Int
+
+  eDesc :: Proxy a -> String
+
+linkEscapeCode :: String -> String -> String
+linkEscapeCode linkText link = "\ESC]8;;" <> link <> "\ESC\\" <> linkText <> "\ESC]8;;\ESC\\"
+
+
    ------------------------
    --[ Low-level errors ]--
    ------------------------
@@ -51,20 +196,32 @@ instance Pretty NoCompatiblePlatform where
  pPrint (NoCompatiblePlatform str') =
    text ("Could not find a compatible platform. Got: " ++ str')

+instance HFErrorProject NoCompatiblePlatform where
+  eBase _ = 1
+  eDesc _ = "No compatible platform could be found"
+
 -- | Unable to find a download for the requested version/distro.
 data NoDownload = NoDownload
  deriving Show

 instance Pretty NoDownload where
  pPrint NoDownload =
-    text "Unable to find a download for the requested version/distro."
+    text (eDesc (Proxy :: Proxy NoDownload))
+
+instance HFErrorProject NoDownload where
+  eBase _ = 10
+  eDesc _ = "Unable to find a download for the requested version/distro."

 -- | No update available or necessary.
 data NoUpdate = NoUpdate
  deriving Show

 instance Pretty NoUpdate where
-  pPrint NoUpdate = text "No update available or necessary."
+  pPrint NoUpdate = text (eDesc (Proxy :: Proxy NoUpdate))
+
+instance HFErrorProject NoUpdate where
+  eBase _ = 20
+  eDesc _ = "No update available or necessary."

 -- | The Architecture is unknown and unsupported.
 data NoCompatibleArch = NoCompatibleArch String
@@ -74,13 +231,21 @@ instance Pretty NoCompatibleArch where
  pPrint (NoCompatibleArch arch) =
    text ("The Architecture is unknown or unsupported. Got: " ++ arch)

+instance HFErrorProject NoCompatibleArch where
+  eBase _ = 30
+  eDesc _ = "The Architecture is unknown and unsupported"
+
 -- | Unable to figure out the distribution of the host.
 data DistroNotFound = DistroNotFound
  deriving Show

 instance Pretty DistroNotFound where
  pPrint DistroNotFound =
-    text "Unable to figure out the distribution of the host."
+    text (eDesc (Proxy :: Proxy DistroNotFound))
+
+instance HFErrorProject DistroNotFound where
+  eBase _ = 40
+  eDesc _ = "Unable to figure out the distribution of the host"

 -- | The archive format is unknown. We don't know how to extract it.
 data UnknownArchive = UnknownArchive FilePath
@@ -90,12 +255,21 @@ instance Pretty UnknownArchive where
  pPrint (UnknownArchive file) =
    text $ "The archive format is unknown. We don't know how to extract the file " <> file

+instance HFErrorProject UnknownArchive where
+  eBase _ = 50
+  eDesc _ = "The archive format is unknown. We don't know how to extract it."
+
 -- | The scheme is not supported (such as ftp).
 data UnsupportedScheme = UnsupportedScheme
  deriving Show

 instance Pretty UnsupportedScheme where
-  pPrint UnsupportedScheme = text "The scheme is not supported (such as ftp)."
+  pPrint UnsupportedScheme =
+    text (eDesc (Proxy :: Proxy UnsupportedScheme))
+
+instance HFErrorProject UnsupportedScheme where
+  eBase _ = 60
+  eDesc _ = "The scheme is not supported (such as ftp)."

 -- | Unable to copy a file.
 data CopyError = CopyError String
@@ -105,6 +279,10 @@ instance Pretty CopyError where
  pPrint (CopyError reason) =
    text ("Unable to copy a file. Reason was: " ++ reason)

+instance HFErrorProject CopyError where
+  eBase _ = 70
+  eDesc _ = "Unable to copy a file."
+
 -- | Unable to merge file trees.
 data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath
  deriving Show
@@ -114,6 +292,10 @@ instance Pretty MergeFileTreeError where
    text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e)
     <+> text "\n...you may need to delete" <+> text to <+> text "manually. Make sure it's gone."

+instance HFErrorProject MergeFileTreeError where
+  eBase _ = 80
+  eDesc _ = "Unable to merge file trees during installation"
+
 -- | Unable to find a tag of a tool.
 data TagNotFound = TagNotFound Tag Tool
  deriving Show
@@ -122,6 +304,10 @@ instance Pretty TagNotFound where
  pPrint (TagNotFound tag tool) =
    text "Unable to find tag" <+> pPrint tag <+> text "of tool" <+> pPrint tool

+instance HFErrorProject TagNotFound where
+  eBase _ = 90
+  eDesc _ = "Unable to find a tag of a tool"
+
 -- | Unable to find the next version of a tool (the one after the currently
 -- set one).
 data NextVerNotFound = NextVerNotFound Tool
@@ -131,6 +317,10 @@ instance Pretty NextVerNotFound where
  pPrint (NextVerNotFound tool) =
    text "Unable to find next (the one after the currently set one) version of tool" <+> pPrint tool

+instance HFErrorProject NextVerNotFound where
+  eBase _ = 100
+  eDesc _ = "Unable to find the next version of a tool (the one after the currently set one)"
+
 -- | The tool (such as GHC) is already installed with that version.
 data AlreadyInstalled = AlreadyInstalled Tool Version
  deriving Show
@@ -140,6 +330,9 @@ instance Pretty AlreadyInstalled where
    (pPrint tool <> text "-" <> pPrint ver') <+> text "is already installed;"
    <+> text "if you really want to reinstall it, you may want to run 'ghcup install" <+> pPrint tool <+> text "--force" <+> (pPrint ver' <> text "'")

+instance HFErrorProject AlreadyInstalled where
+  eBase _ = 110
+  eDesc _ = "The tool (such as GHC) is already installed with that version"

 -- | The Directory is supposed to be empty, but wasn't.
 data DirNotEmpty = DirNotEmpty {path :: FilePath}
@@ -149,6 +342,10 @@ instance Pretty DirNotEmpty where
  pPrint (DirNotEmpty path) = do
    text $ "The directory was expected to be empty, but isn't: " <> path

+instance HFErrorProject DirNotEmpty where
+  eBase _ = 120
+  eDesc _ = "The Directory is supposed to be empty, but wasn't"
+
 -- | The tool is not installed. Some operations rely on a tool
 -- to be installed (such as setting the current GHC version).
 data NotInstalled = NotInstalled Tool GHCTargetVersion
@@ -158,6 +355,10 @@ instance Pretty NotInstalled where
  pPrint (NotInstalled tool ver) =
    text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."

+instance HFErrorProject NotInstalled where
+  eBase _ = 130
+  eDesc _ = "The required tool is not installed"
+
 data UninstallFailed = UninstallFailed FilePath [FilePath]
  deriving Show

@@ -165,6 +366,10 @@ instance Pretty UninstallFailed where
  pPrint (UninstallFailed dir files) =
    text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."

+instance HFErrorProject UninstallFailed where
+  eBase _ = 140
+  eDesc _ = "Uninstallation failed with leftover files"
+
 -- | An executable was expected to be in PATH, but was not found.
 data NotFoundInPATH = NotFoundInPATH FilePath
  deriving Show
@@ -175,6 +380,10 @@ instance Pretty NotFoundInPATH where
  pPrint (NotFoundInPATH exe) =
    text $ "The exe " <> exe <> " was not found in PATH."

+instance HFErrorProject NotFoundInPATH where
+  eBase _ = 150
+  eDesc _ = "An executable was expected to be in PATH, but was not found"
+
 -- | JSON decoding failed.
 data JSONError = JSONDecodeError String
  deriving Show
@@ -183,6 +392,10 @@ instance Pretty JSONError where
  pPrint (JSONDecodeError err) =
    text $ "JSON decoding failed with: " <> err

+instance HFErrorProject JSONError where
+  eBase _ = 160
+  eDesc _ = "JSON decoding failed"
+
 -- | A file that is supposed to exist does not exist
 -- (e.g. when we use file scheme to "download" something).
 data FileDoesNotExistError = FileDoesNotExistError FilePath
@@ -192,6 +405,10 @@ instance Pretty FileDoesNotExistError where
  pPrint (FileDoesNotExistError file) =
    text $ "File " <> file <> " does not exist."

+instance HFErrorProject FileDoesNotExistError where
+  eBase _ = 170
+  eDesc _ = "A file that is supposed to exist does not exist (oops)"
+
 -- | The file already exists
 -- (e.g. when we use isolated installs with the same path).
 -- (e.g. This is done to prevent any overwriting)
@@ -202,6 +419,10 @@ instance Pretty FileAlreadyExistsError where
  pPrint (FileAlreadyExistsError file) =
    text $ "File " <> file <> " Already exists."

+instance HFErrorProject FileAlreadyExistsError where
+  eBase _ = 180
+  eDesc _ = "A file already exists that wasn't expected to exist"
+
 data TarDirDoesNotExist = TarDirDoesNotExist TarDir
  deriving Show

@@ -209,6 +430,10 @@ instance Pretty TarDirDoesNotExist where
  pPrint (TarDirDoesNotExist dir) =
    text "Tar directory does not exist:" <+> pPrint dir

+instance HFErrorProject TarDirDoesNotExist where
+  eBase _ = 190
+  eDesc _ = "The tar directory (e.g. inside an archive) does not exist"
+
 -- | File digest verification failed.
 data DigestError = DigestError FilePath Text Text
  deriving Show
@@ -219,7 +444,11 @@ instance Pretty DigestError where
      <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest <+> text
      "\nConsider removing the file in case it's cached and try again."

-- | File digest verification failed.
+instance HFErrorProject DigestError where
+  eBase _ = 200
+  eDesc _ = "File digest verification failed"
+
+-- | File PGP verification failed.
 data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)

 deriving instance Show GPGError
@@ -227,6 +456,10 @@ deriving instance Show GPGError
 instance Pretty GPGError where
  pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason

+instance HFErrorProject GPGError where
+  eBase _ = 210
+  eDesc _ = "File PGP verification failed"
+
 -- | Unexpected HTTP status.
 data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
  deriving Show
@@ -235,6 +468,10 @@ instance Pretty HTTPStatusError where
  pPrint (HTTPStatusError status _) =
    text "Unexpected HTTP status:" <+> pPrint status

+instance HFErrorProject HTTPStatusError where
+  eBase _ = 220
+  eDesc _ = "Unexpected HTTP status error (e.g. during downloads)"
+
 -- | Malformed headers.
 data MalformedHeaders = MalformedHeaders Text
  deriving Show
@@ -243,6 +480,10 @@ instance Pretty MalformedHeaders where
  pPrint (MalformedHeaders h) =
    text "Headers are malformed: " <+> pPrint h

+instance HFErrorProject MalformedHeaders where
+  eBase _ = 230
+  eDesc _ = "Malformed headers during download"
+
 -- | Unexpected HTTP status.
 data HTTPNotModified = HTTPNotModified Text
  deriving Show
@@ -251,13 +492,21 @@ instance Pretty HTTPNotModified where
  pPrint (HTTPNotModified etag) =
    text "Remote resource not modifed, etag was:" <+> pPrint etag

+instance HFErrorProject HTTPNotModified where
+  eBase _ = 240
+  eDesc _ = "Not modified HTTP status error (e.g. during downloads)."
+
 -- | The 'Location' header was expected during a 3xx redirect, but not found.
 data NoLocationHeader = NoLocationHeader
  deriving Show

 instance Pretty NoLocationHeader where
  pPrint NoLocationHeader =
-    text "The 'Location' header was expected during a 3xx redirect, but not found."
+    text (eDesc (Proxy :: Proxy NoLocationHeader))
+
+instance HFErrorProject NoLocationHeader where
+  eBase _ = 250
+  eDesc _ = "The 'Location' header was expected during a 3xx redirect, but not found."

 -- | Too many redirects.
 data TooManyRedirs = TooManyRedirs
@@ -265,7 +514,11 @@ data TooManyRedirs = TooManyRedirs

 instance Pretty TooManyRedirs where
  pPrint TooManyRedirs =
-    text "Too many redirections."
+    text (eDesc (Proxy :: Proxy TooManyRedirs))
+
+instance HFErrorProject TooManyRedirs where
+  eBase _ = 260
+  eDesc _ = "Too many redirections."

 -- | A patch could not be applied.
 data PatchFailed = PatchFailed
@@ -273,7 +526,11 @@ data PatchFailed = PatchFailed

 instance Pretty PatchFailed where
  pPrint PatchFailed =
-    text "A patch could not be applied."
+    text (eDesc (Proxy :: Proxy PatchFailed))
+
+instance HFErrorProject PatchFailed where
+  eBase _ = 270
+  eDesc _ = "A patch could not be applied."

 -- | The tool requirements could not be found.
 data NoToolRequirements = NoToolRequirements
@@ -281,7 +538,11 @@ data NoToolRequirements = NoToolRequirements

 instance Pretty NoToolRequirements where
  pPrint NoToolRequirements =
-    text "The Tool requirements could not be found."
+    text (eDesc (Proxy :: Proxy NoToolRequirements))
+
+instance HFErrorProject NoToolRequirements where
+  eBase _ = 280
+  eDesc _ = "The Tool requirements could not be found."

 data InvalidBuildConfig = InvalidBuildConfig Text
  deriving Show
@@ -290,6 +551,10 @@ instance Pretty InvalidBuildConfig where
  pPrint (InvalidBuildConfig reason) =
    text "The build config is invalid. Reason was:" <+> pPrint reason

+instance HFErrorProject InvalidBuildConfig where
+  eBase _ = 290
+  eDesc _ = "The build config is invalid."
+
 data NoToolVersionSet = NoToolVersionSet Tool
  deriving Show

@@ -297,19 +562,31 @@ instance Pretty NoToolVersionSet where
  pPrint (NoToolVersionSet tool) =
    text "No version is set for tool" <+> pPrint tool <+> text "."

+instance HFErrorProject NoToolVersionSet where
+  eBase _ = 300
+  eDesc _ = "No version is set for tool (but was expected)."
+
 data NoNetwork = NoNetwork
  deriving Show

 instance Pretty NoNetwork where
  pPrint NoNetwork =
-    text "A download was required or requested, but '--offline' was specified."
+    text (eDesc (Proxy :: Proxy NoNetwork))
+
+instance HFErrorProject NoNetwork where
+  eBase _ = 310
+  eDesc _ = "A download was required or requested, but '--offline' was specified."

 data HadrianNotFound = HadrianNotFound
  deriving Show

 instance Pretty HadrianNotFound where
  pPrint HadrianNotFound =
-    text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
+    text (eDesc (Proxy :: Proxy HadrianNotFound))
+
+instance HFErrorProject HadrianNotFound where
+  eBase _ = 320
+  eDesc _ = "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"

 data ToolShadowed = ToolShadowed
                       Tool
@@ -332,12 +609,43 @@ instance Pretty ToolShadowed where
         <> " in PATH."
         )

+instance HFErrorProject ToolShadowed where
+  eBase _ = 330
+  eDesc _ = "A tool is shadowed in PATH."
+
+-- | File content length verification failed.
+data ContentLengthError = ContentLengthError (Maybe FilePath) (Maybe Integer) Integer
+  deriving Show
+
+instance Pretty ContentLengthError where
+  pPrint (ContentLengthError Nothing Nothing expectedSize) =
+    text "Content length exceeded expected size:"
+      <+> text (show expectedSize)
+      <+> text "\nConsider removing the file in case it's cached and try again."
+  pPrint (ContentLengthError Nothing (Just currentSize) expectedSize) =
+    text "Content length error. Expected"
+      <+> text (show expectedSize) <+> text "but got" <+> pPrint currentSize <+> text
+      "\nConsider removing the file in case it's cached and try again."
+  pPrint (ContentLengthError (Just fp) (Just currentSize) expectedSize) =
+    text "Content length error for" <+> text (fp <> ": expected")
+      <+> text (show expectedSize) <+> text "but got" <+> pPrint currentSize <+> text
+      "\nConsider removing the file in case it's cached and try again."
+  pPrint (ContentLengthError (Just fp) Nothing expectedSize) =
+    text "Content length error for" <+> text (fp <> ": expected")
+      <+> text (show expectedSize) <+> text "\nConsider removing the file in case it's cached and try again."
+
+instance Exception ContentLengthError
+
+instance HFErrorProject ContentLengthError where
+  eBase _ = 340
+  eDesc _ = "File content length verification failed"
+
    -------------------------
    --[ High-level errors ]--
    -------------------------

 -- | A download failed. The underlying error is encapsulated.
-data DownloadFailed = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
+data DownloadFailed = forall xs . (HFErrorProject (V xs), ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)

 instance Pretty DownloadFailed where
  pPrint (DownloadFailed reason) =
@@ -347,7 +655,12 @@ instance Pretty DownloadFailed where

 deriving instance Show DownloadFailed

-data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)
+instance HFErrorProject DownloadFailed where
+  eBase _ = 5000
+  eNum (DownloadFailed xs) = 5000 + eNum xs
+  eDesc _ = "A download failed."
+
+data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), HFErrorProject (V xs1), Show (V xs2), Pretty (V xs2), HFErrorProject (V xs2)) => InstallSetError (V xs1) (V xs2)

 instance Pretty InstallSetError where
  pPrint (InstallSetError reason1 reason2) =
@@ -358,9 +671,31 @@ instance Pretty InstallSetError where

 deriving instance Show InstallSetError

+instance HFErrorProject InstallSetError where
+  eBase _ = 7000
+  -- will there be collisions?
+  eNum (InstallSetError xs1 xs2) = 7000 + eNum xs1 + eNum xs2
+  eDesc _ = "Installation or setting the tool failed."
+
+
+-- | A test failed.
+data TestFailed = forall es . (ToVariantMaybe TestFailed es, PopVariant TestFailed es, Pretty (V es), Show (V es), HFErrorProject (V es)) => TestFailed FilePath (V es)
+
+instance Pretty TestFailed where
+  pPrint (TestFailed path reason) =
+    case reason of
+      VMaybe (_ :: TestFailed) -> pPrint reason
+      _ -> text ("The test failed. GHC test suite is fragile and non-portable. Please also check out the " <> linkEscapeCode "issue tracker" " https://gitlab.haskell.org/ghc/ghc/-/issues/?sort=updated_desc&state=opened&label_name%5B%5D=testsuite&label_name%5B%5D=packaging&first_page_size=20" <> ".\nBuild dir was:") <+> text path <+> text "\nReason was:" <+> pPrint reason
+
+deriving instance Show TestFailed
+
+instance HFErrorProject TestFailed where
+  eBase _ = 4000
+  eNum (TestFailed _ xs2) = 4000 + eNum xs2
+  eDesc _ = "The test failed."

 -- | A build failed.
-data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
+data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es), HFErrorProject (V es)) => BuildFailed FilePath (V es)

 instance Pretty BuildFailed where
  pPrint (BuildFailed path reason) =
@@ -370,18 +705,28 @@ instance Pretty BuildFailed where

 deriving instance Show BuildFailed

+instance HFErrorProject BuildFailed where
+  eBase _ = 8000
+  eNum (BuildFailed _ xs2) = 8000 + eNum xs2
+  eDesc _ = "The build failed."
+

 -- | Setting the current GHC version failed.
-data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es)) => GHCupSetError (V es)
+data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es), HFErrorProject (V es)) => GHCupSetError (V es)

 instance Pretty GHCupSetError where
  pPrint (GHCupSetError reason) =
    case reason of
      VMaybe (_ :: GHCupSetError) -> pPrint reason
-      _ -> text "Setting the current GHC version failed:" <+> pPrint reason
+      _ -> text "Setting the current version failed:" <+> pPrint reason

 deriving instance Show GHCupSetError

+instance HFErrorProject GHCupSetError where
+  eBase _ = 9000
+  eNum (GHCupSetError xs) = 9000 + eNum xs
+  eDesc _ = "Setting the current version failed."
+

    ---------------------------------------------
    --[ True Exceptions (e.g. for MonadThrow) ]--
@@ -398,6 +743,10 @@ instance Pretty ParseError where

 instance Exception ParseError

+instance HFErrorProject ParseError where
+  eBase _ = 500
+  eDesc _ = "A parse error occured."
+

 data UnexpectedListLength = UnexpectedListLength String
  deriving Show
@@ -408,6 +757,10 @@ instance Pretty UnexpectedListLength where

 instance Exception UnexpectedListLength

+instance HFErrorProject UnexpectedListLength where
+  eBase _ = 510
+  eDesc _ = "A list had an unexpected length."
+
 data NoUrlBase = NoUrlBase Text
  deriving Show

@@ -417,6 +770,10 @@ instance Pretty NoUrlBase where

 instance Exception NoUrlBase

+instance HFErrorProject NoUrlBase where
+  eBase _ = 520
+  eDesc _ = "URL does not have a base filename."
+


    ------------------------
@@ -436,6 +793,23 @@ instance
         Right x -> pPrint x
         Left xs -> pPrint xs

+instance HFErrorProject (V '[]) where
+   {-# INLINABLE eBase #-}
+   eBase _ = undefined
+   {-# INLINABLE eDesc #-}
+   eDesc _ = undefined
+
+instance
+   ( HFErrorProject x
+   , HFErrorProject (V xs)
+   ) => HFErrorProject (V (x ': xs))
+   where
+      eNum v = case popVariantHead v of
+         Right x -> eNum x
+         Left xs -> eNum xs
+      eDesc _ = undefined
+      eBase _ = undefined
+
 instance Pretty URIParseError where
  pPrint (MalformedScheme reason) =
    text "Failed to parse URI. Malformed scheme:" <+> text (show reason)
@@ -454,6 +828,22 @@ instance Pretty URIParseError where
  pPrint (OtherError err) =
    text "Failed to parse URI:" <+> pPrint err

+instance HFErrorProject URIParseError where
+  eBase _ = 800
+
+  eNum (MalformedScheme NonAlphaLeading) = 801
+  eNum (MalformedScheme InvalidChars) = 802
+  eNum (MalformedScheme MissingColon) = 803
+  eNum MalformedUserInfo   = 804
+  eNum MalformedQuery      = 805
+  eNum MalformedFragment   = 806
+  eNum MalformedHost       = 807
+  eNum MalformedPort       = 808
+  eNum MalformedPath       = 809
+  eNum (OtherError _)      = 810
+
+  eDesc _ = "Failed to parse URI."
+
 instance Pretty ArchiveResult where
  pPrint ArchiveFatal = text "Archive result: fatal"
  pPrint ArchiveFailed = text "Archive result: failed"
@@ -462,5 +852,37 @@ instance Pretty ArchiveResult where
  pPrint ArchiveOk = text "Archive result: Ok"
  pPrint ArchiveEOF = text "Archive result: EOF"

+instance HFErrorProject ArchiveResult where
+  eBase _ = 820
+
+  eNum ArchiveFatal  = 821
+  eNum ArchiveFailed = 822
+  eNum ArchiveWarn   = 823
+  eNum ArchiveRetry  = 824
+  eNum ArchiveOk     = 825
+  eNum ArchiveEOF    = 826
+
+  eDesc _ = "Archive extraction result."
+
 instance Pretty T.Text where
  pPrint = text . T.unpack
+
+instance Pretty ProcessError where
+  pPrint (NonZeroExit e exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
+  pPrint (PTerminated exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
+  pPrint (PStopped exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
+  pPrint (NoSuchPid exe args) =
+    text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
+
+instance HFErrorProject ProcessError where
+  eBase _ = 840
+
+  eNum NonZeroExit{}     = 841
+  eNum (PTerminated _ _) = 842
+  eNum (PStopped _ _)    = 843
+  eNum (NoSuchPid _ _)   = 844
+
+  eDesc _ = "A process exited prematurely."
--- a/lib/GHCup/GHC.hs
+++ b/lib/GHCup/GHC.hs
@@ -86,6 +86,144 @@ data GHCVer v = SourceDist v



+    --------------------
+    --[ Tool testing ]--
+    --------------------
+
+
+
+testGHCVer :: ( MonadFail m
+              , MonadMask m
+              , MonadCatch m
+              , MonadReader env m
+              , HasDirs env
+              , HasSettings env
+              , HasPlatformReq env
+              , HasGHCupInfo env
+              , HasLog env
+              , MonadResource m
+              , MonadIO m
+              , MonadUnliftIO m
+              )
+           => Version
+           -> [T.Text]
+           -> Excepts
+                '[ DigestError
+                 , ContentLengthError
+                 , GPGError
+                 , DownloadFailed
+                 , NoDownload
+                 , ArchiveResult
+                 , TarDirDoesNotExist
+                 , UnknownArchive
+                 , TestFailed
+                 ]
+                m
+                ()
+testGHCVer ver addMakeArgs = do
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+
+  dlInfo <-
+    preview (ix GHC % ix ver % viTestDL % _Just) dls
+      ?? NoDownload
+
+  liftE $ testGHCBindist dlInfo ver addMakeArgs
+
+
+
+testGHCBindist :: ( MonadFail m
+                  , MonadMask m
+                  , MonadCatch m
+                  , MonadReader env m
+                  , HasDirs env
+                  , HasSettings env
+                  , HasPlatformReq env
+                  , HasGHCupInfo env
+                  , HasLog env
+                  , MonadResource m
+                  , MonadIO m
+                  , MonadUnliftIO m
+                  )
+               => DownloadInfo
+               -> Version
+               -> [T.Text]
+               -> Excepts
+                    '[ DigestError
+                     , ContentLengthError
+                     , GPGError
+                     , DownloadFailed
+                     , NoDownload
+                     , ArchiveResult
+                     , TarDirDoesNotExist
+                     , UnknownArchive
+                     , TestFailed
+                     ]
+                    m
+                    ()
+testGHCBindist dlinfo ver addMakeArgs = do
+  -- download (or use cached version)
+  dl <- liftE $ downloadCached dlinfo Nothing
+
+  liftE $ testPackedGHC dl (view dlSubdir dlinfo) ver addMakeArgs
+
+
+testPackedGHC :: ( MonadMask m
+                 , MonadCatch m
+                 , MonadReader env m
+                 , HasDirs env
+                 , HasPlatformReq env
+                 , HasSettings env
+                 , MonadThrow m
+                 , HasLog env
+                 , MonadIO m
+                 , MonadUnliftIO m
+                 , MonadFail m
+                 , MonadResource m
+                 )
+              => FilePath          -- ^ Path to the packed GHC bindist
+              -> Maybe TarDir      -- ^ Subdir of the archive
+              -> Version           -- ^ The GHC version
+              -> [T.Text]          -- ^ additional make args
+              -> Excepts
+                   '[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m ()
+testPackedGHC dl msubdir ver addMakeArgs = do
+  -- unpack
+  tmpUnpack <- lift mkGhcupTmpDir
+  liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
+
+  -- the subdir of the archive where we do the work
+  workdir <- maybe (pure tmpUnpack)
+                   (liftE . intoSubdir tmpUnpack)
+                   msubdir
+
+  reThrowAll @_ @'[ArchiveResult, UnknownArchive, TarDirDoesNotExist, ProcessError]
+    (TestFailed (fromGHCupPath workdir)) $ liftE $ runBuildAction tmpUnpack
+                         (testUnpackedGHC workdir ver addMakeArgs)
+
+testUnpackedGHC :: ( MonadReader env m
+                   , HasDirs env
+                   , HasSettings env
+                   , MonadThrow m
+                   , HasLog env
+                   , MonadIO m
+                   )
+                => GHCupPath         -- ^ Path to the unpacked GHC bindist (where the make file resides)
+                -> Version           -- ^ The GHC version
+                -> [T.Text]          -- ^ additional configure args for bindist
+                -> Excepts '[ProcessError] m ()
+testUnpackedGHC path ver addMakeArgs = do
+  lift $ logInfo $ "Testing GHC version " <> prettyVer ver <> "!"
+  ghcDir <- lift $ ghcupGHCDir (mkTVer ver)
+  let ghcBinDir = fromGHCupPath ghcDir </> "bin"
+  env <- liftIO $ addToPath ghcBinDir False
+
+  lEM $ make' (fmap T.unpack addMakeArgs)
+              (Just $ fromGHCupPath path)
+              "ghc-test"
+              (Just $ ("STAGE1_GHC", "ghc-" <> T.unpack (prettyVer ver)) : env)
+  pure ()
+
+
    ---------------------
    --[ Tool fetching ]--
    ---------------------
@@ -109,6 +247,7 @@ fetchGHCSrc :: ( MonadFail m
            -> Maybe FilePath
            -> Excepts
                 '[ DigestError
+                  , ContentLengthError
                  , GPGError
                  , DownloadFailed
                  , NoDownload
@@ -152,6 +291,7 @@ installGHCBindist :: ( MonadFail m
                       '[ AlreadyInstalled
                        , BuildFailed
                        , DigestError
+                        , ContentLengthError
                        , GPGError
                        , DownloadFailed
                        , NoDownload
@@ -357,6 +497,7 @@ installGHCBin :: ( MonadFail m
                   '[ AlreadyInstalled
                    , BuildFailed
                    , DigestError
+                    , ContentLengthError
                    , GPGError
                    , DownloadFailed
                    , NoDownload
@@ -456,7 +597,7 @@ setGHC ver sghc mBinDir = do
      when (targetFile == "ghc") $
        liftIO (isShadowed fullF) >>= \case
          Nothing -> pure ()
-          Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHC pa fullF (_tvVersion ver))
+          Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed GHC pa fullF (_tvVersion ver))

  when (isNothing mBinDir) $ do
    -- create symlink for share dir
@@ -628,6 +769,7 @@ compileGHC :: ( MonadMask m
                '[ AlreadyInstalled
                 , BuildFailed
                 , DigestError
+                 , ContentLengthError
                 , GPGError
                 , DownloadFailed
                 , GHCupSetError
@@ -684,7 +826,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
        -- download source tarball
        tmpDownload <- lift withGHCupTmpDir
        tmpUnpack <- lift mkGhcupTmpDir
-        tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
+        tar <- liftE $ download uri Nothing Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
        (bf, tver) <- liftE $ cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError] tmpUnpack $ do
          liftE $ unpackToDir (fromGHCupPath tmpUnpack) tar
          let regex = [s|^(.*/)*boot$|] :: B.ByteString
@@ -706,7 +848,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
      GitDist GitBranch{..} -> do
        tmpUnpack <- lift mkGhcupTmpDir
        let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
-        tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do
+        tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do
          let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
          lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
          lEM $ git [ "init" ]
@@ -716,7 +858,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
                    , fromString rep ]

          -- figure out if we can do a shallow clone
-          remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure [])
+          remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure [])
              $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)
          let shallow_clone
                | isCommitHash ref                     = True
--- a/lib/GHCup/HLS.hs
+++ b/lib/GHCup/HLS.hs
@@ -68,7 +68,6 @@ import qualified Data.List.NonEmpty            as NE
 import qualified Data.ByteString               as B
 import qualified Data.Text                     as T
 import qualified Text.Megaparsec               as MP
-import Text.PrettyPrint.HughesPJClass (prettyShow)


 data HLSVer = SourceDist Version
@@ -105,6 +104,7 @@ installHLSBindist :: ( MonadMask m
                       '[ AlreadyInstalled
                        , CopyError
                        , DigestError
+                        , ContentLengthError
                        , GPGError
                        , DownloadFailed
                        , NoDownload
@@ -297,6 +297,7 @@ installHLSBin :: ( MonadMask m
                   '[ AlreadyInstalled
                    , CopyError
                    , DigestError
+                    , ContentLengthError
                    , GPGError
                    , DownloadFailed
                    , NoDownload
@@ -344,6 +345,7 @@ compileHLS :: ( MonadMask m
                       , GPGError
                       , DownloadFailed
                       , DigestError
+                       , ContentLengthError
                       , UnknownArchive
                       , TarDirDoesNotExist
                       , ArchiveResult
@@ -401,7 +403,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
      -- download source tarball
      tmpDownload <- lift withGHCupTmpDir
      tmpUnpack <- lift mkGhcupTmpDir
-      tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
+      tar <- liftE $ download uri Nothing Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
      (cf, tver) <- liftE $ cleanUpOnError tmpUnpack $ do
        unpackToDir (fromGHCupPath tmpUnpack) tar
        let regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString
@@ -481,7 +483,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda

  liftE $ runBuildAction
    tmpUnpack
-    (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
+    (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, ContentLengthError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
      let tmpInstallDir = fromGHCupPath workdir </> "out"
      liftIO $ createDirRecursive' tmpInstallDir

@@ -497,7 +499,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
          | otherwise -> pure (takeFileName cp)
        Just (Right uri) -> do
          tmpUnpack' <- lift withGHCupTmpDir
-          cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False
+          cp <- liftE $ download uri Nothing Nothing Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False
          copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
          pure "cabal.project"
        Nothing
@@ -511,7 +513,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
          | otherwise -> pure "cabal.project"
      forM_ cabalProjectLocal $ \uri -> do
        tmpUnpack' <- lift withGHCupTmpDir
-        cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just (cp <.> "local")) False
+        cpl <- liftE $ download uri Nothing Nothing Nothing (fromGHCupPath tmpUnpack') (Just (cp <.> "local")) False
        copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False
      artifacts <- forM (sort ghcs) $ \ghc -> do
        let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
@@ -631,7 +633,7 @@ setHLS ver shls mBinDir = do

      liftIO (isShadowed wrapper) >>= \case
        Nothing -> pure ()
-        Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed HLS pa wrapper ver)
+        Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed HLS pa wrapper ver)


 unsetHLS :: ( MonadMask m
--- a/lib/GHCup/Prelude.hs
+++ b/lib/GHCup/Prelude.hs
@@ -41,24 +41,26 @@ import GHCup.Prelude.Posix
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Haskus.Utils.Variant.Excepts
-import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
+import           Text.PrettyPrint.HughesPJClass ( Pretty )
 import qualified Data.Text                     as T



 -- for some obscure reason... this won't type-check if we move it to a different module
 catchWarn :: forall es m env . ( Pretty (V es)
+                             , HFErrorProject (V es)
                             , MonadReader env m
                             , HasLog env
                             , MonadIO m
                             , Monad m) => Excepts es m () -> Excepts '[] m ()
-catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
+catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyHFError $ v))


 runBothE' :: forall e m a b .
             ( Monad m
             , Show (V e)
             , Pretty (V e)
+             , HFErrorProject (V e)
             , PopVariant InstallSetError e
             , LiftVariant' e (InstallSetError ': e)
             , e :<< (InstallSetError ': e)
--- a/lib/GHCup/Prelude/File/Posix.hs
+++ b/lib/GHCup/Prelude/File/Posix.hs
@@ -48,6 +48,7 @@ import           Streamly.Internal.Data.Unfold.Type
 import qualified Streamly.Internal.Data.Unfold as U
 import           Streamly.Internal.Control.Concurrent ( withRunInIO )
 import           Streamly.Internal.Data.IOFinalizer   ( newIOFinalizer, runIOFinalizer )
+import GHC.IO.Exception (IOException(ioe_type), IOErrorType (..))


 -- | On unix, we can use symlinks, so we just get the
@@ -116,8 +117,18 @@ copyFile from to fail' = do
        let dflags = [ FD.oNofollow
                     , if fail' then FD.oExcl else FD.oTrunc
                     ]
+        let openFdHandle' = openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode
        bracket
-          (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode)
+          (handleIO (\e -> if
+                              -- if we copy from regular file to symlink, we need
+                              -- to delete the symlink
+                              | ioe_type e == InvalidArgument
+                              , not fail' -> do
+                                 removeLink to
+                                 openFdHandle'
+                              | otherwise -> throwIO e
+                    )
+            openFdHandle')
          (hClose . snd)
          $ \(_, tH) -> do
              hSetBinaryMode fH True
--- a/lib/GHCup/Stack.hs
+++ b/lib/GHCup/Stack.hs
@@ -50,7 +50,6 @@ import           System.FilePath
 import           System.IO.Error

 import qualified Data.Text                     as T
-import Text.PrettyPrint.HughesPJClass (prettyShow)



@@ -82,6 +81,7 @@ installStackBin :: ( MonadMask m
                     '[ AlreadyInstalled
                      , CopyError
                      , DigestError
+                      , ContentLengthError
                      , GPGError
                      , DownloadFailed
                      , NoDownload
@@ -120,6 +120,7 @@ installStackBindist :: ( MonadMask m
                         '[ AlreadyInstalled
                          , CopyError
                          , DigestError
+                          , ContentLengthError
                          , GPGError
                          , DownloadFailed
                          , NoDownload
@@ -232,7 +233,7 @@ setStack ver = do

  liftIO (isShadowed stackbin) >>= \case
    Nothing -> pure ()
-    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa stackbin ver)
+    Just pa -> lift $ logWarn $ T.pack $ prettyHFError (ToolShadowed Cabal pa stackbin ver)

  pure ()

--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -35,7 +35,7 @@ import           Data.Text                      ( Text )
 import           Data.Versions
 import           GHC.IO.Exception               ( ExitCode )
 import           Optics                         ( makeLenses )
-import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text, (<+>))
+import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
 import           URI.ByteString
 #if defined(BRICK)
 import           Graphics.Vty                   ( Key(..) )
@@ -138,6 +138,7 @@ data VersionInfo = VersionInfo
  { _viTags        :: [Tag]              -- ^ version specific tag
  , _viChangeLog   :: Maybe URI
  , _viSourceDL    :: Maybe DownloadInfo -- ^ source tarball
+  , _viTestDL      :: Maybe DownloadInfo -- ^ test tarball
  , _viArch        :: ArchitectureSpec   -- ^ descend for binary downloads per arch
  -- informative messages
  , _viPostInstall :: Maybe Text
@@ -262,6 +263,7 @@ data DownloadInfo = DownloadInfo
  { _dlUri    :: URI
  , _dlSubdir :: Maybe TarDir
  , _dlHash   :: Text
+  , _dlCSize  :: Maybe Integer
  }
  deriving (Eq, Ord, GHC.Generic, Show)

@@ -631,15 +633,7 @@ data ProcessError = NonZeroExit Int FilePath [String]
                  | NoSuchPid FilePath [String]
                  deriving Show

-instance Pretty ProcessError where
-  pPrint (NonZeroExit e exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
-  pPrint (PTerminated exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
-  pPrint (PStopped exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
-  pPrint (NoSuchPid exe args) =
-    text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
+
 data CapturedProcess = CapturedProcess
  { _exitCode :: ExitCode
  , _stdOut   :: BL.ByteString
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@@ -93,6 +93,7 @@ import qualified Data.List.NonEmpty            as NE
 import qualified Streamly.Prelude              as S
 import Control.DeepSeq (force)
 import GHC.IO (evaluate)
+import System.Environment (getEnvironment, setEnv)


 -- $setup
@@ -967,11 +968,28 @@ make :: ( MonadThrow m
     => [String]
     -> Maybe FilePath
     -> m (Either ProcessError ())
-make args workdir = do
+make args workdir = make' args workdir "ghc-make" Nothing
+
+
+-- | Calls gmake if it exists in PATH, otherwise make.
+make' :: ( MonadThrow m
+         , MonadIO m
+         , MonadReader env m
+         , HasDirs env
+         , HasLog env
+         , HasSettings env
+         )
+      => [String]
+      -> Maybe FilePath
+      -> FilePath         -- ^ log filename (opened in append mode)
+      -> Maybe [(String, String)] -- ^ optional environment
+      -> m (Either ProcessError ())
+make' args workdir logfile menv = do
  spaths    <- liftIO getSearchPath
  has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
  let mymake = if has_gmake then "gmake" else "make"
-  execLogged mymake args workdir "ghc-make" Nothing
+  execLogged mymake args workdir logfile menv
+

 makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
        => [String]
@@ -1035,13 +1053,13 @@ applyAnyPatch :: ( MonadReader env m
                 , MonadIO m)
              => Maybe (Either FilePath [URI])
              -> FilePath
-              -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
+              -> Excepts '[PatchFailed, DownloadFailed, DigestError, ContentLengthError, GPGError] m ()
 applyAnyPatch Nothing _                   = pure ()
 applyAnyPatch (Just (Left pdir)) workdir  = liftE $ applyPatches pdir workdir
 applyAnyPatch (Just (Right uris)) workdir = do
  tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir
  forM_ uris $ \uri -> do
-    patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
+    patch <- liftE $ download uri Nothing Nothing Nothing tmpUnpack Nothing False
    liftE $ applyPatch patch workdir


@@ -1172,7 +1190,7 @@ ensureGlobalTools :: ( MonadMask m
                     , MonadUnliftIO m
                     , MonadFail m
                     )
-                  => Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
+                  => Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m ()
 ensureGlobalTools
  | isWindows = do
      (GHCupInfo _ _ gTools) <- lift getGHCupInfo
@@ -1184,8 +1202,8 @@ ensureGlobalTools
          lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
          lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) </> "gs.exe"))
          lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe")
-          liftE @'[GPGError, DigestError , DownloadFailed] $ dl
-        ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
+          liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] $ dl
+        ) `catchE` liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] dl
  | otherwise = pure ()


@@ -1282,6 +1300,22 @@ warnAboutHlsCompatibility = do



+addToPath :: FilePath
+          -> Bool         -- ^ if False will prepend
+          -> IO [(String, String)]
+addToPath path append = do
+ cEnv <- Map.fromList <$> getEnvironment
+ let paths          = ["PATH", "Path"]
+     curPaths       = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
+     {- HLINT ignore "Redundant bracket" -}
+     newPath        = intercalate [searchPathSeparator] (if append then (curPaths ++ [path]) else (path : curPaths))
+     envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
+     pathVar        = if isWindows then "Path" else "PATH"
+     envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
+ liftIO $ setEnv pathVar newPath
+ return envWithNewPath
+
+
    -----------
    --[ Git ]--
    -----------
@@ -1301,7 +1335,7 @@ gitOut args dir = do
    ExitSuccess   -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut
    ExitFailure c -> do
      let pe = NonZeroExit c "git" args
-      lift $ logDebug $ T.pack (prettyShow pe)
+      lift $ logDebug $ T.pack (prettyHFError pe)
      throwE pe

 processBranches :: T.Text -> [String]
--- a/lib/GHCup/Utils/Dirs.hs
+++ b/lib/GHCup/Utils/Dirs.hs
@@ -465,15 +465,22 @@ withGHCupTmpDir :: ( MonadReader env m
                   , MonadMask m
                   , MonadIO m)
                => m GHCupPath
-withGHCupTmpDir = snd <$> withRunInIO (\run ->
-  run
-    $ allocate
-        (run mkGhcupTmpDir)
-        (\fp ->
-            handleIO (\e -> run
-                $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
-            . removePathForcibly
-            $ fp))
+withGHCupTmpDir = do
+  Settings{keepDirs} <- getSettings
+  snd <$> withRunInIO (\run ->
+    run
+      $ allocate
+          (run mkGhcupTmpDir)
+          (\fp -> if -- we don't know whether there was a failure, so can only
+                     -- decide for 'Always'
+                     | keepDirs == Always -> pure ()
+                     | otherwise -> handleIO (\e -> run
+                        $ logDebug ("Resource cleanup failed for "
+                                   <> T.pack (fromGHCupPath fp)
+                                   <> ", error was: "
+                                   <> T.pack (displayException e)))
+                        . removePathForcibly
+                        $ fp))



--- a/test/golden/unix/GHCupInfo.json
+++ b/test/golden/unix/GHCupInfo.json
--- a/test/golden/windows/GHCupInfo.json
+++ b/test/golden/windows/GHCupInfo.json
Author	SHA1	Message	Date
Julian Ospald	1e32639873	Implement 'ghcup test ghc' based on the bindist testsuite	2023-01-12 12:58:10 +08:00
Julian Ospald	54af66d115	Merge branch 'HF-errors'	2023-01-05 21:39:23 +08:00
Julian Ospald	850799c21a	Merge remote-tracking branch 'origin/pr/739'	2023-01-05 21:32:07 +08:00
Julian Ospald	d4834d7541	Update docs/about.md Co-authored-by: tomjaguarpaw <tom-github.com@jaguarpaw.co.uk>	2023-01-05 07:32:51 +08:00
Julian Ospald	2895dd9d13	Bump cabal-cache with amazonka patch	2023-01-04 21:08:10 +08:00
Julian Ospald	eb9a0b66c4	Document distribution policies	2023-01-04 18:51:40 +08:00
Julian Ospald	8d0432b961	Make sure FreeBSD runner uses GMT This should fix parsing issues in amazonka and cabal-cache: * https://github.com/haskell-works/cabal-cache/issues/207 * https://github.com/brendanhay/amazonka/issues/866	2023-01-04 16:56:07 +08:00
Julian Ospald	ab2c01d1c9	Don't install stack by default in CI	2023-01-04 16:50:55 +08:00
Julian Ospald	4be97ffd7c	Pad and use hyperlinks	2023-01-03 23:43:46 +08:00
Julian Ospald	009f9211a9	Integrate with errors.haskell.org Fixes #434	2023-01-03 23:43:46 +08:00
Julian Ospald	109187eb6f	Merge branch 'issue-367-content-prop'	2023-01-03 23:17:35 +08:00
Julian Ospald	e881705323	Merge branch 'issue-440'	2023-01-03 22:47:12 +08:00
Julian Ospald	ea06c155a7	Merge branch 'issue-695'	2023-01-03 22:46:52 +08:00
Julian Ospald	d4732e15a7	Merge branch 'issue-716'	2023-01-03 22:46:13 +08:00
Julian Ospald	db6f784a1f	Merge branch 'error-handling'	2023-01-03 22:45:25 +08:00
Julian Ospald	82e3837dd9	Update windows golden test file	2023-01-02 21:42:52 +08:00
Julian Ospald	957c5918b8	Upload golden files on failure	2023-01-02 20:47:49 +08:00
Julian Ospald	9d4c923649	Add content-length property to downloads This is optional for now. Fixes #367	2023-01-02 20:41:42 +08:00
Julian Ospald	24c36ef856	Fix failure with --isolate=dir --force Fixes #695	2023-01-02 20:39:27 +08:00
Julian Ospald	2783b8f693	Fix 'ghcup install hls -u' on windows Fixes #716	2023-01-02 20:38:58 +08:00
Julian Ospald	d5a680e3c6	Don't clean up tmp dirs when --keep=always	2023-01-02 20:38:26 +08:00
Julian Ospald	d1075987de	Fix ARM cleanup	2023-01-02 20:35:46 +08:00