Fixup rest of the PR

This reverts commit 300cfd3ba6.

.gitlab-ci.yml

@@ -99,11 +99,12 @@ variables:
   script:
     - bash ./.gitlab/script/ghcup_version.sh
   variables:
-    JSON_VERSION: "0.0.5"
+    JSON_VERSION: "0.0.6"
   artifacts:
     expire_in: 2 week
     paths:
       - golden
+      - dist-newstyle/cache/
     when: on_failure
 
 # .test_ghcup_scoop:
@@ -202,10 +203,11 @@ variables:
     expire_in: 2 week
     paths:
       - out
+      - dist-newstyle/cache/
   only:
     - tags
   variables:
-    JSON_VERSION: "0.0.5"
+    JSON_VERSION: "0.0.6"
 
 ######## stack test ########
 
@@ -281,11 +283,31 @@ test:linux:cross-armv7:
     CROSS: "arm-linux-gnueabihf"
   needs: []
   when: manual
+  allow_failure: true
   before_script:
     - ./.gitlab/before_script/linux/install_deps.sh
   script:
     - ./.gitlab/script/ghcup_cross.sh
 
+test:linux:git:hadrian:
+  stage: test
+  extends:
+    - .test_ghcup_version
+    - .debian
+  variables:
+    GHC_VERSION: "8.10.5"
+    GHC_GIT_TAG: "ghc-9.0.1-release"
+    GHC_GIT_VERSION: "9.0.1"
+    CABAL_VERSION: "3.4.0.0"
+    CROSS: ""
+  needs: []
+  when: manual
+  allow_failure: true
+  before_script:
+    - ./.gitlab/before_script/linux/install_deps.sh
+  script:
+    - ./.gitlab/script/ghcup_git.sh
+
 
 ######## linux 32bit test ########
 

.gitlab/script/ghcup_git.sh

@@ -0,0 +1,52 @@
+#!/bin/sh
+
+set -eux
+
+. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
+
+mkdir -p "$CI_PROJECT_DIR"/.local/bin
+
+CI_PROJECT_DIR=$(pwd)
+
+ecabal() {
+	cabal "$@"
+}
+
+eghcup() {
+	ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
+}
+
+git describe --always
+
+### build
+
+ecabal update
+
+ecabal build -w ghc-${GHC_VERSION}
+cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup
+
+### cleanup
+
+rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
+
+### manual cli based testing
+
+eghcup --numeric-version
+
+eghcup install ghc ${GHC_VERSION}
+eghcup set ghc ${GHC_VERSION}
+eghcup install cabal ${CABAL_VERSION}
+
+cabal --version
+
+eghcup debug-info
+
+eghcup compile ghc -j $(nproc) -g ${GHC_GIT_TAG} -b ${GHC_VERSION} -- --enable-unregisterised
+eghcup set ghc ${GHC_GIT_VERSION}
+
+[ `$(eghcup whereis ghc ${GHC_GIT_VERSION}) --numeric-version` = "${GHC_GIT_VERSION}" ]
+
+# nuke
+eghcup nuke
+[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
+

.gitlab/script/ghcup_version.sh

@@ -12,6 +12,10 @@ ecabal() {
 	cabal "$@"
 }
 
+raw_eghcup() {
+	ghcup -v -c "$@"
+}
+
 eghcup() {
 	if [ "${OS}" = "WINDOWS" ] ; then
 		ghcup -v -c -s file:/$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
@@ -20,6 +24,12 @@ eghcup() {
 	fi
 }
 
+if [ "${OS}" = "WINDOWS" ] ; then
+	GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
+else
+	GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
+fi
+
 git describe --always
 
 ### build
@@ -65,11 +75,7 @@ fi
 
 ### cleanup
 
-if [ "${OS}" = "WINDOWS" ] ; then
-	rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
-else
-	rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
-fi
+rm -rf "${GHCUP_DIR}"
 
 ### manual cli based testing
 
@@ -88,6 +94,7 @@ cabal --version
 
 eghcup debug-info
 
+# also test etags
 eghcup list
 eghcup list -t ghc
 eghcup list -t cabal
@@ -109,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
@@ -155,6 +175,55 @@ if [ "${OS}" = "LINUX" ] ; then
 	fi
 fi
 
+sha_sum() {
+	if [ "${OS}" = "FREEBSD" ] ; then
+		sha256 "$@"
+	else
+		sha256sum "$@"
+	fi
+
+}
+
+# test etags
+rm -f "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
+raw_eghcup -s https://www.haskell.org/ghcup/data/ghcup-${JSON_VERSION}.yaml list
+# snapshot yaml and etags file
+etag=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
+sha=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
+# invalidate access time timer, which is 5minutes, so we re-download
+touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
+# redownload same file with some newlines added
+raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
+# snapshot new yaml and etags file
+etag2=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
+sha2=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
+# compare
+[ "${etag}" != "${etag2}" ]
+[ "${sha}" != "${sha2}" ]
+# invalidate access time timer, which is 5minutes, but don't expect a re-download
+touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
+# this time, we expect the same hash and etag
+raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
+etag3=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
+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
@@ -162,8 +231,4 @@ eghcup upgrade -f
 
 # nuke
 eghcup nuke
-if [ "${OS}" = "WINDOWS" ] ; then
-	[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/ghcup" ]
-else
-	[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
-fi
+[ ! -e "${GHCUP_DIR}" ]

.travis.yml

@@ -0,0 +1,25 @@
+jobs:
+  include:
+    - os: osx
+      osx_image: xcode10.1
+      language: generic
+      env: ARTIFACT=x86_64-apple-darwin-10.13-ghcup
+
+    - os: osx
+      osx_image: xcode11.3
+      language: generic
+      env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
+
+
+script: ".travis/build.sh"
+
+deploy:
+  provider: releases
+  api_key:
+    secure: "hT2od8Iy04tdFVuonPSWv0NX5hZDmv4al8Q0GbIWmviUetROuM7c6/MCHUcgyiw6H2L3pmH4F24GBYWpKBT3ZMbxrKXhZOZ3KPLXzlnuRlm1qymKqqwsJs3466bMftaiBr16rx1VpAuditN4A32oSmTFcQAJc84Bxn2WZ4t8hk9muS8YPyLhqg3/NxT6ob8dzNp9eS2cA0WODMb/fMzaMruRtepSK8JvuXb/SnTvaDcl9plmPzEa+eW54jwVsDps8ZpQMQlTtGIjYHIwTQ36/iLH4LoAvD7OEnB7qf753LOzmI/bvlB75xYGsLxe1qgpzPMjuG3AK0jb2KGSZCzyAyrbBFSQMIyC1gNKMtab3CohnA9WdQqAT1xrzPzA9zNw516G5Fn/z+t9Ek1f6L2OYO2hJfweNhWh+ChAIsOags2QBpqc0qjkwUS4wqxCWBdyVfgPTUoGelvjCfjQgypgIyLEHFvXt9rlj+kd97FY7nG3vxZrsvWTKKKT551OqUYX5zWTyvGR71jKyNst/p93Pg3DkRy31gHrGnG9zfNgN5tWxJqDd/suR/BAFTp0VtkFb8fR3ct7WMVeJXtE2+bKqxO5Fnocs1VjEm8pKPk7glnp0muu08kaO0h54wiSOCbk1RvO1KZtHue4wKWrHcI18dwW2WtzoBQ4P1lOSkS81UY="
+  file: $ARTIFACT
+  on:
+    repo: hasufell/ghcup-hs
+    tags: true
+  skip_cleanup: true
+  draft: true

.travis/build.sh

@@ -0,0 +1,28 @@
+#!/bin/sh
+
+set -ex
+
+mkdir -p ~/.ghcup/bin
+curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ~/.ghcup/bin/ghcup
+chmod +x ~/.ghcup/bin/ghcup
+
+export PATH="$HOME/.ghcup/bin:$PATH"
+
+ghcup install 8.10.4
+ghcup install-cabal 3.4.0.0
+ghcup set 8.10.4
+
+
+## install ghcup
+
+cabal update
+
+(
+       cd /tmp
+       cabal install --installdir="$HOME"/.ghcup/bin hspec-discover
+)
+
+cabal build --constraint="zlib +static" --constraint="lzma +static" -ftui
+cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
+strip ./ghcup
+cp ghcup "./${ARTIFACT}"

CHANGELOG.md

@@ -1,8 +1,23 @@
 # Revision history for ghcup
 
-## 0.1.16 -- ????-??-??
+## 0.1.16.1 -- 2021-07-29
 
 * Add 'nuke' subcommand wrt [#135](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/135), implemented by Arjun Kathuria
+* Add uninstallation powershell script on windows wrt [#150](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/150)
+* Improve logging
+* Fix building GHC cross compiler wrt [#180](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/180)
+* Allow to use hadrian as build system (for git based versions only) wrt [#35](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/35)
+* Allow passing `--flavor` to `ghcup compile ghc`
+* Support new GHC `bin/` directory format wrt [ghc/ghc#20074](https://gitlab.haskell.org/ghc/ghc/-/issues/20074#note_363720)
+* Implement `whereis` subcommand wrt [#173](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/173)
+* Add `--offline` switch and `prefetch` subcommand wrt [#186](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/186)
+* Implement ETAGs hashing for metadata downloads to speed up `ghcup list` wrt [#193](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/193)
+* Avoid unnecessary fetching of ghcup metadata in some commands
+* Avoid unnecessary update checks for some commands
+* Preserve mtimes on unpacked GHC tarballs on windows wrt [#187](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/187), fixing issues with `ghc-pkg`
+* Fix lesser bug in `ghcup list` for stray stack versions wrt [#183](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/183)
+* Major redo on how file removal on windows works, avoiding partial removals etc, wrt [#165](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/165)
+* Improve ghcup tui for screen readers wrt [github/#4](https://github.com/haskell/ghcup-hs/pull/4), thanks to Mario Lang
 
 ## 0.1.15.2 -- 2021-06-13
 

README.md

@@ -18,6 +18,7 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
      * [XDG support](#xdg-support)
      * [Env variables](#env-variables)
      * [Installing custom bindists](#installing-custom-bindists)
+     * [Tips and tricks](#tips-and-tricks)
    * [Design goals](#design-goals)
    * [How](#how)
    * [Known users](#known-users)
@@ -154,6 +155,53 @@ and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
 GHCup always needs to know which version the bindist corresponds to (this is not automatically
 detected).
 
+### Tips and tricks
+
+#### with_ghc wrapper (e.g. for HLS)
+
+Due to some HLS [bugs](https://github.com/mpickering/hie-bios/issues/194) it's necessary that the `ghc` in PATH
+is the one defined in `cabal.project`. With some simple shell functions, we can start our editor with the appropriate
+path prepended.
+
+For bash, in e.g. `~/.bashrc` define:
+
+```sh
+with_ghc() {
+  local np=$(ghcup --offline whereis -d ghc $1 || { ghcup --cache install ghc $1 && ghcup whereis -d ghc $1 ;})
+  if [ -e "${np}" ] ; then
+    shift
+    PATH="$np:$PATH" "$@"
+  else
+    >&2 echo "Cannot find or install GHC version $1"
+    return 1
+  fi
+}
+```
+
+For fish shell, in e.g. `~/.config/fish/config.fish` define:
+
+```fish
+function with_ghc
+  set --local np (ghcup --offline whereis -d ghc $argv[1] ; or begin ghcup --cache install ghc $argv[1] ; and ghcup whereis -d ghc $argv[1] ; end)
+  if test -e "$np"
+    PATH="$np:$PATH" $argv[2..-1]
+  else
+    echo "Cannot find or install GHC version $argv[1]" 1>&2
+    return 1
+  end
+end
+```
+
+Then start a new shell and issue:
+
+```sh
+# replace 'code' with your editor
+with_ghc 8.10.5 code path/to/haskell/source
+```
+
+Cabal and HLS will now see `8.10.5` as the primary GHC, without the need to
+run `ghcup set` all the time when switching between projects.
+
 ## Design goals
 
 1. simplicity
@@ -230,16 +278,110 @@ to figure out whether you have the correct toolchain and
 the correct dependencies. Refer to [the official docs](https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation/Linux)
 on how to prepare your environment for building GHC.
 
+### Stack support
+
+There may be a number of bugs when trying to make ghcup installed GHC versions work with stack,
+such as:
+
+- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/188
+
+Further, stack's upgrade procedure may break/confuse ghcup. There are a number of integration
+issues discussed here:
+
+- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/153
+
+### Windows support
+
+Windows support is in early stages. Since windows doesn't support symbolic links properly,
+ghcup uses a [shimgen wrapper](https://github.com/71/scoop-better-shimexe). It seems to work
+well, but there may be unknown issues with that approach.
+
+Windows 7 and Powershell 2.0 aren't well supported at the moment, also see:
+
+- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/140
+- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/197
+
 ## FAQ
 
-1. Why reimplement stack?
+### Why reimplement stack?
 
-ghcup is not a reimplementation of stack. The only common part is automatic installation of GHC, but even that differs in scope and design.
+GHCup is not a reimplementation of stack. The only common part is automatic installation of GHC,
+but even that differs in scope and design.
 
-2. Why not support windows?
+### Why should I use ghcup over stack?
 
-We do.
+GHCup is not a replacement for stack. Instead, it supports installing and managing stack versions.
+It does the same for cabal, GHC and HLS. As such, It doesn't make a workflow choice for you.
 
-3. Why the haskell reimplementation?
+### Why should I let ghcup manage stack?
 
-:-)
+You don't need to. However, some users seem to prefer to have a central tool that manages cabal and stack
+at the same time. Additionally, it can allow better sharing of GHC installation across these tools.
+Also see:
+
+* https://docs.haskellstack.org/en/stable/yaml_configuration/#system-ghc
+* https://github.com/commercialhaskell/stack/pull/5585
+
+### Why does ghcup not use stack code?
+
+Oddly, this question has been asked a couple of times. For the curious, here are a few reasons:
+
+1. GHCup started as a shell script. At the time of rewriting it in Haskell, the authors didn't even know that stack exposes *some* of its [installation API](https://hackage.haskell.org/package/stack-2.5.1.1/docs/Stack-Setup.html)
+2. Even if they did, it doesn't seem it would have satisfied their needs
+	  - it didn't support cabal installation, which was the main motivation behind GHCup back then
+	  - depending on a codebase as big as stack for a central part of one's application without having a short contribution pipeline would likely have caused stagnation or resulted in simply copy-pasting the relevant code in order to adjust it
+	  - it's not clear how GHCup would have been implemented with the provided API. It seems the codebases are fairly different. GHCup does a lot of symlink handling to expose a central `bin/` directory that users can easily put in PATH, without having to worry about anything more. It also provides explicit removal functionality, GHC cross-compilation, a TUI, etc etc.
+3. GHCup is built around unix principles and supposed to be simple.
+
+### Why not unify...
+
+#### ...stack and Cabal and do away with standalone installers
+
+GHCup is not involved in such decisions. cabal-install and stack might have a
+sufficiently different user experience to warrant having a choice.
+
+#### ...installer implementations and have a common library
+
+This sounds like an interesting goal. However, GHC installation isn't a hard engineering problem
+and the shared code wouldn't be too exciting. For such an effort to make sense, all involved
+parties would need to collaborate and have a short pipeline to get patches in.
+
+It's true this would solve the integration problem, but following unix principles, we can
+do similar via **hooks**. Both cabal and stack can support installation hooks. These hooks
+can then call into ghcup or anything else, also see:
+
+* https://github.com/haskell/cabal/issues/7394
+* https://github.com/commercialhaskell/stack/pull/5585
+
+#### ...installers (like, all of it)
+
+So far, there hasn't been an **open** discussion about this. Is this even a good idea?
+Sometimes projects converge eventually if their overlap is big enough, sometimes they don't.
+
+While unification sounds like a simplification of the ecosystem, it also takes away choice.
+Take `curl` and `wget` as an example.
+
+How bad do we need this?
+
+### Why not support windows?
+
+Windows is supported since GHCup version 0.1.15.1.
+
+### Why the haskell reimplementation?
+
+GHCup started as a portable posix shell script of maybe 50 LOC. GHC installation itself can be carried out in
+about ~3 lines of shell code (download, unpack , configure+make install). However, much convenient functionality
+has been added since, as well as ensuring that all operations are safe and correct. The shell script ended up with
+over 2k LOC, which was very hard to maintain.
+
+The main concern when switching from a portable shell script to haskell was platform/architecture support.
+However, ghcup now re-uses GHCs CI infrastructure and as such is perfectly in sync with all platforms that
+GHC supports.
+
+### Is GHCup affiliated with the Haskell Foundation?
+
+There has been some collaboration: Windows and Stack support were mainly requested by the Haskell Foundation
+and those seemed interesting features to add.
+
+Other than that, GHCup is dedicated only to its users and is supported by haskell.org through hosting and CI
+infrastructure.

app/ghcup-gen/Validate.hs

@@ -126,7 +126,7 @@ validate dls _ = do
         _ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
 
   checkUniqueTags tool = do
-    let allTags = join $ M.elems $ availableToolVersions dls tool
+    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
     let nonUnique =
           fmap fst
             .   filter (\(_, b) -> not b)
@@ -164,7 +164,7 @@ validate dls _ = do
 
   -- a tool must have at least one of each mandatory tags
   checkMandatoryTags tool = do
-    let allTags = join $ M.elems $ availableToolVersions dls tool
+    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
     forM_ [Latest, Recommended] $ \t -> case elem t allTags of
       False -> do
         lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
@@ -174,7 +174,7 @@ validate dls _ = do
   -- all GHC versions must have a base tag
   checkGHCHasBaseVersion = do
     let allTags = M.toList $ availableToolVersions dls GHC
-    forM allTags $ \(ver, tags) -> case any isBase tags of
+    forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
       False -> do
         lift $ $(logError) [i|Base tag missing from GHC ver #{ver}|]
         addError
@@ -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
@@ -256,7 +256,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
         case etool of
           Right (Just GHCup) -> do
             tmpUnpack <- lift mkGhcupTmpDir
-            _ <- liftE $ download dli tmpUnpack Nothing
+            _ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
             pure Nothing
           Right _ -> do
             p <- liftE $ downloadCached dli Nothing
@@ -266,7 +266,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
               $ p
           Left ShimGen -> do
             tmpUnpack <- lift mkGhcupTmpDir
-            _ <- liftE $ download dli tmpUnpack Nothing
+            _ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
             pure Nothing
     case r of
       VRight (Just basePath) -> do

app/ghcup/BrickMain.hs

@@ -59,7 +59,7 @@ import qualified Data.Vector                   as V
 
 
 hiddenTools :: [Tool]
-hiddenTools = [Stack]
+hiddenTools = []
 
 
 data BrickData = BrickData
@@ -169,7 +169,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
           | elem Latest lTag && not lInstalled =
               withAttr "hooray"
           | otherwise = id
-        active = if b then forceAttr "active" else id
+        active = if b then putCursor "GHCup" (Location (0,0)) . forceAttr "active" else id
     in  hooray $ active $ dim
           (   marks
           <+> padLeft (Pad 2)
@@ -257,7 +257,7 @@ app attrs dimAttrs =
   , appHandleEvent  = eventHandler
   , appStartEvent   = return
   , appAttrMap      = const attrs
-  , appChooseCursor = neverShowCursor
+  , appChooseCursor = showFirstCursor
   }
 
 defaultAttributes :: Bool -> AttrMap
@@ -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

app/ghcup/Main.hs

@@ -34,6 +34,7 @@ import           GHCup.Version
 import           Codec.Archive
 #endif
 import           Control.Concurrent
+import           Control.Concurrent.Async
 import           Control.DeepSeq                ( force )
 import           Control.Exception              ( evaluate )
 import           Control.Exception.Safe
@@ -137,6 +138,7 @@ data InstallOptions = InstallOptions
   , instPlatform :: Maybe PlatformRequest
   , instBindist  :: Maybe URI
   , instSet      :: Bool
+  , isolateDir   :: Maybe FilePath
   }
 
 data SetCommand = SetGHC SetOptions
@@ -182,6 +184,9 @@ data GHCCompileOptions = GHCCompileOptions
   , addConfArgs  :: [Text]
   , setCompile   :: Bool
   , ovewrwiteVer :: Maybe Version
+  , buildFlavour :: Maybe String
+  , hadrian      :: Bool
+  , isolateDir   :: Maybe FilePath
   }
 
 data UpgradeOpts = UpgradeInplace
@@ -571,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)
@@ -600,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)
@@ -987,6 +1001,25 @@ ghcCompileOpts =
               "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
             )
           )
+    <*> optional
+          (option
+            str
+            (short 'f' <> long "flavour" <> metavar "BUILD_FLAVOUR" <> help
+              "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
+            )
+          )
+    <*> 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
@@ -1048,6 +1081,7 @@ tagCompleter tool add = listIOCompleter $ do
     VRight ghcupInfo -> do
       let allTags = filter (\t -> t /= Old)
             $ join
+            $ fmap _viTags
             $ M.elems
             $ availableToolVersions (_ghcupDownloads ghcupInfo) tool
       pure $ nub $ (add ++) $ fmap tagToString allTags
@@ -1201,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
@@ -1330,7 +1368,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           (settings, keybindings) <- toSettings opt
 
           -- logger interpreter
-          logfile <- initGHCupFileLogging logsDir
+          logfile <- flip runReaderT dirs $ initGHCupFileLogging
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
                 , colorOutter  = B.hPut stderr
@@ -1374,9 +1412,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             exitWith (ExitFailure 2)
                 let s' = AppState settings dirs keybindings ghcupInfo pfreq
 
-                lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
-                  Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
-                  Just _ -> pure ()
+                race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
+                      (threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{recycleDir} manually|]))
+
+                case optCommand of
+                  Nuke -> pure ()
+                  Whereis _ _ -> pure ()
+                  DInfo -> pure ()
+                  ToolRequirements -> pure ()
+                  ChangeLog _ -> pure ()
+#if defined(BRICK)
+                  Interactive -> pure ()
+#endif
+                  _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
+                         Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
+                         Just _ -> pure ()
 
                 -- TODO: always run for windows
                 (siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
@@ -1406,6 +1456,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           -- Effect interpreters --
           -------------------------
 
+
           let runInstTool' appstate' mInstPlatform =
                 runLogger
                   . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
@@ -1418,6 +1469,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 #endif
                       , FileDoesNotExistError
                       , CopyError
+                      , NotInstalled
+                      , DirNotEmpty
                       , NoDownload
                       , NotInstalled
                       , BuildFailed
@@ -1427,6 +1480,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       , TarDirDoesNotExist
                       , NextVerNotFound
                       , NoToolVersionSet
+                      , FileAlreadyExistsError
                       ]
 
           let runInstTool mInstPlatform action' = do
@@ -1503,6 +1557,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let runRm =
                 runLogger . runAppState . runE @'[NotInstalled]
 
+          let runNuke s' =
+                runLogger . flip runReaderT s' . runE @'[NotInstalled]
+
           let runDebugInfo =
                 runLogger
                   . runAppState
@@ -1525,6 +1582,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       , UnknownArchive
                       , TarDirDoesNotExist
                       , NotInstalled
+                      , DirNotEmpty
 #if !defined(TAR)
                       , ArchiveResult
 #endif
@@ -1587,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"
@@ -1631,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
@@ -1640,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
@@ -1659,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
@@ -1671,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
@@ -1690,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
@@ -1906,6 +1968,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                         runLogger $ $(logError) $ T.pack $ prettyShow e
                         pure $ ExitFailure 8
 
+            Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
+              runLogger $ $(logError) "Hadrian cross compile support is not yet implemented!"
+              pure $ ExitFailure 9
             Compile (CompileGHC GHCCompileOptions {..}) ->
               runCompileGHC (do
                 case targetGhc of
@@ -1926,6 +1991,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             buildConfig
                             patchDir
                             addConfArgs
+                            buildFlavour
+                            hadrian
+                            isolateDir
                 GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                 let vi = getVersionInfo (_tvVersion targetVer) GHC dls
                 when setCompile $ void $ liftE $
@@ -1992,22 +2060,25 @@ Make sure to clean up #{tmpdir} afterwards.|])
                 (UpgradeAt p)   -> pure $ Just p
                 UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
 
-              runUpgrade (liftE $ upgradeGHCup target force') >>= \case
-                VRight v' -> do
-                  GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
-                  let pretty_v = prettyVer v'
-                  let vi = fromJust $ snd <$> getLatest dls GHCup
-                  runLogger $ $(logInfo)
-                    [i|Successfully upgraded GHCup to version #{pretty_v}|]
-                  forM_ (_viPostInstall vi) $ \msg ->
-                    runLogger $ $(logInfo) msg
-                  pure ExitSuccess
-                VLeft (V NoUpdate) -> do
-                  runLogger $ $(logWarn) [i|No GHCup update available|]
-                  pure ExitSuccess
-                VLeft e -> do
-                  runLogger $ $(logError) $ T.pack $ prettyShow e
-                  pure $ ExitFailure 11
+              runUpgrade (do
+                v' <- liftE $ upgradeGHCup target force'
+                GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+                pure (v', dls)
+                ) >>= \case
+                  VRight (v', dls) -> do
+                    let pretty_v = prettyVer v'
+                    let vi = fromJust $ snd <$> getLatest dls GHCup
+                    runLogger $ $(logInfo)
+                      [i|Successfully upgraded GHCup to version #{pretty_v}|]
+                    forM_ (_viPostInstall vi) $ \msg ->
+                      runLogger $ $(logInfo) msg
+                    pure ExitSuccess
+                  VLeft (V NoUpdate) -> do
+                    runLogger $ $(logWarn) [i|No GHCup update available|]
+                    pure ExitSuccess
+                  VLeft e -> do
+                    runLogger $ $(logError) $ T.pack $ prettyShow e
+                    pure $ ExitFailure 11
 
             ToolRequirements -> do
               s' <- appState
@@ -2046,7 +2117,8 @@ Make sure to clean up #{tmpdir} afterwards.|])
                     )
                   pure ExitSuccess
                 Just uri -> do
-                  pfreq <- runAppState getPlatformReq
+                  s' <- appState
+                  pfreq <- flip runReaderT s' getPlatformReq
                   let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
                       cmd = case _rPlatform pfreq of
                               Darwin  -> "open"
@@ -2056,7 +2128,6 @@ Make sure to clean up #{tmpdir} afterwards.|])
 
                   if clOpen
                     then do
-                      s' <- appState
                       flip runReaderT s' $
                         exec cmd
                              [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
@@ -2068,10 +2139,10 @@ Make sure to clean up #{tmpdir} afterwards.|])
                                   >> pure (ExitFailure 13)
                     else putStrLn uri' >> pure ExitSuccess
 
-            Nuke ->
-              runRm (do
-                   s' <- liftIO appState
-                   void $ liftIO $ evaluate $ force s'
+            Nuke -> do
+              s' <- liftIO appState
+              void $ liftIO $ evaluate $ force s'
+              runNuke s' (do
                    lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
                    lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
                    liftIO $ threadDelay 10000000  -- wait 10s
@@ -2091,7 +2162,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
                                   runLogger $ $logInfo "Nuclear Annihilation complete!"
                                   pure ExitSuccess
                               | otherwise -> do
-                                  runLogger $ $logWarn "These Files have survived Nuclear Annihilation, you may remove them manually."
+                                  runLogger $ $logError "These Files have survived Nuclear Annihilation, you may remove them manually."
                                   forM_ leftOverFiles putStrLn
                                   pure ExitSuccess
 

bootstrap-haskell

@@ -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
@@ -290,7 +290,16 @@ ask_bashrc() {
 
 			read -r bashrc_answer </dev/tty
 		else
-			return 1
+			# On windows .bashrc isn't an important user config, so we adjust it
+			# always. On other platforms, let's be a bit more conservative.
+			case "${plat}" in
+					MSYS*|MINGW*)
+						return 1
+						;;
+					*)
+						return 0
+						;;
+			esac
 		fi
 		case $bashrc_answer in
 			[Pp]* | "")
@@ -326,7 +335,7 @@ adjust_bashrc() {
 			;;
 		2)
 			cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
-				export PATH="\$HOME/.cabal/bin:\$PATH:${GHCUP_BIN}"
+				export PATH="\$PATH:\$HOME/.cabal/bin:${GHCUP_BIN}"
 				EOF
 			;;
 		*) ;;
@@ -335,7 +344,10 @@ adjust_bashrc() {
 	case $1 in
 		1 | 2)
 			case $MY_SHELL in
-				"") break ;;
+				"")
+					warn_path "Couldn't figure out login shell!"
+					return
+					;;
 				fish)
 					mkdir -p "${GHCUP_PROFILE_FILE%/*}"
 					sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
@@ -365,15 +377,30 @@ adjust_bashrc() {
 					echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
 					break ;;
 			esac
+			echo
+			echo "==============================================================================="
+			echo
 			warn "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
 			warn "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
 			return
 			;;
 		*)
+			warn_path
 			;;
 	esac
 }
 
+warn_path() {
+	echo
+	echo "==============================================================================="
+	echo
+	[ -n "$1" ] && warn "$1"
+	yellow "In order to run ghc and cabal, you need to adjust your PATH variable."
+	yellow "To do so, you may want run 'source $GHCUP_DIR/env' in your current terminal"
+	yellow "session as well as your shell configuration (e.g. ~/.bashrc)."
+
+}
+
 adjust_cabal_config() {
 	edo cabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$HOME"/AppData/Roaming/cabal/bin), $(cygpath -w "$GHCUP_MSYS2"/usr/bin), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init
 }
@@ -615,36 +642,8 @@ case $ask_stack_answer in
 esac
 
 
+adjust_bashrc $ask_bashrc_answer
 
-# short-circuit script based on platform
-case "${plat}" in
-        MSYS*|MINGW*)
-			# For windows we always adjust bashrc, since it's inside msys2
-			adjust_bashrc $adjust_bashrc_answer
-			;;
-		*)
-        	if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
-				case $ask_bashrc_answer in
-					1 | 2)
-						echo
-						echo "==============================================================================="
-						echo
-						yellow "In order to run ghc and cabal, start a new shell or"
-						yellow "run 'source $GHCUP_DIR/env' in your current shell session."
-						adjust_bashrc $adjust_bashrc_answer
-						;;
-					*)
-						echo
-						echo "==============================================================================="
-						echo
-						yellow "In order to run ghc and cabal, you need to adjust your PATH variable."
-						yellow "You may want to source '$GHCUP_DIR/env' in your shell"
-						yellow "configuration to do so (e.g. ~/.bashrc)."
-						;;
-				esac
-			fi
-			;;
-esac
 
 _done
 

bootstrap-haskell.ps1

@@ -276,7 +276,7 @@ if ($CabalDir) {
   while ($true) {
 
     $defaultCabalDir = ('{0}\cabal' -f $GhcupBasePrefix)
-    Print-Msg -color Magenta -msg ('Specify Cabal directory (this is where haskell packages end up). Press enter to accept the default [{0}]:' -f $defaultCabalDir)
+    Print-Msg -color Magenta -msg ('Specify Cabal directory (this is where haskell packages end up){1}Press enter to accept the default [{0}]:' -f $defaultCabalDir, "`n")
     $CabalDirPrompt = Read-Host
     $CabDirEnv = ($defaultCabalDir,$CabalDirPrompt)[[bool]$CabalDirPrompt]
 
@@ -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'
@@ -383,7 +383,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
     while ($true) {
       if ($GhcupMsys2) {
         $defaultMsys2Dir = $GhcupMsys2
-        Print-Msg -color Magenta -msg ('Input existing MSys2 toolchain directory. Press enter to accept the default [{0}]:' -f $defaultMsys2Dir)
+        Print-Msg -color Magenta -msg ('Input existing MSys2 toolchain directory.{1}Press enter to accept the default [{0}]:' -f $defaultMsys2Dir, "`n")
         $MsysDirPrompt = Read-Host
         $MsysDir = ($defaultMsys2Dir,$MsysDirPrompt)[[bool]$MsysDirPrompt]
       } else {
@@ -412,11 +412,74 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
 }
 
 Print-Msg -msg 'Creating shortcuts...'
+$uninstallShortCut = @'
+$decision = $Host.UI.PromptForChoice('Uninstall Haskell'
+, 'Do you want to uninstall all of the haskell toolchain, including GHC, Cabal, Stack and GHCup itself?'
+, [System.Management.Automation.Host.ChoiceDescription[]] @('&Uninstall'
+    '&Abort'), 0)
+
+if ($decision -eq 1) {
+  Exit 0
+}
+
+Write-Host 'Removing ghcup toolchain' -ForegroundColor Green
+ghcup nuke
+
+Write-Host 'Unsetting GHCUP_INSTALL_BASE_PREFIX' -ForegroundColor Green
+[Environment]::SetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', $null, [System.EnvironmentVariableTarget]::User)
+
+$ghcupMsys2 = [System.Environment]::GetEnvironmentVariable('GHCUP_MSYS2', 'user')
+$GhcupBasePrefixEnv = [System.Environment]::GetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', 'user')
+
+if ($ghcupMsys2) {
+  $msys2Dir = [IO.Path]::GetFullPath($ghcupMsys2)
+  $baseDir = [IO.Path]::GetFullPath('{0}\ghcup' -f $GhcupBasePrefixEnv)
+
+  if ($msys2Dir.StartsWith($baseDir)) {
+    Write-Host 'Unsetting GHCUP_MSYS2' -ForegroundColor Green
+    [Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)
+  } else {
+    Write-Host ('GHCUP_MSYS2 env variable is set to a non-standard location {0}. Environment variable not unset. Uninstall manually.' -f $msys2Dir) -ForegroundColor Magenta
+  }
+} else {
+  Write-Host 'Unsetting GHCUP_MSYS2' -ForegroundColor Green
+  [Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)
+}
+
+Write-Host 'Removing ghcup from PATH env var' -ForegroundColor Green
+$path = [System.Environment]::GetEnvironmentVariable(
+    'PATH',
+    'user'
+)
+$path = ($path.Split(';') | Where-Object { $_ -ne ('{0}\bin' -f $baseDir) }) -join ';'
+[System.Environment]::SetEnvironmentVariable(
+    'PATH',
+    $path,
+    'user'
+)
+
+Write-Host 'Removing desktop files' -ForegroundColor Green
+$DesktopDir = [Environment]::GetFolderPath("Desktop")
+Remove-Item -LiteralPath ('{0}\Install GHC dev dependencies.lnk' -f $DesktopDir) -Force
+Remove-Item -LiteralPath ('{0}\Mingw haskell shell.lnk' -f $DesktopDir) -Force
+Remove-Item -LiteralPath ('{0}\Mingw package management docs.url' -f $DesktopDir) -Force
+
+Write-Host ('CABAL_DIR env variable is still set to {0} and will be used by cabal regardless of ghcup. You may want to uninstall this manually.' -f [System.Environment]::GetEnvironmentVariable('CABAL_DIR', 'user')) -ForegroundColor Magenta
+Write-Host 'You may remove this script now.' -ForegroundColor Magenta
+
+if ($Host.Name -eq "ConsoleHost")
+{
+    Write-Host "Press any key to continue..."
+    $Host.UI.RawUI.ReadKey("NoEcho,IncludeKeyUp") > $null
+}
+'@
+
 $DesktopDir = [Environment]::GetFolderPath("Desktop")
 $GhcInstArgs = '-mingw64 -mintty -c "pacman --noconfirm -S --needed base-devel gettext autoconf make libtool automake python p7zip patch unzip"'
 Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe $GhcInstArgs -DestinationPath ('{0}\Install GHC dev dependencies.lnk' -f $DesktopDir)
 Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe '-mingw64' -DestinationPath ('{0}\Mingw haskell shell.lnk' -f $DesktopDir)
 Create-Shortcut -SourceExe 'https://www.msys2.org/docs/package-management' -ArgumentsToSourceExe '' -DestinationPath ('{0}\Mingw package management docs.url' -f $DesktopDir)
+$null = New-Item -Path $DesktopDir -Name "Uninstall Haskell.ps1" -ItemType "file" -Force -Value $uninstallShortCut
 
 Print-Msg -msg ('Adding {0}\bin to Users Path...' -f $GhcupDir)
 Add-EnvPath -Path ('{0}\bin' -f ([System.IO.Path]::GetFullPath("$GhcupDir"))) -Container 'User'

cabal.ghc8105.project

@@ -8,6 +8,11 @@ package ghcup
     tests: True
     flags: +tui
 
+source-repository-package
+    type: git
+    location: https://github.com/jtdaugherty/brick.git
+    tag: b3b96cfe66dfd398d338e3feb2b6855e66a35190
+
 source-repository-package
     type: git
     location: https://github.com/Bodigrim/tar

cabal.ghc8105.project.freeze

@@ -5,7 +5,7 @@ constraints: any.Cabal ==3.2.1.0,
              HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
              any.QuickCheck ==2.14.2,
              QuickCheck -old-random +templatehaskell,
-             any.StateVar ==1.2.1,
+             any.StateVar ==1.2.2,
              any.aeson ==1.5.6.0,
              aeson -bytestring-builder -cffi -developer -fast,
              any.aeson-pretty ==0.8.8,
@@ -34,7 +34,7 @@ constraints: any.Cabal ==3.2.1.0,
              any.binary ==0.8.8.0,
              any.bindings-DSL ==1.0.25,
              any.blaze-builder ==0.4.2.1,
-             any.brick ==0.61,
+             any.brick ==0.63,
              brick -demos,
              any.bytestring ==0.10.12.0,
              any.bz2 ==1.0.1.0,
@@ -66,7 +66,7 @@ constraints: any.Cabal ==3.2.1.0,
              any.config-ini ==0.2.4.0,
              config-ini -enable-doctests,
              any.containers ==0.6.4.1,
-             any.contravariant ==1.5.3,
+             any.contravariant ==1.5.4,
              contravariant +semigroups +statevar +tagged,
              any.cpphs ==1.20.9.1,
              cpphs -old-locale,
@@ -111,7 +111,7 @@ constraints: any.Cabal ==3.2.1.0,
              hsc2hs -in-ghc-tree,
              any.hspec ==2.7.10,
              any.hspec-core ==2.7.10,
-             any.hspec-discover ==2.7.10,
+             any.hspec-discover ==2.7.10 || ==2.8.2,
              any.hspec-expectations ==0.8.2,
              any.hspec-golden-aeson ==0.9.0.0,
              any.http-io-streams ==0.1.6.0,
@@ -137,7 +137,7 @@ constraints: any.Cabal ==3.2.1.0,
              any.microlens ==0.4.12.0,
              any.microlens-mtl ==0.2.0.1,
              any.microlens-th ==0.4.3.10,
-             any.monad-control ==1.0.2.3,
+             any.monad-control ==1.0.3,
              any.monad-logger ==0.3.36,
              monad-logger +template_haskell,
              any.monad-loops ==0.4.3,
@@ -176,7 +176,7 @@ constraints: any.Cabal ==3.2.1.0,
              any.recursion-schemes ==5.2.2.1,
              recursion-schemes +template-haskell,
              any.regex-base ==0.94.0.1,
-             any.regex-posix ==0.96.0.0,
+             any.regex-posix ==0.96.0.1,
              regex-posix -_regex-posix-clib,
              any.resourcet ==1.2.4.2,
              any.rts ==1.0.1,
@@ -228,7 +228,7 @@ constraints: any.Cabal ==3.2.1.0,
              any.transformers ==0.5.6.2,
              any.transformers-base ==0.4.5.2,
              transformers-base +orphaninstances,
-             any.transformers-compat ==0.6.6,
+             any.transformers-compat ==0.7,
              transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
              any.typed-process ==0.2.6.0,
              any.unix ==2.7.2.2,
@@ -261,4 +261,4 @@ constraints: any.Cabal ==3.2.1.0,
              any.zlib-bindings ==0.1.1.5,
              any.zstd ==0.1.2.0,
              zstd +standalone
-index-state: hackage.haskell.org 2021-07-12T18:00:24Z
+index-state: hackage.haskell.org 2021-07-27T07:59:57Z

cabal.ghc901.project

@@ -8,6 +8,11 @@ package ghcup
     tests: True
     flags: +tui
 
+source-repository-package
+    type: git
+    location: https://github.com/jtdaugherty/brick.git
+    tag: b3b96cfe66dfd398d338e3feb2b6855e66a35190
+
 source-repository-package
     type: git
     location: https://github.com/Bodigrim/tar

cabal.ghc901.project.freeze

@@ -5,7 +5,7 @@ constraints: any.Cabal ==3.4.0.0,
              HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
              any.QuickCheck ==2.14.2,
              QuickCheck -old-random +templatehaskell,
-             any.StateVar ==1.2.1,
+             any.StateVar ==1.2.2,
              any.aeson ==1.5.6.0,
              aeson -bytestring-builder -cffi -developer -fast,
              any.aeson-pretty ==0.8.8,
@@ -34,7 +34,7 @@ constraints: any.Cabal ==3.4.0.0,
              any.binary ==0.8.8.0,
              any.bindings-DSL ==1.0.25,
              any.blaze-builder ==0.4.2.1,
-             any.brick ==0.61,
+             any.brick ==0.63,
              brick -demos,
              any.bytestring ==0.10.12.1,
              any.bz2 ==1.0.1.0,
@@ -66,7 +66,7 @@ constraints: any.Cabal ==3.4.0.0,
              any.config-ini ==0.2.4.0,
              config-ini -enable-doctests,
              any.containers ==0.6.4.1,
-             any.contravariant ==1.5.3,
+             any.contravariant ==1.5.4,
              contravariant +semigroups +statevar +tagged,
              any.cpphs ==1.20.9.1,
              cpphs -old-locale,
@@ -112,7 +112,7 @@ constraints: any.Cabal ==3.4.0.0,
              hsc2hs -in-ghc-tree,
              any.hspec ==2.7.10,
              any.hspec-core ==2.7.10,
-             any.hspec-discover ==2.7.10,
+             any.hspec-discover ==2.7.10 || ==2.8.2,
              any.hspec-expectations ==0.8.2,
              any.hspec-golden-aeson ==0.9.0.0,
              any.http-io-streams ==0.1.6.0,
@@ -137,7 +137,7 @@ constraints: any.Cabal ==3.4.0.0,
              any.microlens ==0.4.12.0,
              any.microlens-mtl ==0.2.0.1,
              any.microlens-th ==0.4.3.10,
-             any.monad-control ==1.0.2.3,
+             any.monad-control ==1.0.3,
              any.monad-logger ==0.3.36,
              monad-logger +template_haskell,
              any.monad-loops ==0.4.3,
@@ -176,7 +176,7 @@ constraints: any.Cabal ==3.4.0.0,
              any.recursion-schemes ==5.2.2.1,
              recursion-schemes +template-haskell,
              any.regex-base ==0.94.0.1,
-             any.regex-posix ==0.96.0.0,
+             any.regex-posix ==0.96.0.1,
              regex-posix -_regex-posix-clib,
              any.resourcet ==1.2.4.2,
              any.rts ==1.0,
@@ -228,7 +228,7 @@ constraints: any.Cabal ==3.4.0.0,
              any.transformers ==0.5.6.2,
              any.transformers-base ==0.4.5.2,
              transformers-base +orphaninstances,
-             any.transformers-compat ==0.6.6,
+             any.transformers-compat ==0.7,
              transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
              any.typed-process ==0.2.6.0,
              any.unix ==2.7.2.2,
@@ -261,4 +261,4 @@ constraints: any.Cabal ==3.4.0.0,
              any.zlib-bindings ==0.1.1.5,
              any.zstd ==0.1.2.0,
              zstd +standalone
-index-state: hackage.haskell.org 2021-07-12T18:00:24Z
+index-state: hackage.haskell.org 2021-07-27T07:59:57Z

cabal.project

@@ -8,6 +8,11 @@ package ghcup
     tests: True
     flags: +tui
 
+source-repository-package
+    type: git
+    location: https://github.com/jtdaugherty/brick.git
+    tag: b3b96cfe66dfd398d338e3feb2b6855e66a35190
+
 source-repository-package
     type: git
     location: https://github.com/Bodigrim/tar

ghcup-0.0.2.yaml

@@ -1384,7 +1384,7 @@ ghcupDownloads:
               dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-freebsd-12.1-release.tar.xz
               dlHash: 9705e16d03497b46be4ad477e6c64d10890af853eafa8a9adf6dba89aa9e05f7
   GHCup:
-    0.1.14:
+    0.1.16.1:
       viTags:
       - Recommended
       - Latest
@@ -1394,22 +1394,22 @@ ghcupDownloads:
         A_64:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-64
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.14/x86_64-linux-ghcup-0.1.14
-              dlHash: e9b314d248f4d4604ce64cee1be7161c77c8940efd11986c9205779ec3b598dd
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-linux-ghcup-0.1.16.1
+              dlHash: c3505d929722e245b22ec7a05267f1ae8e04089e139bbb470783eb9a1b648f83
           Darwin:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.14/x86_64-apple-darwin-ghcup-0.1.14
-              dlHash: 69ede9db36c0ae631b679fceb87dd856d4753ee26f33610da37dd7a694809919
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-apple-darwin-ghcup-0.1.16.1
+              dlHash: 7edde6bb42323232d28495abbe630321d7eb8e3827e200438a9ae4c41e531e71
           FreeBSD:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.14/x86_64-portbld-freebsd-ghcup-0.1.14
-              dlHash: 68b09404cf49061da539463f42f8ad67c9cef5c5d3f68a3c7c4f6760e8442bb9
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-portbld-freebsd-ghcup-0.1.16.1
+              dlHash: 6b7fc3a52e859f186d30b04c823fd0c5997179222fe9aa510a33435f41599f5c
           Linux_Alpine:
             unknown_versioning: *ghcup-64
         A_32:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-32
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.14/i386-linux-ghcup-0.1.14
-              dlHash: ecb1157f010d2421764c52ab0cdbbf9a5c3da555827172c7b904d5f3f96c80fa
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/i386-linux-ghcup-0.1.16.1
+              dlHash: 93ca5d77247b6ecac01be75e9ef5454adbb503b7957b8e9c59a5abd2046aef3c
           Linux_Alpine:
             unknown_versioning: *ghcup-32

ghcup-0.0.3.yaml

@@ -1451,7 +1451,7 @@ ghcupDownloads:
               dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-freebsd-12.1-release.tar.xz
               dlHash: 9705e16d03497b46be4ad477e6c64d10890af853eafa8a9adf6dba89aa9e05f7
   GHCup:
-    0.1.14:
+    0.1.16.1:
       viTags:
       - Recommended
       - Latest
@@ -1461,23 +1461,23 @@ ghcupDownloads:
         A_64:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-64
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.14/x86_64-linux-ghcup-0.1.14
-              dlHash: e9b314d248f4d4604ce64cee1be7161c77c8940efd11986c9205779ec3b598dd
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-linux-ghcup-0.1.16.1
+              dlHash: c3505d929722e245b22ec7a05267f1ae8e04089e139bbb470783eb9a1b648f83
           Darwin:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.14/x86_64-apple-darwin-ghcup-0.1.14
-              dlHash: 69ede9db36c0ae631b679fceb87dd856d4753ee26f33610da37dd7a694809919
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-apple-darwin-ghcup-0.1.16.1
+              dlHash: 7edde6bb42323232d28495abbe630321d7eb8e3827e200438a9ae4c41e531e71
           FreeBSD:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.14/x86_64-portbld-freebsd-ghcup-0.1.14
-              dlHash: 68b09404cf49061da539463f42f8ad67c9cef5c5d3f68a3c7c4f6760e8442bb9
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-portbld-freebsd-ghcup-0.1.16.1
+              dlHash: 6b7fc3a52e859f186d30b04c823fd0c5997179222fe9aa510a33435f41599f5c
           Linux_Alpine:
             unknown_versioning: *ghcup-64
         A_32:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-32
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.14/i386-linux-ghcup-0.1.14
-              dlHash: ecb1157f010d2421764c52ab0cdbbf9a5c3da555827172c7b904d5f3f96c80fa
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/i386-linux-ghcup-0.1.16.1
+              dlHash: 93ca5d77247b6ecac01be75e9ef5454adbb503b7957b8e9c59a5abd2046aef3c
           Linux_Alpine:
             unknown_versioning: *ghcup-32
   HLS:

ghcup-0.0.4.yaml

@@ -1868,7 +1868,7 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.4.0.0/cabal-install-3.4.0.0-armv7-linux-bootstrapped.tar.xz
               dlHash: 16c0d1eaba24bed14f3e152970179a45d9f9bb5cc839b2c210ad06eb7d4826ed
   GHCup:
-    0.1.15.2:
+    0.1.16.1:
       viTags:
       - Recommended
       - Latest
@@ -1878,39 +1878,39 @@ ghcupDownloads:
         A_64:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-64
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-linux-ghcup-0.1.15.2
-              dlHash: 1eb1bb318a327754f42eaa2245bc81fe53be7c791160d28a186893ded3004ed7
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-linux-ghcup-0.1.16.1
+              dlHash: c3505d929722e245b22ec7a05267f1ae8e04089e139bbb470783eb9a1b648f83
           Darwin:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-apple-darwin-ghcup-0.1.15.2
-              dlHash: c2a6436a49f19f108493954d4a3efcb27503e343dd6288c2641784d32320b1ea
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-apple-darwin-ghcup-0.1.16.1
+              dlHash: 7edde6bb42323232d28495abbe630321d7eb8e3827e200438a9ae4c41e531e71
           FreeBSD:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-portbld-freebsd-ghcup-0.1.15.2
-              dlHash: 7e0c17dd78ebd9fd03e6ecea278c192bac31ca333721bde5b0ef99438b847a20
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-portbld-freebsd-ghcup-0.1.16.1
+              dlHash: 6b7fc3a52e859f186d30b04c823fd0c5997179222fe9aa510a33435f41599f5c
           Linux_Alpine:
             unknown_versioning: *ghcup-64
         A_32:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-32
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/i386-linux-ghcup-0.1.15.2
-              dlHash: 3b1fe710cded0398e920ec9716089ba65226abf181741897f387e7c539a619c2
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/i386-linux-ghcup-0.1.16.1
+              dlHash: 93ca5d77247b6ecac01be75e9ef5454adbb503b7957b8e9c59a5abd2046aef3c
           Linux_Alpine:
             unknown_versioning: *ghcup-32
         A_ARM64:
           Linux_UnknownLinux:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/aarch64-linux-ghcup-0.1.15.2
-              dlHash: d91b7a5416f292f2cf813824eb419f76ad9976d258cee3581123cb6eb01db9a7
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/aarch64-linux-ghcup-0.1.16.1
+              dlHash: 31fecbb704e9e2474804f42817ab17bfac28e32e5aeba93ae3f4c77fbc105706
           Darwin:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/aarch64-apple-darwin-ghcup-0.1.15.2
-              dlHash: 20625ba5e7488f2a6155331750ecead3815ea16b2695c20521633c1412f012cc
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/aarch64-apple-darwin-ghcup-0.1.16.1
+              dlHash: 52eb69a5693abf6c18f95a3b9bf4dac59696299d690c6397bd22a9091e76d40e
         A_ARM:
           Linux_UnknownLinux:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/armv7-linux-ghcup-0.1.15.2
-              dlHash: 03a4af5ed895ada1dd21f4cc3f64dc9078a5bf4268313021d004c04bea7f9c2e
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/armv7-linux-ghcup-0.1.16.1
+              dlHash: 795dd2032f0f4e4ea9688cd49393aba4c40c9eae84c8dea3477f5f440f750767
   HLS:
     1.1.0:
       viTags:

ghcup-0.0.5.yaml

@@ -96,6 +96,7 @@ toolRequirements:
       Linux_Alpine:
         unknown_versioning:
           distroPKGs:
+          - binutils-gold
           - curl
           - gcc
           - g++
@@ -2024,7 +2025,7 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.4.0.0/cabal-install-3.4.0.0-armv7-linux-bootstrapped.tar.xz
               dlHash: 16c0d1eaba24bed14f3e152970179a45d9f9bb5cc839b2c210ad06eb7d4826ed
   GHCup:
-    0.1.15.2:
+    0.1.16.1:
       viTags:
       - Recommended
       - Latest
@@ -2034,52 +2035,55 @@ ghcupDownloads:
         A_64:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-64
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-linux-ghcup-0.1.15.2
-              dlHash: 1eb1bb318a327754f42eaa2245bc81fe53be7c791160d28a186893ded3004ed7
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-linux-ghcup-0.1.16.1
+              dlHash: c3505d929722e245b22ec7a05267f1ae8e04089e139bbb470783eb9a1b648f83
           Darwin:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-apple-darwin-ghcup-0.1.15.2
-              dlHash: c2a6436a49f19f108493954d4a3efcb27503e343dd6288c2641784d32320b1ea
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-apple-darwin-ghcup-0.1.16.1
+              dlHash: 7edde6bb42323232d28495abbe630321d7eb8e3827e200438a9ae4c41e531e71
           FreeBSD:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-portbld-freebsd-ghcup-0.1.15.2
-              dlHash: 7e0c17dd78ebd9fd03e6ecea278c192bac31ca333721bde5b0ef99438b847a20
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-portbld-freebsd-ghcup-0.1.16.1
+              dlHash: 6b7fc3a52e859f186d30b04c823fd0c5997179222fe9aa510a33435f41599f5c
           Windows:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/x86_64-mingw64-ghcup-0.1.15.2.exe
-              dlHash: 4d832052754379531ac472aeef35666e433acfee79d4079826b8ede8ca5de520
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/x86_64-mingw64-ghcup-0.1.16.1.exe
+              dlHash: 62439b45c7bcbc1395afe948393cb8e10bbe4f3af9b1fc58ac78660c2ad616d5
           Linux_Alpine:
             unknown_versioning: *ghcup-64
         A_32:
           Linux_UnknownLinux:
             unknown_versioning: &ghcup-32
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/i386-linux-ghcup-0.1.15.2
-              dlHash: 3b1fe710cded0398e920ec9716089ba65226abf181741897f387e7c539a619c2
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/i386-linux-ghcup-0.1.16.1
+              dlHash: 93ca5d77247b6ecac01be75e9ef5454adbb503b7957b8e9c59a5abd2046aef3c
           Linux_Alpine:
             unknown_versioning: *ghcup-32
         A_ARM64:
           Linux_UnknownLinux:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/aarch64-linux-ghcup-0.1.15.2-r1
-              dlHash: d853372440f3d43babbb868fad399811241760f2233829c92403fcbea8c547ec
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/aarch64-linux-ghcup-0.1.16.1
+              dlHash: 31fecbb704e9e2474804f42817ab17bfac28e32e5aeba93ae3f4c77fbc105706
           Darwin:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/aarch64-apple-darwin-ghcup-0.1.15.2
-              dlHash: 20625ba5e7488f2a6155331750ecead3815ea16b2695c20521633c1412f012cc
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/aarch64-apple-darwin-ghcup-0.1.16.1
+              dlHash: 52eb69a5693abf6c18f95a3b9bf4dac59696299d690c6397bd22a9091e76d40e
         A_ARM:
           Linux_UnknownLinux:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/armv7-linux-ghcup-0.1.15.2-r1
-              dlHash: f8add9b39e1f7d0f03904dc69a8683259972a4472432c1ade27d918c39a4a874
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.16.1/armv7-linux-ghcup-0.1.16.1
+              dlHash: 795dd2032f0f4e4ea9688cd49393aba4c40c9eae84c8dea3477f5f440f750767
   HLS:
     1.1.0:
       viTags: []
       viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#110
-      viPostInstall: "This is just the server part of your LSP configuration. Consult the README on how to configure HLS, your project and your LSP client in your editor: https://github.com/haskell/haskell-language-server/blob/master/README.md"
+      viPostInstall: &hls-post-install |
+        This is just the server part of your LSP configuration. Consult the README on how to
+        configure HLS, your project and your LSP client in your editor:
+          https://github.com/haskell/haskell-language-server/blob/master/README.md
       viArch:
         A_64:
           Linux_UnknownLinux:
-            unknown_versioning: &hls-64
+            unknown_versioning: &hls-110-64
               dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.1.0/haskell-language-server-Linux-1.1.0.tar.gz
               dlHash: 0f0dadb0e9a08273658f565fd71c636801959b954be2737f38f2a1aac522208f
           Darwin:
@@ -2091,17 +2095,15 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/hls/1.1.0/haskell-language-server-Windows-1.1.0.tar.gz
               dlHash: a1d3f451e64a041aa527a25da29e4716a2de6ae347cef4ef9312fc7611e168cc
           Linux_Alpine:
-            unknown_versioning: *hls-64
+            unknown_versioning: *hls-110-64
     1.2.0:
-      viTags:
-        - Recommended
-        - Latest
+      viTags: []
       viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#120
-      viPostInstall: "This is just the server part of your LSP configuration. Consult the README on how to configure HLS, your project and your LSP client in your editor: https://github.com/haskell/haskell-language-server/blob/master/README.md"
+      viPostInstall: *hls-post-install
       viArch:
         A_64:
           Linux_UnknownLinux:
-            unknown_versioning: &hls-64
+            unknown_versioning: &hls-120-64
               dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.2.0/haskell-language-server-Linux-1.2.0.tar.gz
               dlHash: d29ee22f7bd706da2e2a1bd7640e25bb9736adeafb34eef47d29ea143b0fa927
           Darwin:
@@ -2113,7 +2115,29 @@ ghcupDownloads:
               dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.2.0/haskell-language-server-Windows-1.2.0.tar.gz
               dlHash: 961c6ff12c9a9c7a4609f239c5ac70d7d16753cdb8c10348a6a51feeaa0b6aea
           Linux_Alpine:
-            unknown_versioning: *hls-64
+            unknown_versioning: *hls-120-64
+    1.3.0:
+      viTags:
+        - Recommended
+        - Latest
+      viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#130
+      viPostInstall: *hls-post-install
+      viArch:
+        A_64:
+          Linux_UnknownLinux:
+            unknown_versioning: &hls-130-64
+              dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.3.0/haskell-language-server-Linux-1.3.0.tar.gz
+              dlHash: d29ee22f7bd706da2e2a1bd7640e25bb9736adeafb34eef47d29ea143b0fa927
+          Darwin:
+            unknown_versioning:
+              dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.3.0/haskell-language-server-macOS-1.3.0.tar.gz
+              dlHash: a310d8a3e9c5c4218210f750682c74a0f82ad0f59995adde0dbe775115b1e357
+          Windows:
+            unknown_versioning:
+              dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.3.0/haskell-language-server-Windows-1.3.0.tar.gz
+              dlHash: 961c6ff12c9a9c7a4609f239c5ac70d7d16753cdb8c10348a6a51feeaa0b6aea
+          Linux_Alpine:
+            unknown_versioning: *hls-130-64
   Stack:
     2.5.1:
       viTags:

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.0
 name:            ghcup
-version:         0.1.15.2
+version:         0.1.16.1
 license:         LGPL-3.0-only
 license-file:    LICENSE
 copyright:       Julian Ospald 2020
@@ -20,6 +20,7 @@ extra-doc-files:
   config.yaml
   ghcup-0.0.4.yaml
   ghcup-0.0.5.yaml
+  ghcup-0.0.6.yaml
   HACKING.md
   README.md
   RELEASING.md
@@ -202,6 +203,7 @@ executable ghcup
     -fwarn-incomplete-record-updates -threaded
 
   build-depends:
+    , async                 ^>=2.2.3
     , base                  >=4.13     && <5
     , bytestring            ^>=0.10
     , containers            ^>=0.6
@@ -232,7 +234,7 @@ executable ghcup
     cpp-options:   -DBRICK
     other-modules: BrickMain
     build-depends:
-      , brick         >=0.5    && <0.62
+      , brick         >=0.5    && <0.64
       , transformers  ^>=0.5
       , vector        ^>=0.12
       , vty           >=5.28.2 && <5.34

lib/GHCup/Download.hs

@@ -55,20 +55,19 @@ import           Data.Aeson
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
 #if defined(INTERNAL_DOWNLOADER)
-import           Data.CaseInsensitive           ( CI )
+import           Data.CaseInsensitive           ( mk )
 #endif
 import           Data.List.Extra
 import           Data.Maybe
 import           Data.String.Interpolate
 import           Data.Time.Clock
 import           Data.Time.Clock.POSIX
-#if defined(INTERNAL_DOWNLOADER)
-import           Data.Time.Format
-#endif
 import           Data.Versions
-import           Data.Word8
-import           GHC.IO.Exception
+import           Data.Word8              hiding ( isSpace )
 import           Haskus.Utils.Variant.Excepts
+#if defined(INTERNAL_DOWNLOADER)
+import           Network.Http.Client     hiding ( URL )
+#endif
 import           Optics
 import           Prelude                 hiding ( abs
                                                 , readFile
@@ -76,8 +75,11 @@ import           Prelude                 hiding ( abs
                                                 )
 import           System.Directory
 import           System.Environment
+import           System.Exit
 import           System.FilePath
 import           System.IO.Error
+import           System.IO.Temp
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           URI.ByteString
 
 import qualified Crypto.Hash.SHA256            as SHA256
@@ -85,10 +87,8 @@ import qualified Data.ByteString               as B
 import qualified Data.ByteString.Base16        as B16
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Map.Strict               as M
-#if defined(INTERNAL_DOWNLOADER)
-import qualified Data.CaseInsensitive          as CI
-#endif
 import qualified Data.Text                     as T
+import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Yaml                     as Y
 
@@ -115,6 +115,7 @@ getDownloadsF :: ( FromJSONKey Tool
                  , MonadLogger m
                  , MonadThrow m
                  , MonadFail m
+                 , MonadMask m
                  )
               => Excepts
                    '[JSONError , DownloadFailed , FileDoesNotExistError]
@@ -148,19 +149,14 @@ getDownloadsF = do
     in GHCupInfo tr newDownloads newGlobalTools
 
 
-readFromCache :: ( MonadReader env m
-                 , HasDirs env
-                 , MonadIO m
-                 , MonadCatch m)
-              => URI
-              -> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString
-readFromCache uri = do
-  Dirs{..} <- lift getDirs
-  let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)
-  handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file)
-    . liftIO
-    . L.readFile
-    $ yaml_file
+yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
+yamlFromCache uri = do
+  Dirs{..} <- getDirs
+  pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
+
+
+etagsFile :: FilePath -> FilePath
+etagsFile = (<.> "etags")
 
 
 getBase :: ( MonadReader env m
@@ -170,35 +166,54 @@ getBase :: ( MonadReader env m
            , MonadIO m
            , MonadCatch m
            , MonadLogger m
+           , MonadMask m
            )
         => URI
-        -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
+        -> Excepts '[JSONError] m GHCupInfo
 getBase uri = do
   Settings { noNetwork } <- lift getSettings
-  bs <- if noNetwork
-        then readFromCache uri
-        else handleIO (\_ -> warnCache >> readFromCache uri)
-               . catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri)
-               . reThrowAll @_ @_ @'[JSONError, 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
-    . lE' @_ @_ @'[JSONError] JSONDecodeError
-    . first show
-    . Y.decodeEither'
-    . L.toStrict
-    $ bs
+    . onE_ (onError actualYaml)
+    . lEM' @_ @_ @'[JSONError] JSONDecodeError
+    . fmap (first (\e -> [i|#{displayException e}
+Consider removing "#{actualYaml}" manually.|]))
+    . liftIO
+    . Y.decodeFileEither
+    $ actualYaml
  where
-  warnCache = lift $ $(logWarn)
-      [i|Could not get download info, trying cached version (this may not be recent!)|]
+  -- On error, remove the etags file and set access time to 0. This should ensure the next invocation
+  -- may re-download and succeed.
+  onError :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
+  onError fp = do
+    let efp = etagsFile fp
+    handleIO (\e -> $(logWarn) [i|Couldn't remove file #{efp}, error was: #{displayException e}|])
+      (hideError doesNotExistErrorType $ rmFile efp)
+    liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
+  warnCache s = do
+    lift $ $(logWarn) [i|Could not get download info, trying cached version (this may not be recent!)|]
+    lift $ $(logDebug) [i|Error was: #{s}|]
 
   -- First check if the json file is in the ~/.ghcup/cache dir
   -- and check it's access time. If it has been accessed within the
   -- last 5 minutes, just reuse it.
   --
-  -- If not, then send a HEAD request and check for modification time.
-  -- Only download the file if the modification time is newer
-  -- than the local file.
-  --
   -- Always save the local file with the mod time of the remote file.
   smartDl :: forall m1 env1
            . ( MonadReader env1 m1
@@ -208,95 +223,40 @@ getBase uri = do
              , MonadIO m1
              , MonadFail m1
              , MonadLogger m1
+             , MonadMask m1
              )
           => URI
           -> Excepts
-               '[ FileDoesNotExistError
-                , HTTPStatusError
-                , URIParseError
-                , UnsupportedScheme
-                , NoLocationHeader
-                , TooManyRedirs
-                , ProcessError
-                , NoNetwork
+               '[ DownloadFailed
+                , DigestError
                 ]
                m1
-               L.ByteString
+               FilePath
   smartDl uri' = do
-    Dirs{..} <- lift getDirs
-    let path = view pathL' uri'
-    let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
+    json_file <- lift $ yamlFromCache uri'
+    let scheme = view (uriSchemeL' % schemeBSL') uri'
     e <- liftIO $ doesFileExist json_file
-    if e
-      then do
-        accessTime <- liftIO $ getAccessTime json_file
-        currentTime <- liftIO getCurrentTime
+    currentTime <- liftIO getCurrentTime
+    Dirs { cacheDir } <- lift getDirs
 
-        -- access time won't work on most linuxes, but we can try regardless
-        if (utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300
-          then do -- no access in last 5 minutes, re-check upstream mod time
-            getModTime >>= \case
-              Just modTime -> do
-                fileMod <- liftIO $ getModificationTime json_file
-                if modTime > fileMod
-                  then dlWithMod modTime json_file
-                  else liftIO $ L.readFile json_file
-              Nothing -> do
-                lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
-                dlWithoutMod json_file
-          else -- access in less than 5 minutes, re-use file
-               liftIO $ L.readFile json_file
-      else do
-        getModTime >>= \case
-          Just modTime -> dlWithMod modTime json_file
-          Nothing -> do
-            -- although we don't know last-modified, we still save
-            -- it to a file, so we might use it in offline mode
-            lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
-            dlWithoutMod 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
-      bs <- liftE $ downloadBS uri'
-      liftIO $ writeFileWithModTime modTime json_file bs
-      pure bs
-    dlWithoutMod json_file = do
-      bs <- liftE $ downloadBS uri'
-      liftIO $ hideError doesNotExistErrorType $ rmFile json_file
-      liftIO $ L.writeFile json_file bs
-      liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
-      pure bs
-
-
-    getModTime = do
-#if !defined(INTERNAL_DOWNLOADER)
-      pure Nothing
-#else
-      headers <-
-        handleIO (\_ -> pure mempty)
-        $ liftE
-        $ ( catchAllE
-              (\_ ->
-                pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
-              )
-          $ getHead uri'
-          )
-      pure $ parseModifiedHeader headers
-
-  parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
-  parseModifiedHeader headers =
-    (M.lookup (CI.mk "Last-Modified") headers) >>= \h -> parseTimeM
-      True
-      defaultTimeLocale
-      "%a, %d %b %Y %H:%M:%S %Z"
-      (T.unpack . decUTF8Safe $ h)
-
-#endif
-
-  writeFileWithModTime :: UTCTime -> FilePath -> L.ByteString -> IO ()
-  writeFileWithModTime utctime path content = do
-    L.writeFile path content
-    setModificationTime path utctime
+      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
@@ -356,39 +316,37 @@ download :: ( MonadReader env m
             , MonadLogger m
             , MonadIO m
             )
-         => DownloadInfo
-         -> FilePath          -- ^ destination dir
+         => URI
+         -> Maybe T.Text      -- ^ expected hash
+         -> FilePath          -- ^ destination dir (ignored for file:// scheme)
          -> Maybe FilePath    -- ^ optional filename
+         -> Bool              -- ^ whether to read an write etags
          -> Excepts '[DigestError , DownloadFailed] m FilePath
-download dli dest mfn
+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 (dlUri % uriSchemeL' % schemeBSL') dli
-  cp     = do
-    -- destination dir must exist
-    liftIO $ createDirRecursive' dest
-    let destFile = getDestFile
-    let fromFile = T.unpack . decUTF8Safe $ path
-    liftIO $ copyFile fromFile destFile
-    pure destFile
+  scheme = view (uriSchemeL' % schemeBSL') uri
   dl = do
-    let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
-    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
-    let destFile = getDestFile
 
     -- download
     flip onException
-         (liftIO $ hideError doesNotExistErrorType $ rmFile destFile)
+         (lift $ hideError doesNotExistErrorType $ recycleFile destFile)
      $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
           (\e ->
-            liftIO (hideError doesNotExistErrorType $ rmFile destFile)
+            lift (hideError doesNotExistErrorType $ recycleFile destFile)
               >> (throwE . DownloadFailed $ e)
           ) $ do
               Settings{ downloader, noNetwork } <- lift getSettings
@@ -396,28 +354,140 @@ download dli dest mfn
               case downloader of
                 Curl -> do
                   o' <- liftIO getCurlOpts
-                  liftE $ lEM @_ @'[ProcessError] $ exec "curl" 
-                    (o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
+                  if etags
+                    then do
+                      dh <- liftIO $ emptySystemTempFile "curl-header"
+                      flip finally (try @_ @SomeException $ rmFile dh) $
+                        flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
+                          metag <- readETag destFile
+                          liftE $ lEM @_ @'[ProcessError] $ exec "curl"
+                              (o' ++ (if etags then ["--dump-header", dh] else [])
+                                  ++ maybe [] (\t -> ["-H", [i|If-None-Match: #{t}|]]) metag
+                                  ++ ["-fL", "-o", destFile <.> "tmp", T.unpack uri']) Nothing Nothing
+                          headers <- liftIO $ T.readFile dh
+
+                          -- this nonsense is necessary, because some older versions of curl would overwrite
+                          -- the destination file when 304 is returned
+                          case fmap T.words . listToMaybe . fmap T.strip . T.lines $ headers of
+                            Just (http':sc:_)
+                              | sc == "304"
+                              , T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug [i|Status code was 304, not overwriting|]
+                              | T.pack "HTTP" `T.isPrefixOf` http' -> do
+                                  $logDebug [i|Status code was #{sc}, overwriting|]
+                                  liftIO $ copyFile (destFile <.> "tmp") destFile
+                            _ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
+                              :: V '[MalformedHeaders]))
+
+                          writeEtags destFile (parseEtags headers)
+                    else
+                      liftE $ lEM @_ @'[ProcessError] $ exec "curl" 
+                        (o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
                 Wget -> do
-                  o' <- liftIO getWgetOpts
-                  liftE $ lEM @_ @'[ProcessError] $ exec "wget" 
-                    (o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
+                  destFileTemp <- liftIO $ emptySystemTempFile "wget-tmp"
+                  flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
+                    o' <- liftIO getWgetOpts
+                    if etags
+                      then do
+                        metag <- readETag destFile
+                        let opts = o' ++ maybe [] (\t -> ["--header", [i|If-None-Match: #{t}|]]) metag
+                                      ++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
+                        CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
+                        case _exitCode of
+                          ExitSuccess -> do
+                            liftIO $ copyFile destFileTemp destFile
+                            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 destFile (parseEtags (decUTF8Safe' _stdErr))
+                            | otherwise -> throwE (NonZeroExit i' "wget" opts)
+                      else do
+                        let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
+                        liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
+                        liftIO $ copyFile destFileTemp destFile
 #if defined(INTERNAL_DOWNLOADER)
                 Internal -> do
-                  (https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
-                  liftE $ downloadToFile https host fullPath port destFile
+                  (https, host, fullPath, port) <- liftE $ uriToQuadruple uri
+                  if etags
+                    then do
+                      metag <- readETag destFile
+                      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 destFile (pure $ Just etag))
+                        $ do
+                          r <- downloadToFile https host fullPath port destFile addHeaders
+                          writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
+                    else void $ liftE $ catchE @HTTPNotModified
+                                        @'[DownloadFailed]
+                                   (\e@(HTTPNotModified _) ->
+                                     throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
+                               $ downloadToFile https host fullPath port destFile mempty
 #endif
 
-    liftE $ checkDigest dli destFile
+    forM_ eDigest (liftE . flip checkDigest destFile)
     pure destFile
 
-  -- Manage to find a file we can write the body into.
-  getDestFile :: FilePath
-  getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
-                  (dest </>)
-                  mfn
 
-  path = view (dlUri % pathL') dli
+  -- Manage to find a file we can write the body into.
+  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
+    let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines $ stderr
+    case T.words <$> mEtag of
+      (Just []) -> do
+        $logDebug "Couldn't parse etags, no input: "
+        pure Nothing
+      (Just [_, etag']) -> do
+        $logDebug [i|Parsed etag: #{etag'}|]
+        pure (Just etag')
+      (Just xs) -> do
+        $logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
+        pure Nothing
+      Nothing -> do
+        $logDebug "No etags header found"
+        pure Nothing
+
+  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)}|]
+        liftIO $ T.writeFile (etagsFile destFile) t
+      Nothing ->
+        $logDebug [i|No etags files written|]
+
+  readETag :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
+  readETag fp = do
+    e <- liftIO $ doesFileExist fp
+    if e
+    then do
+      rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
+      case rE of
+        (Right et) -> do
+          $logDebug [i|Read etag: #{et}|]
+          pure (Just et)
+        (Left _) -> do
+          $logDebug [i|Etag file doesn't exist (yet)|]
+          pure Nothing
+    else do
+      $logDebug [i|Skipping and deleting etags file because destination file #{fp} doesn't exist|]
+      liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
+      pure Nothing
 
 
 -- | Download into tmpdir or use cached version, if it exists. If filename
@@ -441,7 +511,7 @@ downloadCached dli mfn = do
     True -> downloadCached' dli mfn Nothing
     False -> do
       tmp <- lift withGHCupTmpDir
-      liftE $ download dli tmp mfn
+      liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp mfn False
 
 
 downloadCached' :: ( MonadReader env m
@@ -465,9 +535,9 @@ downloadCached' dli mfn mDestDir = do
   fileExists <- liftIO $ doesFileExist cachfile
   if
     | fileExists -> do
-      liftE $ checkDigest dli cachfile
+      liftE $ checkDigest (view dlHash dli) cachfile
       pure cachfile
-    | otherwise -> liftE $ download dli destDir mfn
+    | otherwise -> liftE $ download (_dlUri dli) (Just (_dlHash dli)) destDir mfn False
 
 
 
@@ -478,73 +548,6 @@ downloadCached' dli mfn mDestDir = do
 
 
 
-
--- | This is used for downloading the JSON.
-downloadBS :: ( MonadReader env m
-              , HasSettings env
-              , MonadCatch m
-              , MonadIO m
-              , MonadLogger m
-              )
-           => URI
-           -> Excepts
-                '[ FileDoesNotExistError
-                 , HTTPStatusError
-                 , URIParseError
-                 , UnsupportedScheme
-                 , NoLocationHeader
-                 , TooManyRedirs
-                 , ProcessError
-                 , NoNetwork
-                 ]
-                m
-                L.ByteString
-downloadBS uri'
-  | scheme == "https"
-  = dl True
-  | scheme == "http"
-  = dl False
-  | scheme == "file"
-  = liftIOException doesNotExistErrorType (FileDoesNotExistError $ T.unpack $ decUTF8Safe path)
-    (liftIO $ L.readFile (T.unpack $ decUTF8Safe path))
-  | otherwise
-  = throwE UnsupportedScheme
-
- where
-  scheme = view (uriSchemeL' % schemeBSL') uri'
-  path   = view pathL' uri'
-#if defined(INTERNAL_DOWNLOADER)
-  dl https = do
-#else
-  dl _ = do
-#endif
-    lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
-    Settings{ downloader, noNetwork } <- lift getSettings
-    when noNetwork $ throwE NoNetwork
-    case downloader of
-      Curl -> do
-        o' <- liftIO getCurlOpts
-        let exe = "curl"
-            args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
-        lift (executeOut exe args Nothing) >>= \case
-          CapturedProcess ExitSuccess stdout _ -> do
-            pure stdout
-          CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
-      Wget -> do
-        o' <- liftIO getWgetOpts
-        let exe = "wget"
-            args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
-        lift (executeOut exe args Nothing) >>= \case
-          CapturedProcess ExitSuccess stdout _ -> do
-            pure stdout
-          CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
-#if defined(INTERNAL_DOWNLOADER)
-      Internal -> do
-        (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
-        liftE $ downloadBS' https host' fullPath' port'
-#endif
-
-
 checkDigest :: ( MonadReader env m
                , HasDirs env
                , HasSettings env
@@ -552,10 +555,10 @@ checkDigest :: ( MonadReader env m
                , MonadThrow m
                , MonadLogger m
                )
-            => DownloadInfo
+            => T.Text     -- ^ the hash
             -> FilePath
             -> Excepts '[DigestError] m ()
-checkDigest dli file = do
+checkDigest eDigest file = do
   Settings{ noVerify } <- lift getSettings
   let verify = not noVerify
   when verify $ do
@@ -563,7 +566,6 @@ checkDigest dli file = do
     lift $ $(logInfo) [i|verifying digest of: #{p'}|]
     c <- liftIO $ L.readFile file
     cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
-    let eDigest = view dlHash dli
     when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
 
 

lib/GHCup/Download/IOStreams.hs

@@ -9,9 +9,7 @@ module GHCup.Download.IOStreams where
 
 import           GHCup.Download.Utils
 import           GHCup.Errors
-import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.File
 import           GHCup.Utils.Prelude
 
 import           Control.Applicative
@@ -20,7 +18,7 @@ import           Control.Monad
 import           Control.Monad.Reader
 import           Data.ByteString                ( ByteString )
 import           Data.ByteString.Builder
-import           Data.CaseInsensitive           ( CI )
+import           Data.CaseInsensitive           ( CI, original, mk )
 import           Data.IORef
 import           Data.Maybe
 import           Data.Text.Read
@@ -32,7 +30,6 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           System.ProgressBar
-import           System.IO
 import           URI.ByteString
 
 import qualified Data.ByteString               as BS
@@ -67,7 +64,7 @@ downloadBS' :: MonadIO m
 downloadBS' https host path port = do
   bref <- liftIO $ newIORef (mempty :: Builder)
   let stepper bs = modifyIORef bref (<> byteString bs)
-  downloadInternal False https host path port stepper
+  void $ downloadInternal False https host path port stepper (pure ()) mempty
   liftIO (readIORef bref <&> toLazyByteString)
 
 
@@ -77,12 +74,17 @@ downloadToFile :: (MonadMask m, MonadIO m)
                -> ByteString       -- ^ path (e.g. "/my/file") including query
                -> Maybe Int        -- ^ optional port (e.g. 3000)
                -> FilePath         -- ^ destination file to create and write to
-               -> Excepts '[DownloadFailed] m ()
-downloadToFile https host fullPath port destFile = do
-  fd <- liftIO $ openFile destFile WriteMode
-  let stepper = BS.hPut fd
-  flip finally (liftIO $ hClose fd)
-    $ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
+               -> M.Map (CI ByteString) ByteString -- ^ additional headers
+               -> Excepts '[DownloadFailed, HTTPNotModified] m Response
+downloadToFile https host fullPath port destFile addHeaders = do
+  let stepper = BS.appendFile destFile
+      setup = BS.writeFile destFile mempty
+  catchAllE (\case
+              (V (HTTPStatusError i headers))
+                | 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 :: MonadIO m
@@ -92,6 +94,8 @@ downloadInternal :: MonadIO m
                  -> ByteString  -- ^ path with query
                  -> Maybe Int   -- ^ optional port
                  -> (ByteString -> IO a)   -- ^ the consuming step function
+                 -> IO a                   -- ^ setup action
+                 -> M.Map (CI ByteString) ByteString -- ^ additional headers
                  -> Excepts
                       '[ HTTPStatusError
                        , URIParseError
@@ -100,19 +104,21 @@ downloadInternal :: MonadIO m
                        , TooManyRedirs
                        ]
                       m
-                      ()
+                      Response
 downloadInternal = go (5 :: Int)
 
  where
-  go redirs progressBar https host path port consumer = do
+  go redirs progressBar https host path port consumer setup addHeaders = do
     r <- liftIO $ withConnection' https host port action
     veitherToExcepts r >>= \case
-      Just r' ->
+      Right r' ->
         if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
-      Nothing -> pure ()
+      Left res -> pure res
    where
     action c = do
-      let q = buildRequest1 $ http GET path
+      let q = buildRequest1 $ do
+                http GET path
+                flip M.traverseWithKey addHeaders $ \key val -> setHeader (original key) val
 
       sendRequest c q emptyBody
 
@@ -121,28 +127,30 @@ downloadInternal = go (5 :: Int)
         (\r i' -> runE $ do
           let scode = getStatusCode r
           if
-            | scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
+            | scode >= 200 && scode < 300 -> liftIO $ downloadStream r i' >> pure (Left r)
+            | scode == 304 -> throwE $ HTTPStatusError scode (getHeaderMap r)
             | scode >= 300 && scode < 400 -> case getHeader r "Location" of
-              Just r' -> pure $ Just r'
+              Just r' -> pure $ Right r'
               Nothing -> throwE NoLocationHeader
-            | otherwise -> throwE $ HTTPStatusError scode
+            | otherwise -> throwE $ HTTPStatusError scode (getHeaderMap r)
         )
 
     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
+        go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders
       Left e -> throwE e
 
     downloadStream r i' = do
+      void setup
       let size = case getHeader r "Content-Length" of
             Just x' -> case decimal $ decUTF8Safe x' of
               Left  _       -> 0
               Right (r', _) -> r'
             Nothing -> 0
 
-      mpb <- if progressBar
-        then Just <$> liftIO (newProgressBar defStyle 10 (Progress 0 size ()))
+      (mpb :: Maybe (ProgressBar ())) <- if progressBar
+        then Just <$> newProgressBar defStyle 10 (Progress 0 size ())
         else pure Nothing
 
       outStream <- liftIO $ Streams.makeOutputStream
@@ -155,79 +163,6 @@ downloadInternal = go (5 :: Int)
       liftIO $ Streams.connect i' outStream
 
 
-getHead :: (MonadCatch m, MonadIO m)
-        => URI
-        -> Excepts
-             '[ HTTPStatusError
-              , URIParseError
-              , UnsupportedScheme
-              , NoLocationHeader
-              , TooManyRedirs
-              , ProcessError
-              ]
-             m
-             (M.Map (CI ByteString) ByteString)
-getHead uri' | scheme == "https" = head' True
-             | scheme == "http"  = head' False
-             | otherwise         = throwE UnsupportedScheme
-
- where
-  scheme = view (uriSchemeL' % schemeBSL') uri'
-  head' https = do
-    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
-    liftE $ headInternal https host' fullPath' port'
-
-
-headInternal :: MonadIO m
-             => Bool        -- ^ https?
-             -> ByteString  -- ^ host
-             -> ByteString  -- ^ path with query
-             -> Maybe Int   -- ^ optional port
-             -> Excepts
-                  '[ HTTPStatusError
-                   , URIParseError
-                   , UnsupportedScheme
-                   , TooManyRedirs
-                   , NoLocationHeader
-                   ]
-                  m
-                  (M.Map (CI ByteString) ByteString)
-headInternal = go (5 :: Int)
-
- where
-  go redirs https host path port = do
-    r <- liftIO $ withConnection' https host port action
-    veitherToExcepts r >>= \case
-      Left r' ->
-        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
-      Right hs -> pure hs
-   where
-
-    action c = do
-      let q = buildRequest1 $ http HEAD path
-
-      sendRequest c q emptyBody
-
-      unsafeReceiveResponse
-        c
-        (\r _ -> runE $ do
-          let scode = getStatusCode r
-          if
-            | scode >= 200 && scode < 300 -> do
-              let headers = getHeaderMap r
-              pure $ Right headers
-            | scode >= 300 && scode < 400 -> case getHeader r "Location" of
-              Just r' -> pure $ Left r'
-              Nothing -> throwE NoLocationHeader
-            | otherwise -> throwE $ HTTPStatusError scode
-        )
-
-    followRedirectURL bs = case parseURI strictURIParserOptions bs of
-      Right uri' -> do
-        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
-        go (redirs - 1) https' host' fullPath' port'
-      Left e -> throwE e
-
 
 withConnection' :: Bool
                 -> ByteString

lib/GHCup/Errors.hs

@@ -27,14 +27,18 @@ import           Codec.Archive
 import qualified Codec.Archive.Tar             as Tar
 #endif
 import           Control.Exception.Safe
+import           Data.ByteString                ( ByteString )
+import           Data.CaseInsensitive           ( CI )
 import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           Haskus.Utils.Variant
-import           Text.PrettyPrint
-import           Text.PrettyPrint.HughesPJClass
+import           Text.PrettyPrint               hiding ( (<>) )
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           URI.ByteString
 
+import qualified Data.Map.Strict               as M
+
 
 
     ------------------------
@@ -130,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
@@ -164,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
 
@@ -180,13 +201,29 @@ instance Pretty DigestError where
     text [i|Digest error: expected "#{expectedDigest}", but got "#{currentDigest}"|]
 
 -- | Unexpected HTTP status.
-data HTTPStatusError = HTTPStatusError Int
+data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
   deriving Show
 
 instance Pretty HTTPStatusError where
-  pPrint (HTTPStatusError status) =
+  pPrint (HTTPStatusError status _) =
     text [i|Unexpected HTTP status: #{status}|]
 
+-- | Malformed headers.
+data MalformedHeaders = MalformedHeaders Text
+  deriving Show
+
+instance Pretty MalformedHeaders where
+  pPrint (MalformedHeaders h) =
+    text [i|Headers are malformed: #{h}|]
+
+-- | Unexpected HTTP status.
+data HTTPNotModified = HTTPNotModified Text
+  deriving Show
+
+instance Pretty HTTPNotModified where
+  pPrint (HTTPNotModified etag) =
+    text [i|Remote resource not modifed, etag was: #{etag}|]
+
 -- | The 'Location' header was expected during a 3xx redirect, but not found.
 data NoLocationHeader = NoLocationHeader
   deriving Show
@@ -240,6 +277,13 @@ instance Pretty NoNetwork where
   pPrint NoNetwork =
     text [i|A download was required or requested, but '--offline' was specified.|]
 
+data HadrianNotFound = HadrianNotFound
+  deriving Show
+
+instance Pretty HadrianNotFound where
+  pPrint HadrianNotFound =
+    text [i|Could not find Hadrian build files. Does this GHC version support Hadrian builds?|]
+
 
     -------------------------
     --[ High-level errors ]--
@@ -256,11 +300,11 @@ deriving instance Show DownloadFailed
 
 
 -- | A build failed.
-data BuildFailed = forall es . Show (V es) => BuildFailed FilePath (V es)
+data BuildFailed = forall es . (Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
 
 instance Pretty BuildFailed where
   pPrint (BuildFailed path reason) =
-    text [i|BuildFailed failed in dir "#{path}": #{reason}|]
+    text [i|BuildFailed failed in dir "#{path}": |] <> pPrint reason
 
 deriving instance Show BuildFailed
 
@@ -300,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
+
 
 
     ------------------------

lib/GHCup/Types.hs

@@ -384,7 +384,7 @@ data Dirs = Dirs
   , cacheDir :: FilePath
   , logsDir  :: FilePath
   , confDir  :: FilePath
-  , tmpDir   :: FilePath
+  , recycleDir :: FilePath -- mainly used on windows
   }
   deriving (Show, GHC.Generic)
 

lib/GHCup/Types/Optics.hs

@@ -1,9 +1,11 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE MultiParamTypeClasses   #-}
 
 {-|
 Module      : GHCup.Types.Optics
@@ -143,3 +145,6 @@ getCache = getSettings <&> cache
 getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
 getDownloader = getSettings <&> downloader
 
+
+instance LabelOptic "dirs" A_Lens Dirs Dirs Dirs Dirs where
+  labelOptic = lens id (\_ d -> d)

lib/GHCup/Utils.hs

@@ -53,6 +53,7 @@ import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
+import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
 #if defined(IS_WINDOWS)
 import           Data.Bits
 #endif
@@ -78,6 +79,7 @@ import           System.Win32.Console
 import           System.Win32.File     hiding ( copyFile )
 import           System.Win32.Types
 #endif
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           Text.Regex.Posix
 import           URI.ByteString
 
@@ -122,6 +124,7 @@ rmMinorSymlinks :: ( MonadReader env m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
+                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
@@ -133,7 +136,7 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
     let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
     let fullF = binDir </> f_xyz
     lift $ $(logDebug) [i|rm -f #{fullF}|]
-    liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+    lift $ hideError doesNotExistErrorType $ rmLink fullF
 
 
 -- | Removes the set ghc version for the given target, if any.
@@ -143,6 +146,7 @@ rmPlain :: ( MonadReader env m
            , MonadThrow m
            , MonadFail m
            , MonadIO m
+           , MonadMask m
            )
         => Maybe Text -- ^ target
         -> Excepts '[NotInstalled] m ()
@@ -154,11 +158,11 @@ rmPlain target = do
     forM_ files $ \f -> do
       let fullF = binDir </> f <> exeExt
       lift $ $(logDebug) [i|rm -f #{fullF}|]
-      liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+      lift $ hideError doesNotExistErrorType $ rmLink fullF
     -- old ghcup
     let hdc_file = binDir </> "haddock-ghc" <> exeExt
     lift $ $(logDebug) [i|rm -f #{hdc_file}|]
-    liftIO $ hideError doesNotExistErrorType $ rmLink hdc_file
+    lift $ hideError doesNotExistErrorType $ rmLink hdc_file
 
 
 -- | Remove the major GHC symlink, e.g. ghc-8.6.
@@ -168,6 +172,7 @@ rmMajorSymlinks :: ( MonadReader env m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
+                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
@@ -181,7 +186,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
     let f_xy = f <> "-" <> T.unpack v' <> exeExt
     let fullF = binDir </> f_xy
     lift $ $(logDebug) [i|rm -f #{fullF}|]
-    liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+    lift $ hideError doesNotExistErrorType $ rmLink fullF
 
 
 
@@ -761,49 +766,22 @@ ghcToolFiles ver = do
   whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
         (throwE (NotInstalled GHC ver))
 
-  files    <- liftIO $ listDirectory bindir
-  -- figure out the <ver> suffix, because this might not be `Version` for
-  -- alpha/rc releases, but x.y.a.somedate.
+  files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
+  pure (getUniqueTools . groupToolFiles . fmap (dropSuffix exeExt) $ files)
 
-  ghcIsHadrian    <- liftIO $ isHadrian bindir
-  onlyUnversioned <- case ghcIsHadrian of
-    Right () -> pure id
-    Left (fmap (dropSuffix exeExt) -> [ghc, ghc_ver])
-      | (Just symver) <- stripPrefix (ghc <> "-") ghc_ver
-      , not (null symver) -> pure $ filter (\x -> not $ symver `isInfixOf` x)
-    _ -> fail "Fatal: Could not find internal GHC version"
-
-  pure $ onlyUnversioned $ fmap (dropSuffix exeExt) files
  where
-  isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
-    -- GHC is moving some builds to Hadrian for bindists,
-    -- which doesn't create versioned binaries.
-    -- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
-  isHadrian :: FilePath -- ^ ghcbin path
-            -> IO (Either [String] ()) -- ^ Right for Hadrian
-  isHadrian dir = do
-    -- Non-hadrian has e.g. ["ghc", "ghc-8.10.4"]
-    -- which also requires us to discover the internal version
-    -- to filter the correct tool files.
-    -- We can't use the symlink on windows, so we fall back to some
-    -- more complicated logic.
-    fs <- fmap
-         -- regex over-matches
-         (filter (isNotAnyInfix ["haddock", "ghc-pkg", "ghci"]))
-       $ liftIO $ findFiles
-      dir
-      (makeRegexOpts compExtended
-                     execBlank
-                     -- for cross, this won't be "ghc", but e.g.
-                     -- "armv7-unknown-linux-gnueabihf-ghc"
-                     ([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc.*$|] :: ByteString)
-      )
-    if | length fs == 1 -> pure $ Right ()        -- hadrian
-       | length fs == 2 -> pure $ Left
-                              (sortOn length fs)  -- legacy make, result should
-                                                  -- be ["ghc", "ghc-8.10.4"]
-       | otherwise      -> fail "isHadrian failed!"
 
+  groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
+  groupToolFiles = groupBy (\(a, _) (b, _) -> a == b) . fmap (splitOnPVP "-")
+
+  getUniqueTools :: [[(FilePath, String)]] -> [String]
+  getUniqueTools = filter (isNotAnyInfix blackListedTools) . nub . fmap fst . filter ((== "") . snd) . concat
+
+  blackListedTools :: [String]
+  blackListedTools = ["haddock-ghc"]
+
+  isNotAnyInfix :: [String] -> String -> Bool
+  isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
 
 
 -- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
@@ -882,8 +860,17 @@ getChangeLog dls tool (Right tag) =
 --
 --   1. the build directory, depending on the KeepDirs setting
 --   2. the install destination, depending on whether the build failed
-runBuildAction :: (Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
-               => FilePath          -- ^ build directory (cleaned up depending on Settings)
+runBuildAction :: ( Pretty (V e)
+                  , Show (V e)
+                  , MonadReader env m
+                  , HasDirs env
+                  , HasSettings env
+                  , MonadIO m
+                  , MonadMask m
+                  , MonadLogger m
+                  , MonadUnliftIO m
+                  )
+               => FilePath        -- ^ build directory (cleaned up depending on Settings)
                -> Maybe FilePath  -- ^ dir to *always* clean up on exception
                -> Excepts e m a
                -> Excepts '[BuildFailed] m a
@@ -891,11 +878,9 @@ runBuildAction bdir instdir action = do
   Settings {..} <- lift getSettings
   let exAction = do
         forM_ instdir $ \dir ->
-          liftIO $ hideError doesNotExistErrorType $ rmPath dir
+          lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
         when (keepDirs == Never)
-          $ liftIO
-          $ hideError doesNotExistErrorType
-          $ rmPath bdir
+          $ lift $ rmBDir bdir
   v <-
     flip onException exAction
     $ catchAllE
@@ -904,10 +889,20 @@ runBuildAction bdir instdir action = do
           throwE (BuildFailed bdir es)
         ) action
 
-  when (keepDirs == Never || keepDirs == Errors) $ liftIO $ rmPath bdir
+  when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
   pure v
 
 
+-- | Remove a build directory, ignoring if it doesn't exist and gracefully
+-- printing other errors without crashing.
+rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
+rmBDir dir = withRunInIO (\run -> run $
+           liftIO $ handleIO (\e -> run $ $(logWarn)
+               [i|Couldn't remove build dir #{dir}, error was: #{displayException e}|])
+           $ hideError doesNotExistErrorType
+           $ rmPathForcibly dir)
+
+
 getVersionInfo :: Version
                -> Tool
                -> GHCupDownloads
@@ -994,13 +989,13 @@ pathIsLink = pathIsSymbolicLink
 #endif
 
 
-rmLink :: FilePath -> IO ()
+rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
 #if defined(IS_WINDOWS)
 rmLink fp = do
-  hideError doesNotExistErrorType . liftIO . rmFile $ fp
-  hideError doesNotExistErrorType . liftIO . rmFile $ (dropExtension fp <.> "shim")
+  hideError doesNotExistErrorType . recycleFile $ fp
+  hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
 #else
-rmLink = hideError doesNotExistErrorType . liftIO . rmFile
+rmLink = hideError doesNotExistErrorType . recycleFile
 #endif
 
 
@@ -1038,14 +1033,14 @@ createLink link exe = do
       shimContents = "path = " <> fullLink
 
   $(logDebug) [i|rm -f #{exe}|]
-  liftIO $ rmLink exe
+  rmLink exe
 
   $(logDebug) [i|ln -s #{fullLink} #{exe}|]
   liftIO $ copyFile shimGen exe
   liftIO $ writeFile shim shimContents
 #else
   $(logDebug) [i|rm -f #{exe}|]
-  liftIO $ hideError doesNotExistErrorType $ rmFile exe
+  hideError doesNotExistErrorType $ recycleFile exe
 
   $(logDebug) [i|ln -s #{link} #{exe}|]
   liftIO $ createFileLink link exe
@@ -1067,7 +1062,6 @@ ensureGlobalTools :: ( MonadMask m
 ensureGlobalTools = do
 #if defined(IS_WINDOWS)
   (GHCupInfo _ _ gTools) <- lift getGHCupInfo
-  settings <- lift getSettings
   dirs <- lift getDirs
   shimDownload <- liftE $ lE @_ @'[NoDownload]
     $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
@@ -1075,7 +1069,7 @@ ensureGlobalTools = do
   void $ (\(DigestError _ _) -> do
       lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
       lift $ $(logDebug) [i|rm -f #{shimDownload}|]
-      liftIO $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
+      lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
       liftE @'[DigestError , DownloadFailed] $ dl
     ) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
   pure ()
@@ -1086,14 +1080,14 @@ ensureGlobalTools = do
 
 -- | Ensure ghcup directory structure exists.
 ensureDirectories :: Dirs -> IO ()
-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
   createDirRecursive' baseDir
   createDirRecursive' (baseDir </> "ghc")
   createDirRecursive' binDir
   createDirRecursive' cacheDir
   createDirRecursive' logsDir
   createDirRecursive' confDir
-  createDirRecursive' tmpDir
+  createDirRecursive' trashDir
   pure ()
 
 
@@ -1107,4 +1101,3 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
 ghcBinaryName :: GHCTargetVersion -> String
 ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
 ghcBinaryName (GHCTargetVersion Nothing  v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
-

lib/GHCup/Utils/Dirs.hs

@@ -30,6 +30,7 @@ module GHCup.Utils.Dirs
 #if !defined(IS_WINDOWS)
   , useXDG
 #endif
+  , cleanupTrash
   )
 where
 
@@ -53,9 +54,7 @@ import           Data.String.Interpolate
 import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
 import           Haskus.Utils.Variant.Excepts
 import           Optics
-#if !defined(IS_WINDOWS)
 import           System.Directory                                                
-#endif
 import           System.DiskSpace                                                
 import           System.Environment
 import           System.FilePath
@@ -191,23 +190,21 @@ ghcupLogsDir = do
 #endif
 
 
--- | Defaults to '~/.ghcup/tmp.
---
--- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
--- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec.
-ghcupTmpDir :: IO FilePath
-ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
+-- | '~/.ghcup/trash'.
+-- Mainly used on windows to improve file removal operations
+ghcupRecycleDir :: IO FilePath
+ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
 
 
 
 getAllDirs :: IO Dirs
 getAllDirs = do
-  baseDir  <- ghcupBaseDir
-  binDir   <- ghcupBinDir
-  cacheDir <- ghcupCacheDir
-  logsDir  <- ghcupLogsDir
-  confDir  <- ghcupConfigDir
-  tmpDir   <- ghcupTmpDir
+  baseDir    <- ghcupBaseDir
+  binDir     <- ghcupBinDir
+  cacheDir   <- ghcupCacheDir
+  logsDir    <- ghcupLogsDir
+  confDir    <- ghcupConfigDir
+  recycleDir <- ghcupRecycleDir
   pure Dirs { .. }
 
 
@@ -262,7 +259,15 @@ parseGHCupGHCDir (T.pack -> fp) =
   throwEither $ MP.parse ghcTargetVerP "" fp
 
 
-mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
+mkGhcupTmpDir :: ( MonadReader env m
+                 , HasDirs env
+                 , MonadUnliftIO m
+                 , MonadLogger m
+                 , MonadCatch m
+                 , MonadThrow m
+                 , MonadMask m
+                 , MonadIO m)
+              => m FilePath
 mkGhcupTmpDir = do
   tmpdir <- liftIO getCanonicalTemporaryDirectory
 
@@ -283,8 +288,25 @@ mkGhcupTmpDir = do
       where t = 10^n
 
 
-withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
-withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath)
+withGHCupTmpDir :: ( MonadReader env m
+                   , HasDirs env
+                   , MonadUnliftIO m
+                   , MonadLogger m
+                   , MonadCatch m
+                   , MonadResource m
+                   , MonadThrow m
+                   , MonadMask m
+                   , MonadIO m)
+                => m FilePath
+withGHCupTmpDir = snd <$> withRunInIO (\run ->
+  run
+    $ allocate
+        (run mkGhcupTmpDir)
+        (\fp ->
+            handleIO (\e -> run
+                $ $(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|])
+            . rmPathForcibly
+            $ fp))
 
 
 
@@ -312,3 +334,21 @@ relativeSymlink p1 p2 =
         <> joinPath ([pathSeparator] : drop (length common) d2)
 
 
+cleanupTrash :: ( MonadIO m
+                , MonadMask m
+                , MonadLogger m
+                , MonadReader env m
+                , HasDirs env
+                )
+             => m ()
+cleanupTrash = do
+  Dirs { recycleDir } <- getDirs
+  contents <- liftIO $ listDirectory recycleDir
+  if null contents
+  then pure ()
+  else do
+    $(logWarn) [i|Removing leftover files in #{recycleDir}|]
+    forM_ contents (\fp -> handleIO (\e ->
+        $(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|]
+      ) $ liftIO $ removePathForcibly (recycleDir </> fp))
+

lib/GHCup/Utils/File/Windows.hs

@@ -209,6 +209,20 @@ exec exe args chdir env = do
   pure $ toProcessError exe args exit_code
 
 
+-- | Thin wrapper around `executeFile`.
+execShell :: MonadIO m
+          => FilePath       -- ^ thing to execute
+          -> [FilePath]     -- ^ args for the thing
+          -> Maybe FilePath   -- ^ optionally chdir into this
+          -> Maybe [(String, String)] -- ^ optional environment
+          -> m (Either ProcessError ())
+execShell exe args chdir env = do
+  let cmd = exe <> " " <> concatMap (' ':) args
+  cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env })
+  exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
+  pure $ toProcessError cmd [] exit_code
+
+
 chmod_755 :: MonadIO m => FilePath -> m ()
 chmod_755 fp =
   let perm = setOwnerWritable True emptyPermissions

lib/GHCup/Utils/Logger.hs

@@ -14,12 +14,16 @@ Here we define our main logger.
 -}
 module GHCup.Utils.Logger where
 
+import           GHCup.Types
+import           GHCup.Types.Optics
 import           GHCup.Utils.File
 import           GHCup.Utils.String.QQ
 
+import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
+import           Control.Monad.Reader
 import           Data.Char               ( ord )
 import           Prelude                 hiding ( appendFile )
 import           System.Console.Pretty
@@ -79,17 +83,21 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
     rawOutter outr
 
 
-initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath
-initGHCupFileLogging logsDir = do
+initGHCupFileLogging :: ( MonadReader env m
+                        , HasDirs env
+                        , MonadIO m
+                        , MonadMask m
+                        ) => m FilePath
+initGHCupFileLogging = do
+  Dirs { logsDir } <- getDirs
   let logfile = logsDir </> "ghcup.log"
-  liftIO $ do
-    logFiles <- findFiles
-      logsDir
-      (makeRegexOpts compExtended
-                     execBlank
-                     ([s|^.*\.log$|] :: B.ByteString)
-      )
-    forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
+  logFiles <- liftIO $ findFiles
+    logsDir
+    (makeRegexOpts compExtended
+                   execBlank
+                   ([s|^.*\.log$|] :: B.ByteString)
+    )
+  forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
 
-    writeFile logfile ""
-    pure logfile
+  liftIO $ writeFile logfile ""
+  pure logfile

lib/GHCup/Utils/Prelude.hs

@@ -19,14 +19,19 @@ GHCup specific prelude. Lots of Excepts functionality.
 -}
 module GHCup.Utils.Prelude where
 
+#if defined(IS_WINDOWS)
+import           GHCup.Types
+#endif
+import           GHCup.Types.Optics
+
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Class      ( lift )
+import           Control.Monad.Reader
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( nub )
+import           Data.List                      ( nub, intercalate )
 import           Data.Foldable
 import           Data.String
 import           Data.Text                      ( Text )
@@ -35,6 +40,9 @@ import           Data.Word8
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           System.IO.Error
+#if defined(IS_WINDOWS)
+import           System.IO.Temp
+#endif
 import           System.IO.Unsafe
 import           System.Directory
 import           System.FilePath
@@ -47,6 +55,7 @@ import           GHC.IO.Exception
 import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
+import qualified Data.List.Split               as Split
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Text.Encoding.Error      as E
@@ -54,6 +63,9 @@ import qualified Data.Text.Lazy                as TL
 import qualified Data.Text.Lazy.Builder        as B
 import qualified Data.Text.Lazy.Builder.Int    as B
 import qualified Data.Text.Lazy.Encoding       as TLE
+#if defined(IS_WINDOWS)
+import qualified System.Win32.File             as Win32
+#endif
 
 
 
@@ -312,17 +324,16 @@ createDirRecursive' p =
 -- | Recursively copy the contents of one directory to another path.
 --
 -- This is a rip-off of Cabal library.
-copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
-copyDirectoryRecursive srcDir destDir = do
+copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
+copyDirectoryRecursive srcDir destDir doCopy = do
   srcFiles <- getDirectoryContentsRecursive srcDir
-  copyFilesWith copyFile destDir [ (srcDir, f)
-                                   | f <- srcFiles ]
+  copyFilesWith destDir [ (srcDir, f)
+                          | f <- srcFiles ]
   where
     -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
     -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
-    copyFilesWith :: (FilePath -> FilePath -> IO ())
-                  -> FilePath -> [(FilePath, FilePath)] -> IO ()
-    copyFilesWith doCopy targetDir srcFiles = do
+    copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
+    copyFilesWith targetDir srcFiles = do
 
       -- Create parent directories for everything
       let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
@@ -367,42 +378,117 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""]
         ignore ['.', '.'] = True
         ignore _          = False
 
+
 -- https://github.com/haskell/directory/issues/110
 -- https://github.com/haskell/directory/issues/96
 -- https://www.sqlite.org/src/info/89f1848d7f
-rmPath :: (MonadIO m, MonadMask m)
-      => FilePath
-      -> m ()
-rmPath fp =
+recyclePathForcibly :: ( MonadIO m
+                       , MonadReader env m
+                       , HasDirs env
+                       , MonadMask m
+                       )
+                    => FilePath
+                    -> m ()
+recyclePathForcibly fp = do
 #if defined(IS_WINDOWS)
-  recovering (fullJitterBackoff 25000 <> limitRetries 10)
-    [\_ -> Handler (\e -> pure $ isPermissionError e)
-    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
-    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
-    ]
-    (\_ -> liftIO $ removePathForcibly fp)
+  Dirs { recycleDir } <- getDirs
+  tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
+  let dest = tmp </> takeFileName fp
+  liftIO (Win32.moveFileEx fp (Just dest) 0)
+      `catch`
+      (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+      `finally`
+        (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
 #else
-  liftIO $ removeDirectoryRecursive fp
+  liftIO $ removePathForcibly fp
+#endif
+
+
+rmPathForcibly :: ( MonadIO m
+                  , MonadMask m
+                  )
+               => FilePath
+               -> m ()
+rmPathForcibly fp =
+#if defined(IS_WINDOWS)
+  recover (liftIO $ removePathForcibly fp)
+#else
+  liftIO $ removePathForcibly fp
+#endif
+
+
+rmDirectory :: (MonadIO m, MonadMask m)
+            => FilePath
+            -> m ()
+rmDirectory fp =
+#if defined(IS_WINDOWS)
+  recover (liftIO $ removeDirectory fp)
+#else
+  liftIO $ removeDirectory fp
 #endif
 
 
 -- https://www.sqlite.org/src/info/89f1848d7f
 -- https://github.com/haskell/directory/issues/96
-rmFile :: (MonadIO m, MonadMask m)
+recycleFile :: ( MonadIO m
+               , MonadMask m
+               , MonadReader env m
+               , HasDirs env
+               )
+            => FilePath
+            -> m ()
+recycleFile fp = do
+#if defined(IS_WINDOWS)
+  Dirs { recycleDir } <- getDirs
+  liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
+  tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
+  let dest = tmp </> takeFileName fp
+  liftIO (Win32.moveFileEx fp (Just dest) 0)
+    `catch`
+      (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+    `finally`
+      (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+#else
+  liftIO $ removeFile fp
+#endif
+
+
+rmFile :: ( MonadIO m
+          , MonadMask m
+          )
       => FilePath
       -> m ()
 rmFile fp =
 #if defined(IS_WINDOWS)
-  recovering (fullJitterBackoff 25000 <> limitRetries 10)
-    [\_ -> Handler (\e -> pure $ isPermissionError e)
-    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
-    ]
-    (\_ -> liftIO $ removeFile fp)
+  recover (liftIO $ removeFile fp)
 #else
   liftIO $ removeFile fp
 #endif
 
 
+rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
+                => FilePath
+                -> m ()
+rmDirectoryLink fp = 
+#if defined(IS_WINDOWS)
+  recover (liftIO $ removeDirectoryLink fp)
+#else
+  liftIO $ removeDirectoryLink fp
+#endif
+
+
+#if defined(IS_WINDOWS)
+recover :: (MonadIO m, MonadMask m) => m a -> m a
+recover action = 
+  recovering (fullJitterBackoff 25000 <> limitRetries 10)
+    [\_ -> Handler (\e -> pure $ isPermissionError e)
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
+    ]
+    (\_ -> action)
+#endif
+
+
 -- Gathering monoidal values
 traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
 traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
@@ -420,8 +506,32 @@ stripNewline s
   | otherwise            = head s : stripNewline (tail s)
 
 
+-- | Strip @\\r@ and @\\n@ from 'ByteString's
+stripNewline' :: T.Text -> T.Text
+stripNewline' s
+  | T.null s               = mempty
+  | T.head s `elem` "\n\r" = stripNewline' (T.tail s)
+  | otherwise              = T.singleton (T.head s) <> stripNewline' (T.tail s)
+
+
 isNewLine :: Word8 -> Bool
 isNewLine w
   | w == _lf = True
   | w == _cr = True
   | otherwise = False
+
+
+-- | Split on a PVP suffix.
+--
+-- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706" == ("ghc-iserv-dyn", "9.3.20210706")
+-- >>> splitOnPVP "-" "ghc-iserv-dyn"              == ("ghc-iserv-dyn", "")
+splitOnPVP :: String -> String -> (String, String)
+splitOnPVP c s = case Split.splitOn c s of
+  []  -> def
+  [_] -> def
+  xs
+    | let l = last xs
+    , (Right _) <- pvp (T.pack l) -> (intercalate c (init xs), l)
+    | otherwise -> def
+ where
+  def = (s, "")

lib/GHCup/Version.hs

@@ -25,7 +25,7 @@ import qualified Data.Text                     as T
 
 -- | This reflects the API version of the YAML.
 ghcupURL :: URI
-ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.5.yaml|]
+ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.6.yaml|]
 
 -- | The current ghcup version.
 ghcUpVer :: PVP

stack.yaml

@@ -10,6 +10,9 @@ extra-deps:
   - git: https://github.com/Bodigrim/tar
     commit: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
 
+  - git: https://github.com/jtdaugherty/brick.git
+    commit: b3b96cfe66dfd398d338e3feb2b6855e66a35190
+
   - IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
   - ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
   - base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231

www/index.html

@@ -128,7 +128,10 @@
         <div>
           <p>
             If you are running Windows,<br/>run the following in a powershell session (as a non-admin user).
-			<div class="command-button"><pre><span class='ghcup-command'>Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $false</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
+			<div class="command-button"><pre><span class='ghcup-command'>Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button>
+			</div>
+				<p class="other-help">If you want to run a non-interactive installation, change <span class='code'>$true</span> to <span class='code'>$false</span> at the end of the script.</p>
+			</div>
           </p>
         </div>