Add content-length property to downloads
This is optional for now. Fixes #367
This commit is contained in:
parent
d1075987de
commit
9d4c923649
GPG Key ID:
3786C5262ECB4A3F
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -153,6 +153,7 @@ type PrefetchEffects = '[ TagNotFound
|
|||
, NoToolVersionSet
|
||||
, NoDownload
|
||||
, DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, JSONError
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -88,6 +88,7 @@ upgradeOptsP =
|
|||
|
||||
|
||||
type UpgradeEffects = '[ DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, NoDownload
|
||||
, NoUpdate
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -262,6 +262,7 @@ data DownloadInfo = DownloadInfo
|
|||
{ _dlUri :: URI
|
||||
, _dlSubdir :: Maybe TarDir
|
||||
, _dlHash :: Text
|
||||
, _dlCSize :: Maybe Integer
|
||||
}
|
||||
deriving (Eq, Ord, GHC.Generic, Show)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue