Don't clean up tmp dirs when --keep=always

.github/workflows/release.yaml

@@ -272,14 +272,6 @@ 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"
@@ -339,14 +331,6 @@ 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"
@@ -393,22 +377,6 @@ 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

app/ghcup/BrickMain.hs

@@ -434,7 +434,6 @@ install' _ (_, ListResult {..}) = do
               , BuildFailed
               , TagNotFound
               , DigestError
-              , ContentLengthError
               , GPGError
               , DownloadFailed
               , DirNotEmpty
@@ -633,7 +632,7 @@ getGHCupInfo = do
 
   r <-
     flip runReaderT settings
-    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
+    . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
     $ liftE getDownloadsF
 
   case r of

app/ghcup/GHCup/OptParse/Compile.hs

@@ -420,7 +420,6 @@ hlsCompileOpts =
 type GHCEffects = '[ AlreadyInstalled
                   , BuildFailed
                   , DigestError
-                  , ContentLengthError
                   , GPGError
                   , DownloadFailed
                   , GHCupSetError
@@ -444,7 +443,6 @@ type GHCEffects = '[ AlreadyInstalled
 type HLSEffects = '[ AlreadyInstalled
                   , BuildFailed
                   , DigestError
-                  , ContentLengthError
                   , GPGError
                   , DownloadFailed
                   , GHCupSetError

app/ghcup/GHCup/OptParse/Install.hs

@@ -243,7 +243,6 @@ type InstallEffects = '[ AlreadyInstalled
                        , BuildFailed
                        , TagNotFound
                        , DigestError
-                       , ContentLengthError
                        , GPGError
                        , DownloadFailed
                        , TarDirDoesNotExist
@@ -272,7 +271,6 @@ type InstallGHCEffects = '[ AlreadyInstalled
                           , BuildFailed
                           , CopyError
                           , DigestError
-                          , ContentLengthError
                           , DirNotEmpty
                           , DownloadFailed
                           , FileAlreadyExistsError
@@ -334,7 +332,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-.*") "" Nothing)
+                       (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
                        (_tvVersion v)
                        (maybe GHCupInternal IsolateDir isolateDir)
                        forceInstall
@@ -404,7 +402,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 "" Nothing)
+                                      (DownloadInfo uri Nothing "")
                                       v
                                       (maybe GHCupInternal IsolateDir isolateDir)
                                       forceInstall
@@ -454,7 +452,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-*") "" Nothing)
+                                      (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
                                       v
                                       (maybe GHCupInternal IsolateDir isolateDir)
                                       forceInstall
@@ -503,7 +501,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 "" Nothing)
+                                       (DownloadInfo uri Nothing "")
                                        v
                                        (maybe GHCupInternal IsolateDir isolateDir)
                                        forceInstall

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -153,7 +153,6 @@ type PrefetchEffects = '[ TagNotFound
                         , NoToolVersionSet
                         , NoDownload
                         , DigestError
-                        , ContentLengthError
                         , GPGError
                         , DownloadFailed
                         , JSONError

app/ghcup/GHCup/OptParse/Run.hs

@@ -177,7 +177,6 @@ type RunEffects = '[ AlreadyInstalled
                    , BuildFailed
                    , TagNotFound
                    , DigestError
-                   , ContentLengthError
                    , GPGError
                    , DownloadFailed
                    , TarDirDoesNotExist
@@ -344,7 +343,6 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                               , DownloadFailed
                               , DirNotEmpty
                               , DigestError
-                              , ContentLengthError
                               , BuildFailed
                               , ArchiveResult
                               , AlreadyInstalled

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -88,7 +88,6 @@ upgradeOptsP =
 
 
 type UpgradeEffects = '[ DigestError
-                       , ContentLengthError
                        , GPGError
                        , NoDownload
                        , NoUpdate

app/ghcup/Main.hs

@@ -210,7 +210,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
 
                 ghcupInfo <-
                   ( flip runReaderT leanAppstate
-                    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
+                    . runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
                     $ liftE getDownloadsF
                     )
                     >>= \case

lib/GHCup.hs

@@ -106,7 +106,6 @@ fetchToolBindist :: ( MonadFail m
                  -> Maybe FilePath
                  -> Excepts
                       '[ DigestError
-                       , ContentLengthError
                        , GPGError
                        , DownloadFailed
                        , NoDownload
@@ -289,7 +288,6 @@ upgradeGHCup :: ( MonadMask m
              -> Excepts
                   '[ CopyError
                    , DigestError
-                   , ContentLengthError
                    , GPGError
                    , GPGError
                    , DownloadFailed
@@ -310,7 +308,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)) (_dlCSize dli) tmp (Just fn) False
+  p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False
   let destDir = takeDirectory destFile
       destFile = fromMaybe (binDir </> fn) mtarget
   lift $ logDebug $ "mkdir -p " <> T.pack destDir

lib/GHCup/Cabal.hs

@@ -81,7 +81,6 @@ installCabalBindist :: ( MonadMask m
                          '[ AlreadyInstalled
                           , CopyError
                           , DigestError
-                          , ContentLengthError
                           , GPGError
                           , DownloadFailed
                           , NoDownload
@@ -185,7 +184,6 @@ installCabalBin :: ( MonadMask m
                      '[ AlreadyInstalled
                       , CopyError
                       , DigestError
-                      , ContentLengthError
                       , GPGError
                       , DownloadFailed
                       , NoDownload

lib/GHCup/Download.hs

@@ -114,7 +114,7 @@ getDownloadsF :: ( FromJSONKey Tool
                  , MonadMask m
                  )
               => Excepts
-                   '[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
+                   '[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
                    m
                    GHCupInfo
 getDownloadsF = do
@@ -162,7 +162,7 @@ getBase :: ( MonadReader env m
            , MonadMask m
            )
         => URI
-        -> Excepts '[GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo
+        -> Excepts '[GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo
 getBase uri = do
   Settings { noNetwork, downloader } <- lift getSettings
 
@@ -229,7 +229,6 @@ getBase uri = do
           -> Excepts
                '[ DownloadFailed
                 , DigestError
-                , ContentLengthError
                 , GPGError
                 ]
                m1
@@ -243,7 +242,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 Nothing (fromGHCupPath cacheDir) Nothing True
+    if | scheme == "file" -> liftE $ download uri' Nothing Nothing (fromGHCupPath cacheDir) Nothing True
        | e -> do
           accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
           let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@@ -259,7 +258,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 Nothing dir (Just fn) True
+      f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing dir (Just fn) True
       liftIO $ setModificationTime f modTime
       liftIO $ setAccessTime f modTime
       pure f
@@ -325,18 +324,16 @@ 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, ContentLengthError, DownloadFailed, GPGError] m FilePath
+         -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
-download uri gpgUri eDigest eCSize dest mfn etags
+download uri gpgUri eDigest dest mfn etags
-  | scheme == "https" = liftE dl
+  | scheme == "https" = dl
-  | scheme == "http"  = liftE dl
+  | scheme == "http"  = dl
   | scheme == "file"  = do
       let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
       lift $ logDebug $ "using local file: " <> T.pack destFile'
-      forM_ eCSize  (liftE . flip checkCSize  destFile')
       forM_ eDigest (liftE . flip checkDigest destFile')
       pure destFile'
   | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
@@ -354,7 +351,7 @@ download uri gpgUri eDigest eCSize dest mfn etags
     -- download
     flip onException
          (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile))
-     $ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError, ContentLengthError] @'[DigestError, ContentLengthError, DownloadFailed, GPGError]
+     $ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError] @'[DigestError, DownloadFailed, GPGError]
           (\e' -> do
             lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile)
             case e' of
@@ -404,37 +401,19 @@ download uri gpgUri eDigest eCSize 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
+  curlDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] 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']
+        (o' ++ ["-fL", "-o", destFileTemp, T.unpack uri']) Nothing Nothing
-            ++ maybe [] (\s -> ["--max-filesize", show s]) eCSize
-        ) Nothing Nothing
       liftIO $ renameFile destFileTemp destFile
 
-  curlEtagsDL :: ( MonadReader env m
+  curlEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
-                 , HasLog env
+              => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
-                 , 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 +423,6 @@ download uri gpgUri eDigest eCSize dest mfn etags
         liftE $ lEM @_ @'[ProcessError] $ exec "curl"
             (o' ++ (if etags then ["--dump-header", dh] else [])
                 ++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
-                ++ maybe [] (\s -> ["--max-file-size", show s]) eCSize
                 ++ ["-fL", "-o", destFileTemp, T.unpack uri']) Nothing Nothing
         headers <- liftIO $ T.readFile dh
 
@@ -462,14 +440,7 @@ download uri gpgUri eDigest eCSize dest mfn etags
 
         lift $ writeEtags destFile (parseEtags headers)
 
-  wgetDL :: ( MonadCatch m
+  wgetDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] 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
@@ -478,12 +449,7 @@ download uri gpgUri eDigest eCSize dest mfn etags
       liftIO $ renameFile destFileTemp destFile
 
 
-  wgetEtagsDL :: ( MonadReader env m
+  wgetEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO 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
@@ -505,10 +471,7 @@ download uri gpgUri eDigest eCSize dest mfn etags
           | otherwise -> throwE (NonZeroExit i' "wget" opts)
 
 #if defined(INTERNAL_DOWNLOADER)
-  internalDL :: ( MonadCatch m
+  internalDL :: (MonadCatch m, MonadMask m, MonadIO m)
-                , MonadMask m
-                , MonadIO m
-                )
              => FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
   internalDL destFile uri' = do
     let destFileTemp = tmpFile destFile
@@ -518,16 +481,11 @@ download uri gpgUri eDigest eCSize dest mfn etags
                  @'[DownloadFailed]
             (\e@(HTTPNotModified _) ->
               throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
-        $ downloadToFile https host fullPath port destFileTemp mempty eCSize
+        $ downloadToFile https host fullPath port destFileTemp mempty
       liftIO $ renameFile destFileTemp destFile
 
 
-  internalEtagsDL :: ( MonadReader env m
+  internalEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
-                     , HasLog env
-                     , MonadCatch m
-                     , MonadMask m
-                     , MonadIO m
-                     )
                   => FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
   internalEtagsDL destFile uri' = do
     let destFileTemp = tmpFile destFile
@@ -539,7 +497,7 @@ download uri gpgUri eDigest eCSize dest mfn etags
       liftE
         $ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
         $ do
-          r <- downloadToFile https host fullPath port destFileTemp addHeaders eCSize
+          r <- downloadToFile https host fullPath port destFileTemp addHeaders
           liftIO $ renameFile destFileTemp destFile
           lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
 #endif
@@ -616,14 +574,14 @@ downloadCached :: ( MonadReader env m
                   )
                => DownloadInfo
                -> Maybe FilePath  -- ^ optional filename
-               -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
+               -> Excepts '[DigestError , 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)) (_dlCSize dli) (fromGHCupPath tmp) mfn False
+      liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False
 
 
 downloadCached' :: ( MonadReader env m
@@ -638,7 +596,7 @@ downloadCached' :: ( MonadReader env m
                 => DownloadInfo
                 -> Maybe FilePath  -- ^ optional filename
                 -> Maybe FilePath  -- ^ optional destination dir (default: cacheDir)
-                -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
+                -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
 downloadCached' dli mfn mDestDir = do
   Dirs { cacheDir } <- lift getDirs
   let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
@@ -647,10 +605,9 @@ 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)) (_dlCSize dli) destDir mfn False
+    | otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) destDir mfn False
 
 
 
@@ -681,25 +638,6 @@ 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]

lib/GHCup/Download/IOStreams.hs

@@ -17,12 +17,14 @@ 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
@@ -31,6 +33,7 @@ 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
 
@@ -43,6 +46,27 @@ 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?
@@ -51,9 +75,8 @@ 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 eCSize = do
+downloadToFile https host fullPath port destFile addHeaders = do
   let stepper = BS.appendFile destFile
       setup = BS.writeFile destFile mempty
   catchAllE (\case
@@ -61,7 +84,7 @@ downloadToFile https host fullPath port destFile addHeaders eCSize = 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 eCSize
+            ) $ downloadInternal True https host fullPath port stepper setup addHeaders
 
 
 downloadInternal :: MonadIO m
@@ -73,21 +96,19 @@ 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 eCSize = do
+  go redirs progressBar https host path port consumer setup addHeaders = do
     r <- liftIO $ withConnection' https host port action
     veitherToExcepts r >>= \case
       Right r' ->
@@ -117,39 +138,25 @@ 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 eCSize
+        go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders
       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  _       -> Nothing
+              Left  _       -> 0
-              Right (r', _) -> Just r'
+              Right (r', _) -> r'
-            Nothing -> Nothing
+            Nothing -> 0
 
-      forM_ size $ \s -> forM_ eCSize $ \es -> when (es /= s) $ throwIO (ContentLengthError Nothing (Just s) es)
+      (mpb :: Maybe (ProgressBar ())) <- if progressBar
-      let size' = eCSize <|> size
+        then Just <$> newProgressBar defStyle 10 (Progress 0 size ())
-
+        else pure Nothing
-      (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
-            let len = BS.length bs
+            forM_ mpb $ \pb -> incProgress pb (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 ()
         )

lib/GHCup/Errors.hs

@@ -219,29 +219,6 @@ 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 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
-
 -- | File digest verification failed.
 data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)
 

lib/GHCup/GHC.hs

@@ -109,7 +109,6 @@ fetchGHCSrc :: ( MonadFail m
             -> Maybe FilePath
             -> Excepts
                  '[ DigestError
-                  , ContentLengthError
                   , GPGError
                   , DownloadFailed
                   , NoDownload
@@ -153,7 +152,6 @@ installGHCBindist :: ( MonadFail m
                        '[ AlreadyInstalled
                         , BuildFailed
                         , DigestError
-                        , ContentLengthError
                         , GPGError
                         , DownloadFailed
                         , NoDownload
@@ -359,7 +357,6 @@ installGHCBin :: ( MonadFail m
                    '[ AlreadyInstalled
                     , BuildFailed
                     , DigestError
-                    , ContentLengthError
                     , GPGError
                     , DownloadFailed
                     , NoDownload
@@ -631,7 +628,6 @@ compileGHC :: ( MonadMask m
                 '[ AlreadyInstalled
                  , BuildFailed
                  , DigestError
-                 , ContentLengthError
                  , GPGError
                  , DownloadFailed
                  , GHCupSetError
@@ -688,7 +684,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 Nothing (fromGHCupPath tmpDownload) Nothing False
+        tar <- liftE $ download uri 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
@@ -710,7 +706,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, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do
+        tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, 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" ]
@@ -720,7 +716,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, ContentLengthError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure [])
+          remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure [])
               $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)
           let shallow_clone
                 | isCommitHash ref                     = True

lib/GHCup/HLS.hs

@@ -105,7 +105,6 @@ installHLSBindist :: ( MonadMask m
                        '[ AlreadyInstalled
                         , CopyError
                         , DigestError
-                        , ContentLengthError
                         , GPGError
                         , DownloadFailed
                         , NoDownload
@@ -298,7 +297,6 @@ installHLSBin :: ( MonadMask m
                    '[ AlreadyInstalled
                     , CopyError
                     , DigestError
-                    , ContentLengthError
                     , GPGError
                     , DownloadFailed
                     , NoDownload
@@ -346,7 +344,6 @@ compileHLS :: ( MonadMask m
                        , GPGError
                        , DownloadFailed
                        , DigestError
-                       , ContentLengthError
                        , UnknownArchive
                        , TarDirDoesNotExist
                        , ArchiveResult
@@ -404,7 +401,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 Nothing (fromGHCupPath tmpDownload) Nothing False
+      tar <- liftE $ download uri 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
@@ -484,7 +481,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
 
   liftE $ runBuildAction
     tmpUnpack
-    (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, ContentLengthError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
+    (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
       let tmpInstallDir = fromGHCupPath workdir </> "out"
       liftIO $ createDirRecursive' tmpInstallDir
 
@@ -500,7 +497,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 Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False
+          cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False
           copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
           pure "cabal.project"
         Nothing
@@ -514,7 +511,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 Nothing (fromGHCupPath tmpUnpack') (Just (cp <.> "local")) False
+        cpl <- liftE $ download uri 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)

lib/GHCup/Stack.hs

@@ -82,7 +82,6 @@ installStackBin :: ( MonadMask m
                      '[ AlreadyInstalled
                       , CopyError
                       , DigestError
-                      , ContentLengthError
                       , GPGError
                       , DownloadFailed
                       , NoDownload
@@ -121,7 +120,6 @@ installStackBindist :: ( MonadMask m
                          '[ AlreadyInstalled
                           , CopyError
                           , DigestError
-                          , ContentLengthError
                           , GPGError
                           , DownloadFailed
                           , NoDownload

lib/GHCup/Types.hs

@@ -262,7 +262,6 @@ data DownloadInfo = DownloadInfo
   { _dlUri    :: URI
   , _dlSubdir :: Maybe TarDir
   , _dlHash   :: Text
-  , _dlCSize  :: Maybe Integer
   }
   deriving (Eq, Ord, GHC.Generic, Show)
 

lib/GHCup/Utils.hs

@@ -1035,13 +1035,13 @@ applyAnyPatch :: ( MonadReader env m
                  , MonadIO m)
               => Maybe (Either FilePath [URI])
               -> FilePath
-              -> Excepts '[PatchFailed, DownloadFailed, DigestError, ContentLengthError, GPGError] m ()
+              -> Excepts '[PatchFailed, DownloadFailed, DigestError, 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 Nothing tmpUnpack Nothing False
+    patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
     liftE $ applyPatch patch workdir
 
 
@@ -1172,7 +1172,7 @@ ensureGlobalTools :: ( MonadMask m
                      , MonadUnliftIO m
                      , MonadFail m
                      )
-                  => Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m ()
+                  => Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
 ensureGlobalTools
   | isWindows = do
       (GHCupInfo _ _ gTools) <- lift getGHCupInfo
@@ -1184,8 +1184,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, ContentLengthError, DownloadFailed] $ dl
+          liftE @'[GPGError, DigestError , DownloadFailed] $ dl
-        ) `catchE` liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] dl
+        ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
   | otherwise = pure ()
 
 

lib/GHCup/Utils/Dirs.hs

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