Add content-length property to downloads

This is optional for now. Fixes #367
2022-12-22 00:31:41 +08:00 · 2022-12-22 00:31:41 +08:00 · 9d4c923649
commit 9d4c923649
parent d1075987de
19 changed files with 3043 additions and 79 deletions
--- a/app/ghcup/BrickMain.hs
+++ b/app/ghcup/BrickMain.hs
@ -434,6 +434,7 @@ install' _ (_, ListResult {..}) = do
              , BuildFailed
              , TagNotFound
              , DigestError
+              , ContentLengthError
              , GPGError
              , DownloadFailed
              , DirNotEmpty
@ -632,7 +633,7 @@ getGHCupInfo = do

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

  case r of
--- a/app/ghcup/GHCup/OptParse/Compile.hs
+++ b/app/ghcup/GHCup/OptParse/Compile.hs
@ -420,6 +420,7 @@ hlsCompileOpts =
 type GHCEffects = '[ AlreadyInstalled
                  , BuildFailed
                  , DigestError
+                  , ContentLengthError
                  , GPGError
                  , DownloadFailed
                  , GHCupSetError
@ -443,6 +444,7 @@ type GHCEffects = '[ AlreadyInstalled
 type HLSEffects = '[ AlreadyInstalled
                  , BuildFailed
                  , DigestError
+                  , ContentLengthError
                  , GPGError
                  , DownloadFailed
                  , GHCupSetError
--- a/app/ghcup/GHCup/OptParse/Install.hs
+++ b/app/ghcup/GHCup/OptParse/Install.hs
@ -243,6 +243,7 @@ type InstallEffects = '[ AlreadyInstalled
                       , BuildFailed
                       , TagNotFound
                       , DigestError
+                       , ContentLengthError
                       , GPGError
                       , DownloadFailed
                       , TarDirDoesNotExist
@ -271,6 +272,7 @@ type InstallGHCEffects = '[ AlreadyInstalled
                          , BuildFailed
                          , CopyError
                          , DigestError
+                          , ContentLengthError
                          , DirNotEmpty
                          , DownloadFailed
                          , FileAlreadyExistsError
@ -332,7 +334,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
@ -402,7 +404,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
@ -452,7 +454,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 (Just $ RegexDir "haskell-language-server-*") "" Nothing)
                                      v
                                      (maybe GHCupInternal IsolateDir isolateDir)
                                      forceInstall
@ -501,7 +503,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
--- a/app/ghcup/GHCup/OptParse/Prefetch.hs
+++ b/app/ghcup/GHCup/OptParse/Prefetch.hs
@ -153,6 +153,7 @@ type PrefetchEffects = '[ TagNotFound
                        , NoToolVersionSet
                        , NoDownload
                        , DigestError
+                        , ContentLengthError
                        , GPGError
                        , DownloadFailed
                        , JSONError
--- a/app/ghcup/GHCup/OptParse/Run.hs
+++ b/app/ghcup/GHCup/OptParse/Run.hs
@ -177,6 +177,7 @@ type RunEffects = '[ AlreadyInstalled
                   , BuildFailed
                   , TagNotFound
                   , DigestError
+                   , ContentLengthError
                   , GPGError
                   , DownloadFailed
                   , TarDirDoesNotExist
@ -343,6 +344,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                              , DownloadFailed
                              , DirNotEmpty
                              , DigestError
+                              , ContentLengthError
                              , BuildFailed
                              , ArchiveResult
                              , AlreadyInstalled
--- a/app/ghcup/GHCup/OptParse/Upgrade.hs
+++ b/app/ghcup/GHCup/OptParse/Upgrade.hs
@ -88,6 +88,7 @@ upgradeOptsP =


 type UpgradeEffects = '[ DigestError
+                       , ContentLengthError
                       , GPGError
                       , NoDownload
                       , NoUpdate
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -210,7 +210,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]

                ghcupInfo <-
                  ( flip runReaderT leanAppstate
-                    . runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
+                    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
                    $ liftE getDownloadsF
                    )
                    >>= \case
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -106,6 +106,7 @@ fetchToolBindist :: ( MonadFail m
                 -> Maybe FilePath
                 -> Excepts
                      '[ DigestError
+                       , ContentLengthError
                       , GPGError
                       , DownloadFailed
                       , NoDownload
@ -288,6 +289,7 @@ upgradeGHCup :: ( MonadMask m
             -> Excepts
                  '[ CopyError
                   , DigestError
+                   , ContentLengthError
                   , GPGError
                   , GPGError
                   , DownloadFailed
@ -308,7 +310,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
--- a/lib/GHCup/Cabal.hs
+++ b/lib/GHCup/Cabal.hs
@ -81,6 +81,7 @@ installCabalBindist :: ( MonadMask m
                         '[ AlreadyInstalled
                          , CopyError
                          , DigestError
+                          , ContentLengthError
                          , GPGError
                          , DownloadFailed
                          , NoDownload
@ -184,6 +185,7 @@ installCabalBin :: ( MonadMask m
                     '[ AlreadyInstalled
                      , CopyError
                      , DigestError
+                      , ContentLengthError
                      , GPGError
                      , DownloadFailed
                      , NoDownload
--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@ -114,7 +114,7 @@ getDownloadsF :: ( FromJSONKey Tool
                 , MonadMask m
                 )
              => Excepts
-                   '[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
+                   '[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
                   m
                   GHCupInfo
 getDownloadsF = do
@ -162,7 +162,7 @@ getBase :: ( MonadReader env m
           , MonadMask m
           )
        => URI
-        -> Excepts '[GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo
+        -> Excepts '[GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo
 getBase uri = do
  Settings { noNetwork, downloader } <- lift getSettings

@ -184,7 +184,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
@ -229,6 +229,7 @@ getBase uri = do
          -> Excepts
               '[ DownloadFailed
                , DigestError
+                , ContentLengthError
                , GPGError
                ]
               m1
@ -242,7 +243,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
@ -258,7 +259,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
@ -324,16 +325,18 @@ 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'
+      forM_ eCSize  (liftE . flip checkCSize  destFile')
      forM_ eDigest (liftE . flip checkDigest destFile')
      pure destFile'
  | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
@ -351,7 +354,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
@ -401,19 +404,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"
@ -423,6 +444,7 @@ download uri gpgUri eDigest 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

@ -440,7 +462,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
@ -449,7 +478,12 @@ download uri gpgUri eDigest dest mfn etags
      liftIO $ renameFile destFileTemp destFile


-  wgetEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO 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
@ -471,7 +505,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
@ -481,11 +518,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
@ -497,7 +539,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
@ -505,7 +547,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)
@ -574,14 +616,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
@ -596,7 +638,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
@ -605,9 +647,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



@ -638,6 +681,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
@ -219,6 +219,29 @@ 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)

--- a/lib/GHCup/GHC.hs
+++ b/lib/GHCup/GHC.hs
@ -109,6 +109,7 @@ fetchGHCSrc :: ( MonadFail m
            -> Maybe FilePath
            -> Excepts
                 '[ DigestError
+                  , ContentLengthError
                  , GPGError
                  , DownloadFailed
                  , NoDownload
@ -152,6 +153,7 @@ installGHCBindist :: ( MonadFail m
                       '[ AlreadyInstalled
                        , BuildFailed
                        , DigestError
+                        , ContentLengthError
                        , GPGError
                        , DownloadFailed
                        , NoDownload
@ -357,6 +359,7 @@ installGHCBin :: ( MonadFail m
                   '[ AlreadyInstalled
                    , BuildFailed
                    , DigestError
+                    , ContentLengthError
                    , GPGError
                    , DownloadFailed
                    , NoDownload
@ -628,6 +631,7 @@ compileGHC :: ( MonadMask m
                '[ AlreadyInstalled
                 , BuildFailed
                 , DigestError
+                 , ContentLengthError
                 , GPGError
                 , DownloadFailed
                 , GHCupSetError
@ -684,7 +688,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 +710,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 +720,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
@ -105,6 +105,7 @@ installHLSBindist :: ( MonadMask m
                       '[ AlreadyInstalled
                        , CopyError
                        , DigestError
+                        , ContentLengthError
                        , GPGError
                        , DownloadFailed
                        , NoDownload
@ -297,6 +298,7 @@ installHLSBin :: ( MonadMask m
                   '[ AlreadyInstalled
                    , CopyError
                    , DigestError
+                    , ContentLengthError
                    , GPGError
                    , DownloadFailed
                    , NoDownload
@ -344,6 +346,7 @@ compileHLS :: ( MonadMask m
                       , GPGError
                       , DownloadFailed
                       , DigestError
+                       , ContentLengthError
                       , UnknownArchive
                       , TarDirDoesNotExist
                       , ArchiveResult
@ -401,7 +404,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 +484,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 +500,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 +514,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)
--- a/lib/GHCup/Stack.hs
+++ b/lib/GHCup/Stack.hs
@ -82,6 +82,7 @@ installStackBin :: ( MonadMask m
                     '[ AlreadyInstalled
                      , CopyError
                      , DigestError
+                      , ContentLengthError
                      , GPGError
                      , DownloadFailed
                      , NoDownload
@ -120,6 +121,7 @@ installStackBindist :: ( MonadMask m
                         '[ AlreadyInstalled
                          , CopyError
                          , DigestError
+                          , ContentLengthError
                          , GPGError
                          , DownloadFailed
                          , NoDownload
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@ -262,6 +262,7 @@ data DownloadInfo = DownloadInfo
  { _dlUri    :: URI
  , _dlSubdir :: Maybe TarDir
  , _dlHash   :: Text
+  , _dlCSize  :: Maybe Integer
  }
  deriving (Eq, Ord, GHC.Generic, Show)

--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@ -1035,13 +1035,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 +1172,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 +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 , DownloadFailed] $ dl
-        ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
+          liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] $ dl
+        ) `catchE` liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] dl
  | otherwise = pure ()


--- a/test/golden/unix/GHCupInfo.json
+++ b/test/golden/unix/GHCupInfo.json
--- a/test/golden/windows/GHCupInfo.json
+++ b/test/golden/windows/GHCupInfo.json