hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'issue-367-content-prop'

Browse Source
This commit is contained in:
Julian Ospald 2023-01-03 22:51:19 +08:00
commit 109187eb6f
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
20 changed files with 8011 additions and 5077 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
.github/workflows/release.yaml vendored
View File

@ -272,6 +272,14 @@ jobs:
DISTRO: ${{ matrix.DISTRO }} DISTRO: ${{ matrix.DISTRO }}
APT_GET: "sudo apt-get" 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: test-arm:
name: Test ARM name: Test ARM
needs: "build-arm" needs: "build-arm"
@ -331,6 +339,14 @@ jobs:
GHC_VER: ${{ matrix.GHC_VER }} GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: Ubuntu DISTRO: Ubuntu
- if: failure()
name: Upload artifact
uses: actions/upload-artifact@v3
with:
name: testfiles
path: |
./test/golden/unix/GHCupInfo*json
test-macwin: test-macwin:
name: Test Mac/Win name: Test Mac/Win
needs: "build-macwin" needs: "build-macwin"
@ -377,6 +393,22 @@ jobs:
GHC_VER: ${{ matrix.GHC_VER }} GHC_VER: ${{ matrix.GHC_VER }}
DISTRO: ${{ matrix.DISTRO }} DISTRO: ${{ matrix.DISTRO }}
HOMEBREW_CHANGE_ARCH_TO_ARM: 1 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: hls:
name: hls name: hls
needs: build-linux needs: build-linux

3
app/ghcup/BrickMain.hs
View File

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

2
app/ghcup/GHCup/OptParse/Compile.hs
View File

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

10
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -243,6 +243,7 @@ type InstallEffects = '[ AlreadyInstalled
, BuildFailed , BuildFailed
, TagNotFound , TagNotFound
, DigestError , DigestError
, ContentLengthError
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, TarDirDoesNotExist , TarDirDoesNotExist
@ -271,6 +272,7 @@ type InstallGHCEffects = '[ AlreadyInstalled
, BuildFailed , BuildFailed
, CopyError , CopyError
, DigestError , DigestError
, ContentLengthError
, DirNotEmpty , DirNotEmpty
, DownloadFailed , DownloadFailed
, FileAlreadyExistsError , FileAlreadyExistsError
@ -332,7 +334,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
runInstGHC s'{ settings = settings {noVerify = True}} $ do runInstGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBindist liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing)
(_tvVersion v) (_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
@ -402,7 +404,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ runBothE' (installCabalBindist liftE $ runBothE' (installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "" Nothing)
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
@ -452,7 +454,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-- TODO: support legacy -- TODO: support legacy
liftE $ runBothE' (installHLSBindist liftE $ runBothE' (installHLSBindist
(DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "") (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing)
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
@ -501,7 +503,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
liftE $ runBothE' (installStackBindist liftE $ runBothE' (installStackBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "" Nothing)
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall

1
app/ghcup/GHCup/OptParse/Prefetch.hs
View File

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

2
app/ghcup/GHCup/OptParse/Run.hs
View File

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

1
app/ghcup/GHCup/OptParse/Upgrade.hs
View File

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

2
app/ghcup/Main.hs
View File

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

4
lib/GHCup.hs
View File

@ -106,6 +106,7 @@ fetchToolBindist :: ( MonadFail m
-> Maybe FilePath -> Maybe FilePath
-> Excepts -> Excepts
'[ DigestError '[ DigestError
, ContentLengthError
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, NoDownload , NoDownload
@ -288,6 +289,7 @@ upgradeGHCup :: ( MonadMask m
-> Excepts -> Excepts
'[ CopyError '[ CopyError
, DigestError , DigestError
, ContentLengthError
, GPGError , GPGError
, GPGError , GPGError
, DownloadFailed , DownloadFailed
@ -308,7 +310,7 @@ upgradeGHCup mtarget force' fatal = do
dli <- liftE $ getDownloadInfo GHCup latestVer dli <- liftE $ getDownloadInfo GHCup latestVer
tmp <- fromGHCupPath <$> lift withGHCupTmpDir tmp <- fromGHCupPath <$> lift withGHCupTmpDir
let fn = "ghcup" <> exeExt 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 let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn) mtarget destFile = fromMaybe (binDir </> fn) mtarget
lift $ logDebug $ "mkdir -p " <> T.pack destDir lift $ logDebug $ "mkdir -p " <> T.pack destDir

2
lib/GHCup/Cabal.hs
View File

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

110
lib/GHCup/Download.hs
View File

@ -114,7 +114,7 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadMask m , MonadMask m
) )
=> Excepts => Excepts
'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] '[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
m m
GHCupInfo GHCupInfo
getDownloadsF = do getDownloadsF = do
@ -162,7 +162,7 @@ getBase :: ( MonadReader env m
, MonadMask m , MonadMask m
) )
=> URI => URI
-> Excepts '[DownloadFailed, GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo
getBase uri = do getBase uri = do
Settings { noNetwork, downloader, metaMode } <- lift getSettings Settings { noNetwork, downloader, metaMode } <- lift getSettings
@ -188,7 +188,7 @@ getBase uri = do
liftE liftE
. onE_ (onError actualYaml) . onE_ (onError actualYaml)
. lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."]) . lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
. liftIO . liftIO
. Y.decodeFileEither . Y.decodeFileEither
$ actualYaml $ actualYaml
where where
@ -233,6 +233,7 @@ getBase uri = do
-> Excepts -> Excepts
'[ DownloadFailed '[ DownloadFailed
, DigestError , DigestError
, ContentLengthError
, GPGError , GPGError
] ]
m1 m1
@ -246,7 +247,7 @@ getBase uri = do
Settings { metaCache } <- lift getSettings Settings { metaCache } <- lift getSettings
-- for local files, let's short-circuit and ignore access time -- 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 | e -> do
accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@ -262,7 +263,7 @@ getBase uri = do
where where
dlWithMod modTime json_file = do dlWithMod modTime json_file = do
let (dir, fn) = splitFileName json_file 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 $ setModificationTime f modTime
liftIO $ setAccessTime f modTime liftIO $ setAccessTime f modTime
pure f pure f
@ -328,13 +329,14 @@ download :: ( MonadReader env m
=> URI => URI
-> Maybe URI -- ^ URI for gpg sig -> Maybe URI -- ^ URI for gpg sig
-> Maybe T.Text -- ^ expected hash -> Maybe T.Text -- ^ expected hash
-> Maybe Integer -- ^ expected content length
-> FilePath -- ^ destination dir (ignored for file:// scheme) -> FilePath -- ^ destination dir (ignored for file:// scheme)
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Bool -- ^ whether to read an write etags -> Bool -- ^ whether to read an write etags
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
download uri gpgUri eDigest dest mfn etags download uri gpgUri eDigest eCSize dest mfn etags
| scheme == "https" = dl | scheme == "https" = liftE dl
| scheme == "http" = dl | scheme == "http" = liftE dl
| scheme == "file" = do | scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ view pathL' uri let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
lift $ logDebug $ "using local file: " <> T.pack destFile' lift $ logDebug $ "using local file: " <> T.pack destFile'
@ -355,7 +357,7 @@ download uri gpgUri eDigest dest mfn etags
-- download -- download
flip onException flip onException
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile)) (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 (\e' -> do
lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile) lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile)
case e' of case e' of
@ -405,19 +407,37 @@ download uri gpgUri eDigest dest mfn etags
CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
_ -> pure () _ -> pure ()
forM_ eCSize (liftE . flip checkCSize baseDestFile)
forM_ eDigest (liftE . flip checkDigest baseDestFile) forM_ eDigest (liftE . flip checkDigest baseDestFile)
pure 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 curlDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
liftE $ lEM @_ @'[ProcessError] $ exec "curl" 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 liftIO $ renameFile destFileTemp destFile
curlEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m) curlEtagsDL :: ( MonadReader env m
=> [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m () , HasLog env
, MonadCatch m
, MonadMask m
, MonadIO m
)
=> [String]
-> FilePath
-> URI
-> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
curlEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do curlEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile let destFileTemp = tmpFile destFile
dh <- liftIO $ emptySystemTempFile "curl-header" dh <- liftIO $ emptySystemTempFile "curl-header"
@ -444,7 +464,14 @@ download uri gpgUri eDigest dest mfn etags
lift $ writeEtags destFile (parseEtags headers) 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 wgetDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile let destFileTemp = tmpFile destFile
flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
@ -453,7 +480,12 @@ download uri gpgUri eDigest dest mfn etags
liftIO $ renameFile destFileTemp destFile 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 () => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
wgetEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do wgetEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
let destFileTemp = tmpFile destFile let destFileTemp = tmpFile destFile
@ -475,7 +507,10 @@ download uri gpgUri eDigest dest mfn etags
| otherwise -> throwE (NonZeroExit i' "wget" opts) | otherwise -> throwE (NonZeroExit i' "wget" opts)
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
internalDL :: (MonadCatch m, MonadMask m, MonadIO m) internalDL :: ( MonadCatch m
, MonadMask m
, MonadIO m
)
=> FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m () => FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalDL destFile uri' = do internalDL destFile uri' = do
let destFileTemp = tmpFile destFile let destFileTemp = tmpFile destFile
@ -485,11 +520,16 @@ download uri gpgUri eDigest dest mfn etags
@'[DownloadFailed] @'[DownloadFailed]
(\e@(HTTPNotModified _) -> (\e@(HTTPNotModified _) ->
throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[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 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 () => FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
internalEtagsDL destFile uri' = do internalEtagsDL destFile uri' = do
let destFileTemp = tmpFile destFile let destFileTemp = tmpFile destFile
@ -501,7 +541,7 @@ download uri gpgUri eDigest dest mfn etags
liftE liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag)) $ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do $ do
r <- downloadToFile https host fullPath port destFileTemp addHeaders r <- downloadToFile https host fullPath port destFileTemp addHeaders eCSize
liftIO $ renameFile destFileTemp destFile liftIO $ renameFile destFileTemp destFile
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag") lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
#endif #endif
@ -509,7 +549,7 @@ download uri gpgUri eDigest dest mfn etags
-- Manage to find a file we can write the body into. -- Manage to find a file we can write the body into.
getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath
getDestFile uri' mfn' = getDestFile uri' mfn' =
let path = view pathL' uri' let path = view pathL' uri'
in case mfn' of in case mfn' of
Just fn -> pure (dest </> fn) Just fn -> pure (dest </> fn)
@ -578,14 +618,14 @@ downloadCached :: ( MonadReader env m
) )
=> DownloadInfo => DownloadInfo
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
downloadCached dli mfn = do downloadCached dli mfn = do
Settings{ cache } <- lift getSettings Settings{ cache } <- lift getSettings
case cache of case cache of
True -> downloadCached' dli mfn Nothing True -> downloadCached' dli mfn Nothing
False -> do False -> do
tmp <- lift withGHCupTmpDir 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 downloadCached' :: ( MonadReader env m
@ -600,7 +640,7 @@ downloadCached' :: ( MonadReader env m
=> DownloadInfo => DownloadInfo
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Maybe FilePath -- ^ optional destination dir (default: cacheDir) -> 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 downloadCached' dli mfn mDestDir = do
Dirs { cacheDir } <- lift getDirs Dirs { cacheDir } <- lift getDirs
let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
@ -609,9 +649,10 @@ downloadCached' dli mfn mDestDir = do
fileExists <- liftIO $ doesFileExist cachfile fileExists <- liftIO $ doesFileExist cachfile
if if
| fileExists -> do | fileExists -> do
forM_ (view dlCSize dli) $ \s -> liftE $ checkCSize s cachfile
liftE $ checkDigest (view dlHash dli) cachfile liftE $ checkDigest (view dlHash dli) cachfile
pure cachfile pure cachfile
| otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) destDir mfn False | otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) destDir mfn False
@ -642,6 +683,25 @@ checkDigest eDigest file = do
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
when ((cDigest /= eDigest) && verify) $ throwE (DigestError file cDigest eDigest) 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. -- | Get additional curl args from env. This is an undocumented option.
getCurlOpts :: IO [String] getCurlOpts :: IO [String]

63
lib/GHCup/Download/IOStreams.hs
View File

@ -17,14 +17,12 @@ import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.ByteString.Builder
import Data.CaseInsensitive ( CI, original, mk ) import Data.CaseInsensitive ( CI, original, mk )
import Data.IORef import Data.IORef
import Data.Maybe import Data.Maybe
import Data.Text.Read import Data.Text.Read
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Network.Http.Client hiding ( URL ) import Network.Http.Client hiding ( URL )
import Optics
import Prelude hiding ( abs import Prelude hiding ( abs
, readFile , readFile
, writeFile , writeFile
@ -33,7 +31,6 @@ import System.ProgressBar
import URI.ByteString import URI.ByteString
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified System.IO.Streams as Streams 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) downloadToFile :: (MonadMask m, MonadIO m)
=> Bool -- ^ https? => Bool -- ^ https?
@ -75,8 +51,9 @@ downloadToFile :: (MonadMask m, MonadIO m)
-> Maybe Int -- ^ optional port (e.g. 3000) -> Maybe Int -- ^ optional port (e.g. 3000)
-> FilePath -- ^ destination file to create and write to -> FilePath -- ^ destination file to create and write to
-> M.Map (CI ByteString) ByteString -- ^ additional headers -> M.Map (CI ByteString) ByteString -- ^ additional headers
-> Maybe Integer -- ^ expected content length
-> Excepts '[DownloadFailed, HTTPNotModified] m Response -> 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 let stepper = BS.appendFile destFile
setup = BS.writeFile destFile mempty setup = BS.writeFile destFile mempty
catchAllE (\case catchAllE (\case
@ -84,7 +61,7 @@ downloadToFile https host fullPath port destFile addHeaders = do
| i == 304 | i == 304
, Just e <- M.lookup (mk "etag") headers -> throwE $ HTTPNotModified (decUTF8Safe e) , Just e <- M.lookup (mk "etag") headers -> throwE $ HTTPNotModified (decUTF8Safe e)
v -> throwE $ DownloadFailed v 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 downloadInternal :: MonadIO m
@ -96,19 +73,21 @@ downloadInternal :: MonadIO m
-> (ByteString -> IO a) -- ^ the consuming step function -> (ByteString -> IO a) -- ^ the consuming step function
-> IO a -- ^ setup action -> IO a -- ^ setup action
-> M.Map (CI ByteString) ByteString -- ^ additional headers -> M.Map (CI ByteString) ByteString -- ^ additional headers
-> Maybe Integer
-> Excepts -> Excepts
'[ HTTPStatusError '[ HTTPStatusError
, URIParseError , URIParseError
, UnsupportedScheme , UnsupportedScheme
, NoLocationHeader , NoLocationHeader
, TooManyRedirs , TooManyRedirs
, ContentLengthError
] ]
m m
Response Response
downloadInternal = go (5 :: Int) downloadInternal = go (5 :: Int)
where 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 r <- liftIO $ withConnection' https host port action
veitherToExcepts r >>= \case veitherToExcepts r >>= \case
Right r' -> Right r' ->
@ -138,25 +117,39 @@ downloadInternal = go (5 :: Int)
followRedirectURL bs = case parseURI strictURIParserOptions bs of followRedirectURL bs = case parseURI strictURIParserOptions bs of
Right uri' -> do Right uri' -> do
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri' (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 Left e -> throwE e
downloadStream r i' = do downloadStream r i' = do
void setup void setup
let size = case getHeader r "Content-Length" of let size = case getHeader r "Content-Length" of
Just x' -> case decimal $ decUTF8Safe x' of Just x' -> case decimal $ decUTF8Safe x' of
Left _ -> 0 Left _ -> Nothing
Right (r', _) -> r' Right (r', _) -> Just r'
Nothing -> 0 Nothing -> Nothing
(mpb :: Maybe (ProgressBar ())) <- if progressBar forM_ size $ \s -> forM_ eCSize $ \es -> when (es /= s) $ throwIO (ContentLengthError Nothing (Just s) es)
then Just <$> newProgressBar defStyle 10 (Progress 0 size ()) let size' = eCSize <|> 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 outStream <- liftIO $ Streams.makeOutputStream
(\case (\case
Just bs -> do 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 void $ consumer bs
Nothing -> pure () Nothing -> pure ()
) )

23
lib/GHCup/Errors.hs
View File

@ -219,6 +219,29 @@ instance Pretty DigestError where
<+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest <+> text <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest <+> text
"\nConsider removing the file in case it's cached and try again." "\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. -- | File digest verification failed.
data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs) data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)

10
lib/GHCup/GHC.hs
View File

@ -109,6 +109,7 @@ fetchGHCSrc :: ( MonadFail m
-> Maybe FilePath -> Maybe FilePath
-> Excepts -> Excepts
'[ DigestError '[ DigestError
, ContentLengthError
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, NoDownload , NoDownload
@ -152,6 +153,7 @@ installGHCBindist :: ( MonadFail m
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
, DigestError , DigestError
, ContentLengthError
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, NoDownload , NoDownload
@ -357,6 +359,7 @@ installGHCBin :: ( MonadFail m
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
, DigestError , DigestError
, ContentLengthError
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, NoDownload , NoDownload
@ -628,6 +631,7 @@ compileGHC :: ( MonadMask m
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
, DigestError , DigestError
, ContentLengthError
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, GHCupSetError , GHCupSetError
@ -684,7 +688,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
-- download source tarball -- download source tarball
tmpDownload <- lift withGHCupTmpDir tmpDownload <- lift withGHCupTmpDir
tmpUnpack <- lift mkGhcupTmpDir 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 (bf, tver) <- liftE $ cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError] tmpUnpack $ do
liftE $ unpackToDir (fromGHCupPath tmpUnpack) tar liftE $ unpackToDir (fromGHCupPath tmpUnpack) tar
let regex = [s|^(.*/)*boot$|] :: B.ByteString let regex = [s|^(.*/)*boot$|] :: B.ByteString
@ -706,7 +710,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
GitDist GitBranch{..} -> do GitDist GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing 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 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)" lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ] lEM $ git [ "init" ]
@ -716,7 +720,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
, fromString rep ] , fromString rep ]
-- figure out if we can do a shallow clone -- 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) $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)
let shallow_clone let shallow_clone
| isCommitHash ref = True | isCommitHash ref = True

11
lib/GHCup/HLS.hs
View File

@ -105,6 +105,7 @@ installHLSBindist :: ( MonadMask m
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
, DigestError , DigestError
, ContentLengthError
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, NoDownload , NoDownload
@ -297,6 +298,7 @@ installHLSBin :: ( MonadMask m
'[ AlreadyInstalled '[ AlreadyInstalled
, CopyError , CopyError
, DigestError , DigestError
, ContentLengthError
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, NoDownload , NoDownload
@ -344,6 +346,7 @@ compileHLS :: ( MonadMask m
, GPGError , GPGError
, DownloadFailed , DownloadFailed
, DigestError , DigestError
, ContentLengthError
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist , TarDirDoesNotExist
, ArchiveResult , ArchiveResult
@ -401,7 +404,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
-- download source tarball -- download source tarball
tmpDownload <- lift withGHCupTmpDir tmpDownload <- lift withGHCupTmpDir
tmpUnpack <- lift mkGhcupTmpDir 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 (cf, tver) <- liftE $ cleanUpOnError tmpUnpack $ do
unpackToDir (fromGHCupPath tmpUnpack) tar unpackToDir (fromGHCupPath tmpUnpack) tar
let regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString let regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString
@ -481,7 +484,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
liftE $ runBuildAction liftE $ runBuildAction
tmpUnpack 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" let tmpInstallDir = fromGHCupPath workdir </> "out"
liftIO $ createDirRecursive' tmpInstallDir liftIO $ createDirRecursive' tmpInstallDir
@ -497,7 +500,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
| otherwise -> pure (takeFileName cp) | otherwise -> pure (takeFileName cp)
Just (Right uri) -> do Just (Right uri) -> do
tmpUnpack' <- lift withGHCupTmpDir 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 copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
pure "cabal.project" pure "cabal.project"
Nothing Nothing
@ -511,7 +514,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
| otherwise -> pure "cabal.project" | otherwise -> pure "cabal.project"
forM_ cabalProjectLocal $ \uri -> do forM_ cabalProjectLocal $ \uri -> do
tmpUnpack' <- lift withGHCupTmpDir 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 copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False
artifacts <- forM (sort ghcs) $ \ghc -> do artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc) let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)

2
lib/GHCup/Stack.hs
View File

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

1
lib/GHCup/Types.hs
View File

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

10
lib/GHCup/Utils.hs
View File

@ -1035,13 +1035,13 @@ applyAnyPatch :: ( MonadReader env m
, MonadIO m) , MonadIO m)
=> Maybe (Either FilePath [URI]) => Maybe (Either FilePath [URI])
-> FilePath -> FilePath
-> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m () -> Excepts '[PatchFailed, DownloadFailed, DigestError, ContentLengthError, GPGError] m ()
applyAnyPatch Nothing _ = pure () applyAnyPatch Nothing _ = pure ()
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
applyAnyPatch (Just (Right uris)) workdir = do applyAnyPatch (Just (Right uris)) workdir = do
tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir
forM_ uris $ \uri -> do 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 liftE $ applyPatch patch workdir
@ -1172,7 +1172,7 @@ ensureGlobalTools :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m () => Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m ()
ensureGlobalTools ensureGlobalTools
| isWindows = do | isWindows = do
(GHCupInfo _ _ gTools) <- lift getGHCupInfo (GHCupInfo _ _ gTools) <- lift getGHCupInfo
@ -1184,8 +1184,8 @@ ensureGlobalTools
lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) </> "gs.exe")) lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe") lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe")
liftE @'[GPGError, DigestError , DownloadFailed] $ dl liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] $ dl
) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl ) `catchE` liftE @'[GPGError, DigestError, ContentLengthError, DownloadFailed] dl
| otherwise = pure () | otherwise = pure ()

1410
test/golden/unix/GHCupInfo.json
View File

File diff suppressed because it is too large Load Diff

11389
test/golden/windows/GHCupInfo.json
View File

File diff suppressed because it is too large Load Diff