Compare commits

..

77 Commits

Author SHA1 Message Date
3b24f503d1 Fixup rest of the PR 2021-08-11 13:54:02 +02:00
bd18fd9aa1 Merge remote-tracking branch 'origin/merge-requests/127' 2021-08-11 12:28:48 +02:00
Arjun Kathuria
c2c5625685 implements checking if file already exists for Cabal installs 2021-08-11 10:33:08 +05:30
Arjun Kathuria
ce6fb0bb1e Adds new Error type FileAlreadyExistsError 2021-08-11 10:28:30 +05:30
Arjun Kathuria
dcfb3afdad Revert "implements isolated install sanity-checking for Cabal installs"
This reverts commit 300cfd3ba6.
2021-08-11 09:46:42 +05:30
50c91345e8 Merge branch 'windows-autoconf' 2021-08-10 17:08:43 +02:00
af3ecae792 Install autoconf in msys2 wrt #200 2021-08-10 16:58:37 +02:00
Arjun Kathuria
300cfd3ba6 implements isolated install sanity-checking for Cabal installs 2021-08-10 20:14:46 +05:30
Arjun Kathuria
bb430fa0b7 Adds the sanity check function for isolated installs 2021-08-10 20:12:14 +05:30
Arjun Kathuria
80fa7965a4 Adds new Error type IsolatedDirNotEmpty 2021-08-10 20:11:32 +05:30
9975a2d4ba Merge branch 'fix-install' 2021-08-10 16:39:46 +02:00
Arjun Kathuria
d1735bc446 adds toolchainSanityChecks for isolated installs too in installGHCBindist function. 2021-08-10 19:53:41 +05:30
dbf1d6f420 Fix unneeded dist files being installed along with GHC 2021-08-10 15:58:40 +02:00
0a0fbd0cb6 Merge branch 'fix-metadata-download' 2021-08-07 19:26:26 +02:00
f13f53b910 Merge branch 'throwM' 2021-08-07 19:20:00 +02:00
6dfc04a9f6 Fix metadata file read in --offline mode 2021-08-07 18:31:41 +02:00
72133d0002 Rather skip copying to cache dir if scheme is file:// 2021-08-07 10:24:08 +02:00
6e07e9e56b Skip copying metadata if source and destination match 2021-08-07 09:55:45 +02:00
e903aeb555 Skip cached metadata when url starts with file:// 2021-08-07 09:54:26 +02:00
2792f6f4b6 Fix error handling when we can't find a filename 2021-08-06 19:45:59 +02:00
Arjun Kathuria
80eb72ce49 Merge branch 'smash-1' of gitlab.haskell.org:arjun/ghcup-hs into smash-1 2021-08-04 16:09:48 +05:30
Arjun Kathuria
2c6d0382cf adds isolate install feature to compiled ghc command 2021-08-04 16:08:12 +05:30
Arjun Kathuria
e1bec789b0 updates Bindist functions as per https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/127#note_366702 2021-08-03 18:08:54 +05:30
Arjun Kathuria
5683493cae rename some auxiliary functions to their "unpacked" versions 2021-08-03 18:08:54 +05:30
Arjun Kathuria
ae5e213b59 deletes installStackBinIsolated function 2021-08-03 18:08:54 +05:30
Arjun Kathuria
911089f334 updates usages of new installStackBin across files 2021-08-03 18:08:54 +05:30
Arjun Kathuria
6b89646c1e update installStackBindist to take a "Maybe FilePath" argument for isolated installs 2021-08-03 18:08:54 +05:30
Arjun Kathuria
960d5ce79f deletes installHLSBinIsolated function 2021-08-03 18:08:54 +05:30
Arjun Kathuria
90ed0895d6 updates usages of installHLSBin across files 2021-08-03 18:08:54 +05:30
Arjun Kathuria
7471f4f4dc update installHLSBindist to take a "Maybe FilePath" argument for isolated installs 2021-08-03 18:08:54 +05:30
Arjun Kathuria
781cf8eed5 Delete installCabalBinIsolated function. 2021-08-03 18:08:54 +05:30
Arjun Kathuria
236da31af6 updates usages of new installCabalBindist across files. 2021-08-03 18:08:54 +05:30
Arjun Kathuria
1f760af880 update installCabalBindist to take a "Maybe FilePath" argument for isolated installs 2021-08-03 18:08:54 +05:30
Arjun Kathuria
62d03b776b remove installGHCBinIsolated function. 2021-08-03 18:08:54 +05:30
Arjun Kathuria
37ea18a0d8 updates usages of new installGHCBindist and related installGHCBin 2021-08-03 18:08:54 +05:30
Arjun Kathuria
083dc59a8f update installGhcBindist to take a "Maybe FilePath" to work with isolated installs 2021-08-03 18:08:54 +05:30
Arjun Kathuria
a45d069cad Adds a log to notify where the isolated ghc is being installed by the tool 2021-08-03 18:08:54 +05:30
Arjun Kathuria
fdbcd4fafd Adds isolated installs to Stack install 2021-08-03 18:08:54 +05:30
Arjun Kathuria
f3c1c925ed updates installStack' usage in installStackBindist function 2021-08-03 18:08:54 +05:30
Arjun Kathuria
8f6a7ba39c factor out installStack' function 2021-08-03 18:08:54 +05:30
Arjun Kathuria
f212eb4570 Adds isolated install to HLS installs 2021-08-03 18:08:54 +05:30
Arjun Kathuria
0d118e2fe1 update installHLS' usage in installHLSBindist 2021-08-03 18:08:54 +05:30
Arjun Kathuria
c0f46ef81f Factor out installHLS' 2021-08-03 18:08:54 +05:30
Arjun Kathuria
476513b0a7 Adds isolate install functionality to 'Cabal' tool installs 2021-08-03 18:08:54 +05:30
Arjun Kathuria
9a511669a8 use the new factored out installCabal' in installCabalBindist function 2021-08-03 18:08:54 +05:30
Arjun Kathuria
a16a25a3cd factor out installCabal' from installCabalBindist, to be shared with installCabalBinIsolated function 2021-08-03 18:08:54 +05:30
Arjun Kathuria
8666fcd120 adds rudimentary isolate capability to ghcup install ghc command 2021-08-03 18:08:54 +05:30
Arjun Kathuria
521ab0aedb adds basic --isolate option structure for install commands 2021-08-03 18:08:54 +05:30
88d1d19f55 Merge branch 'bump-bs-ver' 2021-07-31 16:38:12 +02:00
0fb1da5c3a Bump ghc version in bootstrap-haskell 2021-07-31 16:23:01 +02:00
b32f88e9a6 Merge branch 'update-hls-1.3.0' 2021-07-31 14:44:16 +02:00
Arjun Kathuria
03d77f5006 updates Bindist functions as per https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/127#note_366702 2021-07-26 11:49:52 +05:30
Arjun Kathuria
71e6dbfdca rename some auxiliary functions to their "unpacked" versions 2021-07-25 22:34:53 +05:30
Arjun Kathuria
692cd1616b deletes installStackBinIsolated function 2021-07-25 22:25:25 +05:30
Arjun Kathuria
4e3dbea5d0 updates usages of new installStackBin across files 2021-07-25 22:24:38 +05:30
Arjun Kathuria
fd2add78bd update installStackBindist to take a "Maybe FilePath" argument for isolated installs 2021-07-25 22:23:58 +05:30
Arjun Kathuria
e9da8ab439 deletes installHLSBinIsolated function 2021-07-25 22:10:43 +05:30
Arjun Kathuria
9c22ba9d45 updates usages of installHLSBin across files 2021-07-25 22:10:10 +05:30
Arjun Kathuria
e5d3080b54 update installHLSBindist to take a "Maybe FilePath" argument for isolated installs 2021-07-25 22:09:54 +05:30
Arjun Kathuria
5995a8b592 Delete installCabalBinIsolated function. 2021-07-25 22:09:54 +05:30
Arjun Kathuria
bc6d006c57 updates usages of new installCabalBindist across files. 2021-07-25 22:09:54 +05:30
Arjun Kathuria
b148d8e2e7 update installCabalBindist to take a "Maybe FilePath" argument for isolated installs 2021-07-25 21:20:42 +05:30
Arjun Kathuria
4f7d41a8cc remove installGHCBinIsolated function. 2021-07-25 13:39:44 +05:30
Arjun Kathuria
5efe2e5f7a updates usages of new installGHCBindist and related installGHCBin 2021-07-25 13:38:32 +05:30
Arjun Kathuria
338f5f309d update installGhcBindist to take a "Maybe FilePath" to work with isolated installs 2021-07-25 13:35:41 +05:30
Arjun Kathuria
ba51cbad6f Adds a log to notify where the isolated ghc is being installed by the tool 2021-07-23 16:51:50 +05:30
Arjun Kathuria
511272e86d Adds isolated installs to Stack install 2021-07-23 16:46:11 +05:30
Arjun Kathuria
873f75da9f updates installStack' usage in installStackBindist function 2021-07-23 16:44:40 +05:30
Arjun Kathuria
42d4a66493 factor out installStack' function 2021-07-23 16:43:43 +05:30
Arjun Kathuria
9a79af6fd2 Adds isolated install to HLS installs 2021-07-23 16:25:01 +05:30
Arjun Kathuria
63f10a1871 update installHLS' usage in installHLSBindist 2021-07-23 16:23:52 +05:30
Arjun Kathuria
9686ee9826 Factor out installHLS' 2021-07-23 16:23:03 +05:30
Arjun Kathuria
4729364e99 Adds isolate install functionality to 'Cabal' tool installs 2021-07-23 15:57:42 +05:30
Arjun Kathuria
91d982c7b2 use the new factored out installCabal' in installCabalBindist function 2021-07-23 15:56:03 +05:30
Arjun Kathuria
8b7c22440e factor out installCabal' from installCabalBindist, to be shared with installCabalBinIsolated function 2021-07-23 15:52:28 +05:30
Arjun Kathuria
9b3d55a095 adds rudimentary isolate capability to ghcup install ghc command 2021-07-22 19:32:56 +05:30
Arjun Kathuria
e2daf5381c adds basic --isolate option structure for install commands 2021-07-20 22:05:01 +05:30
11 changed files with 19436 additions and 197 deletions

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -116,7 +116,20 @@ else
if [ "${OS}" = "LINUX" ] ; then
eghcup --downloader=wget prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
else # test wget a bit
if [ "${ARCH}" = "64" ] ; then
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-linux.files" | sort)
actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort)
[ "${actual}" = "${expected}" ]
unset actual expected
fi
elif [ "${OS}" = "WINDOWS" ] ; then
eghcup prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-windows.files" | sort)
actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort)
[ "${actual}" = "${expected}" ]
unset actual expected
else
eghcup prefetch ghc 8.10.3
eghcup --offline install ghc 8.10.3
fi
@@ -196,6 +209,21 @@ sha3=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
[ "${etag2}" = "${etag3}" ]
[ "${sha2}" = "${sha3}" ]
# test isolated installs
eghcup install ghc -i "$(pwd)/isolated" 8.10.5
[ "$(isolated/bin/ghc --numeric-version)" = "8.10.5" ]
! eghcup install ghc -i "$(pwd)/isolated" 8.10.5
if [ "${ARCH}" = "64" ] ; then
if [ "${OS}" = "LINUX" ] || [ "${OS}" = "WINDOWS" ] ; then
eghcup install cabal -i "$(pwd)/isolated" 3.4.0.0
[ "$(isolated/cabal --numeric-version)" = "3.4.0.0" ]
eghcup install stack -i "$(pwd)/isolated" 2.7.3
[ "$(isolated/stack --numeric-version)" = "2.7.3" ]
eghcup install hls -i "$(pwd)/isolated" 1.3.0
[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0" ] ||
[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0.0" ]
fi
fi
eghcup upgrade
eghcup upgrade -f

View File

@@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
($(logError) $ T.pack $ prettyShow e)
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl False GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
r <-
runLogger

View File

@@ -440,27 +440,29 @@ install' _ (_, ListResult {..}) = do
, TagNotFound
, DigestError
, DownloadFailed
, DirNotEmpty
, NoUpdate
, TarDirDoesNotExist
, FileAlreadyExistsError
]
run (do
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer $> vi
liftE $ installGHCBin lVer Nothing $> vi
Cabal -> do
let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer $> vi
liftE $ installCabalBin lVer Nothing $> vi
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False $> vi
HLS -> do
let vi = getVersionInfo lVer HLS dls
liftE $ installHLSBin lVer $> vi
liftE $ installHLSBin lVer Nothing $> vi
Stack -> do
let vi = getVersionInfo lVer Stack dls
liftE $ installStackBin lVer $> vi
liftE $ installStackBin lVer Nothing $> vi
)
>>= \case
VRight vi -> do

View File

@@ -138,6 +138,7 @@ data InstallOptions = InstallOptions
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
}
data SetCommand = SetGHC SetOptions
@@ -185,6 +186,7 @@ data GHCCompileOptions = GHCCompileOptions
, ovewrwiteVer :: Maybe Version
, buildFlavour :: Maybe String
, hadrian :: Bool
, isolateDir :: Maybe FilePath
}
data UpgradeOpts = UpgradeInplace
@@ -574,7 +576,7 @@ Examples:
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\p (u, v) b -> InstallOptions v p u b)
(\p (u, v) b is -> InstallOptions v p u b is)
<$> optional
(option
(eitherReader platformParser)
@@ -603,6 +605,15 @@ installOpts tool =
(long "set" <> help
"Set as active version after install"
)
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated dir instead of the default one"
)
)
setParser :: Parser (Either SetCommand SetOptions)
@@ -1000,6 +1011,15 @@ ghcCompileOpts =
<*> switch
(long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
)
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made"
)
)
toolVersionParser :: Parser ToolVersion
@@ -1215,6 +1235,10 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
isolateParser :: FilePath -> Either String FilePath
isolateParser f = case isValid f of
True -> Right $ normalise f
False -> Left "Please enter a valid filepath for isolate dir."
toSettings :: Options -> IO (Settings, KeyBindings)
toSettings options = do
@@ -1445,6 +1469,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
#endif
, FileDoesNotExistError
, CopyError
, NotInstalled
, DirNotEmpty
, NoDownload
, NotInstalled
, BuildFailed
@@ -1454,6 +1480,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TarDirDoesNotExist
, NextVerNotFound
, NoToolVersionSet
, FileAlreadyExistsError
]
let runInstTool mInstPlatform action' = do
@@ -1555,6 +1582,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, UnknownArchive
, TarDirDoesNotExist
, NotInstalled
, DirNotEmpty
#if !defined(TAR)
, ArchiveResult
#endif
@@ -1617,22 +1645,23 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-----------------------
let installGHC InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin (_tvVersion v) isolateDir
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> do
s' <- liftIO appState
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBin (_tvVersion v)
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
isolateDir
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> do
s' <- liftIO appState
runInstTool' s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
)
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "GHC installation successful"
@@ -1661,7 +1690,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Cabal
liftE $ installCabalBin (_tvVersion v)
liftE $ installCabalBin (_tvVersion v) isolateDir
pure vi
Just uri -> do
s' <- appState
@@ -1670,6 +1699,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
pure vi
)
>>= \case
@@ -1689,10 +1719,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 4
let installHLS InstallOptions{..} =
(case instBindist of
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
liftE $ installHLSBin (_tvVersion v)
liftE $ installHLSBin (_tvVersion v) isolateDir
pure vi
Just uri -> do
s' <- appState
@@ -1701,6 +1731,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
pure vi
)
>>= \case
@@ -1720,19 +1751,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 4
let installStack InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v)
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
pure vi
(case instBindist of
Nothing -> runInstTool instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBin (_tvVersion v) isolateDir
pure vi
Just uri -> do
s' <- appState
runInstTool' s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer Stack
liftE $ installStackBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
isolateDir
pure vi
)
>>= \case
VRight vi -> do
@@ -1961,6 +1993,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
addConfArgs
buildFlavour
hadrian
isolateDir
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $

View File

@@ -20,7 +20,7 @@
plat="$(uname -s)"
arch=$(uname -m)
ghver="0.1.15.2"
ghver="0.1.16.1"
base_url="https://downloads.haskell.org/~ghcup"
export GHCUP_SKIP_UPDATE_CHECK=yes

View File

@@ -371,7 +371,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'
Print-Msg -msg 'Installing Dependencies...'
Exec "$Bash" '-lc' 'pacman --noconfirm -S --needed curl mingw-w64-x86_64-pkgconf'
Exec "$Bash" '-lc' 'pacman --noconfirm -S --needed curl autoconf mingw-w64-x86_64-pkgconf'
Print-Msg -msg 'Updating SSL root certificate authorities...'
Exec "$Bash" '-lc' 'pacman --noconfirm -S ca-certificates'

View File

@@ -186,6 +186,7 @@ installGHCBindist :: ( MonadFail m
)
=> DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated filepath if user passed any
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@@ -195,16 +196,22 @@ installGHCBindist :: ( MonadFail m
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, DirNotEmpty
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installGHCBindist dlinfo ver = do
installGHCBindist dlinfo ver isoFilepath = do
let tver = mkTVer ver
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
case isoFilepath of
-- we only care for already installed errors in regular (non-isolated) installs
Nothing -> whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
_ -> pure ()
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -214,9 +221,15 @@ installGHCBindist dlinfo ver = do
toolchainSanityChecks
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|]
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
Nothing -> do -- regular install
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
liftE $ postGHCInstall tver
-- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver
where
toolchainSanityChecks = do
@@ -250,6 +263,7 @@ installPackedGHC :: ( MonadMask m
'[ BuildFailed
, UnknownArchive
, TarDirDoesNotExist
, DirNotEmpty
#if !defined(TAR)
, ArchiveResult
#endif
@@ -257,6 +271,8 @@ installPackedGHC :: ( MonadMask m
installPackedGHC dl msubdir inst ver = do
PlatformRequest {..} <- lift getPlatformReq
liftE $ installDestSanityCheck inst
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
@@ -270,6 +286,22 @@ installPackedGHC dl msubdir inst ver = do
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver)
where
-- | Does basic checks for isolated installs
-- Isolated Directory:
-- 1. if it doesn't exist -> proceed
-- 2. if it exists and is empty -> proceed
-- 3. if it exists and is non-empty -> panic and leave the house
installDestSanityCheck :: ( MonadIO m
, MonadCatch m
) =>
FilePath ->
Excepts '[DirNotEmpty] m ()
installDestSanityCheck isoDir = do
hideErrorDef [doesNotExistErrorType] () $ do
contents <- liftIO $ getDirectoryContentsRecursive isoDir
unless (null contents) (throwE $ DirNotEmpty isoDir)
-- | Install an unpacked GHC distribution. This only deals with the GHC
@@ -300,10 +332,6 @@ installUnpackedGHC path inst ver = do
setModificationTime dest mtime
#else
PlatformRequest {..} <- lift getPlatformReq
liftIO $ copyDirectoryRecursive path inst $ \source dest -> do
mtime <- getModificationTime source
copyFile source dest
setModificationTime dest mtime
let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
@@ -343,6 +371,7 @@ installGHCBin :: ( MonadFail m
, MonadUnliftIO m
)
=> Version -- ^ the version to install
-> Maybe FilePath -- ^ isolated install filepath, if user passed any
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@@ -352,15 +381,16 @@ installGHCBin :: ( MonadFail m
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
, DirNotEmpty
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installGHCBin ver = do
installGHCBin ver isoFilepath = do
dlinfo <- liftE $ getDownloadInfo GHC ver
installGHCBindist dlinfo ver
installGHCBindist dlinfo ver isoFilepath
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@@ -379,6 +409,7 @@ installCabalBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath -- ^ isolated install filepath, if user provides any.
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -391,23 +422,28 @@ installCabalBindist :: ( MonadMask m
#if !defined(TAR)
, ArchiveResult
#endif
, FileAlreadyExistsError
]
m
()
installCabalBindist dlinfo ver = do
installCabalBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ pathIsLink (binDir </> "cabal" <> exeExt)
)
(throwE $ AlreadyInstalled Cabal ver)
case isoFilepath of
Nothing -> -- for regular install check if any previous versions installed
whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ pathIsLink (binDir </> "cabal" <> exeExt)
)
(throwE $ AlreadyInstalled Cabal ver)
_ -> pure () -- check isn't required in isolated installs
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -420,30 +456,37 @@ installCabalBindist dlinfo ver = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installCabal' workdir binDir
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|]
liftE $ installCabalUnpacked workdir isoDir Nothing
-- create symlink if this is the latest version
cVers <- lift $ fmap rights getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
Nothing -> do -- regular install
liftE $ installCabalUnpacked workdir binDir (Just ver)
where
-- | Install an unpacked cabal distribution.
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m ()
installCabal' path inst = do
lift $ $(logInfo) "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' inst
let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile <> exeExt)
destPath
lift $ chmod_755 destPath
-- create symlink if this is the latest version for regular installs
cVers <- lift $ fmap rights getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
-- | Install an unpacked cabal distribution.
installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst mver' = do
lift $ $(logInfo) "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' inst
let destFileName = cabalFile
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile <> exeExt)
destPath
lift $ chmod_755 destPath
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
-- creates a default @cabal -> cabal-x.y.z.q@ symlink for
@@ -462,6 +505,7 @@ installCabalBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath -- isolated install Path, if user provided any
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -474,12 +518,13 @@ installCabalBin :: ( MonadMask m
#if !defined(TAR)
, ArchiveResult
#endif
, FileAlreadyExistsError
]
m
()
installCabalBin ver = do
installCabalBin ver isoFilepath = do
dlinfo <- liftE $ getDownloadInfo Cabal ver
installCabalBindist dlinfo ver
installCabalBindist dlinfo ver isoFilepath
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
@@ -498,6 +543,7 @@ installHLSBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath -- ^ isolated install path, if user passed any
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -513,14 +559,19 @@ installHLSBindist :: ( MonadMask m
]
m
()
installHLSBindist dlinfo ver = do
installHLSBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver)
case isoFilepath of
Nothing ->
-- we only check for already installed in regular (non-isolated) installs
whenM (lift (hlsInstalled ver))
(throwE $ AlreadyInstalled HLS ver)
_ -> pure ()
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -533,46 +584,55 @@ installHLSBindist dlinfo ver = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installHLS' workdir binDir
case isoFilepath of
Just isoDir -> do
lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|]
liftE $ installHLSUnpacked workdir isoDir Nothing
-- create symlink if this is the latest version
hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
Nothing -> do
liftE $ installHLSUnpacked workdir binDir (Just ver)
where
-- | Install an unpacked hls distribution.
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m ()
installHLS' path inst = do
lift $ $(logInfo) "Installing HLS"
liftIO $ createDirRecursive' inst
-- create symlink if this is the latest version in a regular install
hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
path
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
let toF = dropSuffix exeExt f
<> "~" <> T.unpack (prettyVer ver) <> exeExt
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> f)
(inst </> toF)
lift $ chmod_755 (inst </> toF)
-- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper"
toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt
-- | Install an unpacked hls distribution.
installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> Excepts '[CopyError] m ()
installHLSUnpacked path inst mver' = do
lift $ $(logInfo) "Installing HLS"
liftIO $ createDirRecursive' inst
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
path
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
let toF = dropSuffix exeExt f
<> maybe "" (("~" <>) . T.unpack . prettyVer) mver'
<> exeExt
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper <> exeExt)
(path </> f)
(inst </> toF)
lift $ chmod_755 (inst </> toF)
-- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper"
toF = wrapper
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> exeExt
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper <> exeExt)
(inst </> toF)
lift $ chmod_755 (inst </> toF)
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
@@ -590,6 +650,7 @@ installHLSBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -605,9 +666,9 @@ installHLSBin :: ( MonadMask m
]
m
()
installHLSBin ver = do
installHLSBin ver isoFilepath = do
dlinfo <- liftE $ getDownloadInfo HLS ver
installHLSBindist dlinfo ver
installHLSBindist dlinfo ver isoFilepath
-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and
@@ -627,6 +688,7 @@ installStackBin :: ( MonadMask m
, MonadFail m
)
=> Version
-> Maybe FilePath
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -642,9 +704,9 @@ installStackBin :: ( MonadMask m
]
m
()
installStackBin ver = do
installStackBin ver isoFilepath = do
dlinfo <- liftE $ getDownloadInfo Stack ver
installStackBindist dlinfo ver
installStackBindist dlinfo ver isoFilepath
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
@@ -663,6 +725,7 @@ installStackBindist :: ( MonadMask m
)
=> DownloadInfo
-> Version
-> Maybe FilePath
-> Excepts
'[ AlreadyInstalled
, CopyError
@@ -678,14 +741,18 @@ installStackBindist :: ( MonadMask m
]
m
()
installStackBindist dlinfo ver = do
installStackBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver)
case isoFilepath of
Nothing -> -- check previous versions in case of regular installs
whenM (lift (stackInstalled ver))
(throwE $ AlreadyInstalled Stack ver)
_ -> pure () -- don't do shit for isolates
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
@@ -698,31 +765,37 @@ installStackBindist dlinfo ver = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installStack' workdir binDir
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|]
liftE $ installStackUnpacked workdir isoDir Nothing
Nothing -> do -- regular install
liftE $ installStackUnpacked workdir binDir (Just ver)
-- create symlink if this is the latest version
sVers <- lift $ fmap rights getInstalledStacks
let lInstStack = headMay . reverse . sort $ sVers
when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
where
-- | Install an unpacked stack distribution.
installStack' :: (MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m ()
installStack' path inst = do
lift $ $(logInfo) "Installing stack"
let stackFile = "stack"
liftIO $ createDirRecursive' inst
let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile <> exeExt)
destPath
lift $ chmod_755 destPath
-- create symlink if this is the latest version and a regular install
sVers <- lift $ fmap rights getInstalledStacks
let lInstStack = headMay . reverse . sort $ sVers
when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
-- | Install an unpacked stack distribution.
installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated installs
-> Excepts '[CopyError] m ()
installStackUnpacked path inst mver' = do
lift $ $(logInfo) "Installing stack"
let stackFile = "stack"
liftIO $ createDirRecursive' inst
let destFileName = stackFile
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile <> exeExt)
destPath
lift $ chmod_755 destPath
---------------------
@@ -1704,6 +1777,7 @@ compileGHC :: ( MonadMask m
-> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour
-> Bool
-> Maybe FilePath -- ^ isolate dir
-> Excepts
'[ AlreadyInstalled
, BuildFailed
@@ -1716,13 +1790,14 @@ compileGHC :: ( MonadMask m
, UnknownArchive
, TarDirDoesNotExist
, NotInstalled
, DirNotEmpty
#if !defined(TAR)
, ArchiveResult
#endif
]
m
GHCTargetVersion
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian
compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian isolateDir
= do
PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -1792,12 +1867,18 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
alreadyInstalled <- lift $ ghcInstalled installVer
alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver)
when alreadyInstalled $ do
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|]
case isolateDir of
Just isoDir ->
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Isolate installing to #{isoDir} |]
Nothing ->
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|]
lift $ $(logWarn)
"...waiting for 10 seconds before continuing, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
ghcdir <- lift $ ghcupGHCDir installVer
ghcdir <- case isolateDir of
Just isoDir -> pure isoDir
Nothing -> lift $ ghcupGHCDir installVer
bghc <- case bstrap of
Right g -> pure $ Right g
@@ -1814,9 +1895,14 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
pure (b, bmk)
)
when alreadyInstalled $ do
lift $ $(logInfo) [i|Deleting existing installation|]
liftE $ rmGHCVer tver
case isolateDir of
Nothing ->
-- only remove old ghc in regular installs
when alreadyInstalled $ do
lift $ $(logInfo) [i|Deleting existing installation|]
liftE $ rmGHCVer tver
_ -> pure ()
forM_ mBindist $ \bindist -> do
liftE $ installPackedGHC bindist
@@ -1825,11 +1911,15 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
(tver ^. tvVersion)
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
reThrowAll GHCupSetError $ postGHCInstall tver
-- restore
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
case isolateDir of
-- set and make symlinks for regular (non-isolated) installs
Nothing -> do
reThrowAll GHCupSetError $ postGHCInstall tver
-- restore
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
_ -> pure ()
pure tver
@@ -2189,6 +2279,7 @@ upgradeGHCup mtarget force' = do
-------------
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist.
postGHCInstall :: ( MonadReader env m

View File

@@ -172,21 +172,31 @@ getBase :: ( MonadReader env m
-> Excepts '[JSONError] m GHCupInfo
getBase uri = do
Settings { noNetwork } <- lift getSettings
yaml <- lift $ yamlFromCache uri
unless noNetwork $
handleIO (\e -> warnCache (displayException e))
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> warnCache (prettyShow e))
. reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
. smartDl
$ uri
-- try to download yaml... usually this writes it into cache dir,
-- but in some cases not (e.g. when using file://), so we honour
-- the return filepath, if any
mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through
then pure Nothing
else handleIO (\e -> warnCache (displayException e) >> pure Nothing)
. catchE @_ @_ @'[] (\e@(DownloadFailed _) -> warnCache (prettyShow e) >> pure Nothing)
. reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
. fmap Just
. smartDl
$ uri
-- if we didn't get a filepath from the download, use the cached yaml
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
lift $ $(logDebug) [i|Decoding yaml at: #{actualYaml}|]
liftE
. onE_ (onError yaml)
. onE_ (onError actualYaml)
. lEM' @_ @_ @'[JSONError] JSONDecodeError
. fmap (first (\e -> [i|#{displayException e}
Consider removing "#{yaml}" manually.|]))
Consider removing "#{actualYaml}" manually.|]))
. liftIO
. Y.decodeFileEither
$ yaml
$ actualYaml
where
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-- may re-download and succeed.
@@ -221,28 +231,32 @@ Consider removing "#{yaml}" manually.|]))
, DigestError
]
m1
()
FilePath
smartDl uri' = do
json_file <- lift $ yamlFromCache uri'
let scheme = view (uriSchemeL' % schemeBSL') uri'
e <- liftIO $ doesFileExist json_file
currentTime <- liftIO getCurrentTime
if e
then do
accessTime <- liftIO $ getAccessTime json_file
Dirs { cacheDir } <- lift getDirs
-- access time won't work on most linuxes, but we can try regardless
when ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) $
-- no access in last 5 minutes, re-check upstream mod time
dlWithMod currentTime json_file
else
dlWithMod currentTime json_file
-- for local files, let's short-circuit and ignore access time
if | scheme == "file" -> liftE $ download uri' Nothing cacheDir Nothing True
| e -> do
accessTime <- liftIO $ getAccessTime json_file
-- access time won't work on most linuxes, but we can try regardless
if | ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) ->
-- no access in last 5 minutes, re-check upstream mod time
dlWithMod currentTime json_file
| otherwise -> pure json_file
| otherwise -> dlWithMod currentTime json_file
where
dlWithMod modTime json_file = do
let (dir, fn) = splitFileName json_file
f <- liftE $ download uri' Nothing dir (Just fn) True
liftIO $ setModificationTime f modTime
liftIO $ setAccessTime f modTime
pure f
getDownloadInfo :: ( MonadReader env m
@@ -304,27 +318,25 @@ download :: ( MonadReader env m
)
=> URI
-> Maybe T.Text -- ^ expected hash
-> FilePath -- ^ destination dir
-> FilePath -- ^ destination dir (ignored for file:// scheme)
-> Maybe FilePath -- ^ optional filename
-> Bool -- ^ whether to read an write etags
-> Excepts '[DigestError , DownloadFailed] m FilePath
download uri eDigest dest mfn etags
| scheme == "https" = dl
| scheme == "http" = dl
| scheme == "file" = cp
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ path
lift $ $(logDebug) [i|using local file: #{destFile'}|]
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where
scheme = view (uriSchemeL' % schemeBSL') uri
cp = do
-- destination dir must exist
liftIO $ createDirRecursive' dest
let fromFile = T.unpack . decUTF8Safe $ path
liftIO $ copyFile fromFile destFile
pure destFile
dl = do
let uri' = decUTF8Safe (serializeURIRef' uri)
lift $ $(logInfo) [i|downloading: #{uri'}|]
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
lift $ $(logInfo) [i|downloading: #{uri'} as file #{destFile}|]
-- destination dir must exist
liftIO $ createDirRecursive' dest
@@ -366,7 +378,7 @@ download uri eDigest dest mfn etags
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
writeEtags (parseEtags headers)
writeEtags destFile (parseEtags headers)
else
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
@@ -383,13 +395,13 @@ download uri eDigest dest mfn etags
case _exitCode of
ExitSuccess -> do
liftIO $ copyFile destFileTemp destFile
writeEtags (parseEtags (decUTF8Safe' _stdErr))
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
ExitFailure i'
| i' == 8
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-> do
$logDebug "Not modified, skipping download"
writeEtags (parseEtags (decUTF8Safe' _stdErr))
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
| otherwise -> throwE (NonZeroExit i' "wget" opts)
else do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
@@ -404,10 +416,10 @@ download uri eDigest dest mfn etags
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags (pure $ Just etag))
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do
r <- downloadToFile https host fullPath port destFile addHeaders
writeEtags (pure $ decUTF8Safe <$> getHeader r "etag")
writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
else void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
@@ -420,12 +432,18 @@ download uri eDigest dest mfn etags
-- Manage to find a file we can write the body into.
destFile :: FilePath
destFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
(dest </>)
mfn
getDestFile :: Monad m => Excepts '[NoUrlBase] m FilePath
getDestFile =
case mfn of
Just fn -> pure (dest </> fn)
Nothing
| let urlBase = T.unpack (decUTF8Safe (urlBaseName path))
, not (null urlBase) -> pure (dest </> urlBase)
-- TODO: remove this once we use hpath again
| otherwise -> throwE $ NoUrlBase uri'
path = view pathL' uri
uri' = decUTF8Safe (serializeURIRef' uri)
parseEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags stderr = do
@@ -444,8 +462,8 @@ download uri eDigest dest mfn etags
$logDebug "No etags header found"
pure Nothing
writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => m (Maybe T.Text) -> m ()
writeEtags getTags = do
writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags destFile getTags = do
getTags >>= \case
Just t -> do
$logDebug [i|Writing etagsFile #{(etagsFile destFile)}|]

View File

@@ -134,6 +134,13 @@ instance Pretty AlreadyInstalled where
pPrint (AlreadyInstalled tool ver') =
text [i|#{tool}-#{prettyShow ver'} is already installed|]
-- | The Directory is supposed to be empty, but wasn't.
data DirNotEmpty = DirNotEmpty {path :: FilePath}
instance Pretty DirNotEmpty where
pPrint (DirNotEmpty path) = do
text [i|The directory was expected to be empty, but isn't: #{path}|]
-- | The tool is not installed. Some operations rely on a tool
-- to be installed (such as setting the current GHC version).
data NotInstalled = NotInstalled Tool GHCTargetVersion
@@ -168,6 +175,16 @@ instance Pretty FileDoesNotExistError where
pPrint (FileDoesNotExistError file) =
text [i|File "#{file}" does not exist.|]
-- | The file already exists
-- (e.g. when we use isolated installs with the same path).
-- (e.g. This is done to prevent any overwriting)
data FileAlreadyExistsError = FileAlreadyExistsError FilePath
deriving Show
instance Pretty FileAlreadyExistsError where
pPrint (FileAlreadyExistsError file) =
text [i|File "#{file}" Already exists.|]
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
@@ -327,6 +344,15 @@ instance Pretty UnexpectedListLength where
instance Exception UnexpectedListLength
data NoUrlBase = NoUrlBase Text
deriving Show
instance Pretty NoUrlBase where
pPrint (NoUrlBase url) =
text [i|Couldn't get a base filename from url #{url}|]
instance Exception NoUrlBase
------------------------