diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0860003..9e089cc 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -13,7 +13,7 @@ variables: # Sequential version number of all cached things. # Bump to invalidate GitLab CI cache. - CACHE_REV: 0 + CACHE_REV: 1 GIT_SUBMODULE_STRATEGY: recursive @@ -125,6 +125,10 @@ variables: - test/golden - dist-newstyle/cache/ when: on_failure + cache: + key: ghcup-test-$CACHE_REV + paths: + - cabal-cache # .test_ghcup_scoop: # script: @@ -134,72 +138,77 @@ variables: extends: - .test_ghcup_version - .debian - - .root_cleanup before_script: - ./.gitlab/before_script/linux/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:linux32: extends: - .test_ghcup_version - .alpine:32bit - - .root_cleanup before_script: - ./.gitlab/before_script/linux/alpine/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:armv7: extends: - .test_ghcup_version - .linux:armv7 - - .root_cleanup before_script: - ./.gitlab/before_script/linux/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:aarch64: extends: - .test_ghcup_version - .linux:aarch64 - - .root_cleanup before_script: - ./.gitlab/before_script/linux/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:darwin: extends: - .test_ghcup_version - .darwin - - .root_cleanup before_script: - ./.gitlab/before_script/darwin/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:darwin:aarch64: extends: - .test_ghcup_version - .darwin:aarch64 - - .root_cleanup cache: key: darwin-brew-$CACHE_REV paths: - - .brew - - .brew_cache + - brew_cache + key: ghcup-test-$CACHE_REV + paths: + - cabal-cache before_script: - # Install brew locally in the project dir. Packages will also be installed here. - - '[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew' - - export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" - + # extract brew cache + - ./.gitlab/script/ci.sh extract_brew_cache # otherwise we seem to get intel binaries - export HOMEBREW_CHANGE_ARCH_TO_ARM=1 - - # make sure to not pollute the machine with temp files etc - - mkdir -p $CI_PROJECT_DIR/.brew_cache - - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache - - mkdir -p $CI_PROJECT_DIR/.brew_logs - - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs - - mkdir -p /private/tmp/.brew_tmp - - export HOMEBREW_TEMP=/private/tmp/.brew_tmp - # update and install packages - - brew update - - brew install llvm - - brew install autoconf automake coreutils + - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils + # extract cabal cache + - ./.gitlab/script/ci.sh extract_cabal_cache script: | export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang @@ -209,40 +218,51 @@ variables: export RANLIB=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ranlib ./.gitlab/before_script/darwin/install_deps.sh ./.gitlab/script/ghcup_version.sh + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - ./.gitlab/script/ci.sh save_brew_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:freebsd12: extends: - .test_ghcup_version - .freebsd12 - - .root_cleanup before_script: - ./.gitlab/before_script/freebsd/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:freebsd13: extends: - .test_ghcup_version - .freebsd13 - - .root_cleanup before_script: - sudo pkg update - sudo pkg install --yes compat12x-amd64 - sudo ln -s libncurses.so.6 /usr/local/lib/libncurses.so.6.2 - ./.gitlab/before_script/freebsd/install_deps.sh + - ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh .test_ghcup_version:windows: extends: - .test_ghcup_version - .windows - - .root_cleanup before_script: - - set CABAL_DIR="$CI_PROJECT_DIR/cabal" - bash ./.gitlab/before_script/windows/install_deps.sh + - bash ./.gitlab/script/ci.sh extract_cabal_cache + after_script: + - bash ./.gitlab/script/ci.sh save_cabal_cache + - bash ./.gitlab/after_script.sh # .test_ghcup_scoop:windows: # extends: # - .windows # - .test_ghcup_scoop - # - .root_cleanup .release_ghcup: script: @@ -262,9 +282,12 @@ variables: test:linux:stack: stage: test before_script: + - ./.gitlab/script/ci.sh extract_stack_cache - ./.gitlab/before_script/linux/install_deps_minimal.sh script: - ./.gitlab/script/ghcup_stack.sh + after_script: + - ./.gitlab/script/ci.sh save_stack_cache extends: - .debian needs: [] @@ -294,6 +317,7 @@ test:windows:bootstrap_powershell_script: - "[Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)" - "[Environment]::SetEnvironmentVariable('CABAL_DIR', $null, [System.EnvironmentVariableTarget]::User)" - bash ./.gitlab/after_script.sh + - bash ./.gitlab/script/ci.sh save_cabal_cache variables: GHC_VERSION: "8.10.7" CABAL_VERSION: "3.6.2.0" @@ -540,28 +564,17 @@ release:darwin:aarch64: cache: key: darwin-brew-$CACHE_REV paths: - - .brew - - .brew_cache + - brew_cache + key: ghcup-test-$CACHE_REV + paths: + - cabal-cache before_script: - # Install brew locally in the project dir. Packages will also be installed here. - - '[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew' - - export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" - + - ./.gitlab/script/ci.sh extract_brew_cache + - ./.gitlab/script/ci.sh extract_cabal_cache # otherwise we seem to get intel binaries - export HOMEBREW_CHANGE_ARCH_TO_ARM=1 - - # make sure to not pollute the machine with temp files etc - - mkdir -p $CI_PROJECT_DIR/.brew_cache - - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache - - mkdir -p $CI_PROJECT_DIR/.brew_logs - - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs - - mkdir -p /private/tmp/.brew_tmp - - export HOMEBREW_TEMP=/private/tmp/.brew_tmp - # update and install packages - - brew update - - brew install llvm - - brew install autoconf automake + - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils script: | export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang @@ -571,6 +584,9 @@ release:darwin:aarch64: export RANLIB=$CI_PROJECT_DIR/.brew/opt/llvm/bin/llvm-ranlib ./.gitlab/before_script/darwin/install_deps.sh ./.gitlab/script/ghcup_release.sh + after_script: + - ./.gitlab/script/ci.sh save_cabal_cache + - ./.gitlab/script/ci.sh save_brew_cache variables: ARTIFACT: "aarch64-apple-darwin-ghcup" GHC_VERSION: "8.10.7" diff --git a/.gitlab/ghcup_env b/.gitlab/ghcup_env index 7a8ecd9..acf120e 100644 --- a/.gitlab/ghcup_env +++ b/.gitlab/ghcup_env @@ -1,11 +1,23 @@ if [ "${OS}" = "WINDOWS" ] ; then - export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" - export GHCUP_BIN="$CI_PROJECT_DIR/ghcup/bin" - export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" - export TMPDIR="$CI_PROJECT_DIR/tmp" + export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" + export GHCUP_BIN="$CI_PROJECT_DIR/ghcup/bin" + export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" + export TMPDIR="$CI_PROJECT_DIR/tmp" + export CABAL_DIR="$CI_PROJECT_DIR/cabal" + export CABAL_CACHE="$CI_PROJECT_DIR/cabal-cache" + export STACK_ROOT="$CI_PROJECT_DIR/stack" + export STACK_CACHE="$CI_PROJECT_DIR/stack-cache" + export BREW_DIR="$CI_PROJECT_DIR/.brew_cache" + export BREW_CACHE="$CI_PROJECT_DIR/brew-cache" else - export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" - export GHCUP_BIN="$CI_PROJECT_DIR/.ghcup/bin" - export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" - export TMPDIR="$CI_PROJECT_DIR/tmp" + export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR" + export GHCUP_BIN="$CI_PROJECT_DIR/.ghcup/bin" + export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH" + export TMPDIR="$CI_PROJECT_DIR/tmp" + export CABAL_DIR="$CI_PROJECT_DIR/cabal" + export CABAL_CACHE="$CI_PROJECT_DIR/cabal-cache" + export STACK_ROOT="$CI_PROJECT_DIR/stack" + export STACK_CACHE="$CI_PROJECT_DIR/stack-cache" + export BREW_DIR="$CI_PROJECT_DIR/.brew_cache" + export BREW_CACHE="$CI_PROJECT_DIR/brew-cache" fi diff --git a/.gitlab/script/brew.sh b/.gitlab/script/brew.sh new file mode 100755 index 0000000..de76963 --- /dev/null +++ b/.gitlab/script/brew.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +set -Eeuxo pipefail + +# Install brew locally in the project dir. Packages will also be installed here. +[ -e "$CI_PROJECT_DIR/.brew" ] || git clone --depth=1 https://github.com/Homebrew/brew $CI_PROJECT_DIR/.brew +export PATH="$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH" + +# make sure to not pollute the machine with temp files etc +mkdir -p $CI_PROJECT_DIR/.brew_cache +export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache +mkdir -p $CI_PROJECT_DIR/.brew_logs +export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs +mkdir -p /private/tmp/.brew_tmp +export HOMEBREW_TEMP=/private/tmp/.brew_tmp + +# update and install packages +brew update +brew install ${1+"$@"} diff --git a/.gitlab/script/ci.sh b/.gitlab/script/ci.sh new file mode 100755 index 0000000..dfebfb8 --- /dev/null +++ b/.gitlab/script/ci.sh @@ -0,0 +1,70 @@ +#!/usr/bin/env bash + +set -Eeuo pipefail + +TOP="$( cd "$(dirname "$0")" ; pwd -P )" +. "${TOP}/../ghcup_env" + +function save_cabal_cache () { + echo "Storing cabal cache from $CABAL_DIR to $CABAL_CACHE..." + rm -Rf "$CABAL_CACHE" + mkdir -p "$CABAL_CACHE" + if [ -d "$CABAL_DIR" ]; then + cp -Rf "$CABAL_DIR" "$CABAL_CACHE/" + fi +} + + +function extract_cabal_cache () { + if [ -d "$CABAL_CACHE" ]; then + echo "Extracting cabal cache from $CABAL_CACHE to $CABAL_DIR..." + mkdir -p "$CABAL_DIR" + cp -Rf "$CABAL_CACHE"/* "$CABAL_DIR" + fi +} + +function save_stack_cache () { + echo "Storing stack cache from $STACK_ROOT to $STACK_CACHE..." + rm -Rf "$STACK_CACHE" + mkdir -p "$STACK_CACHE" + if [ -d "$STACK_ROOT" ]; then + cp -Rf "$STACK_DIR" "$STACK_CACHE" + fi +} + + +function extract_stack_cache () { + if [ -d "$STACK_CACHE" ]; then + echo "Extracting stack cache from $STACK_CACHE to $STACK_ROOT..." + mkdir -p "$STACK_ROOT" + cp -Rf "$STACK_CACHE"/* "$STACK_ROOT" + fi +} + +function save_brew_cache () { + echo "Storing brew cache from $BREW_DIR to $BREW_CACHE..." + rm -Rf "$BREW_CACHE" + mkdir -p "$BREW_CACHE" + if [ -d "$BREW_DIR" ]; then + cp -Rf "$BREW_DIR" "$BREW_CACHE" + fi +} + + +function extract_brew_cache () { + if [ -d "$BREW_CACHE" ]; then + echo "Extracting stack cache from $BREW_CACHE to $BREW_DIR..." + mkdir -p "$BREW_DIR" + cp -Rf "$BREW_CACHE"/* "$BREW_DIR" + fi +} + +case $1 in + extract_cabal_cache) extract_cabal_cache ;; + save_cabal_cache) save_cabal_cache ;; + extract_stack_cache) extract_stack_cache ;; + save_stack_cache) save_stack_cache ;; + extract_brew_cache) extract_brew_cache ;; + save_brew_cache) save_brew_cache ;; + *) echo "unknown mode $1" ; exit 11 ;; +esac diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 0c4f3e7..6cabc69 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -1,4 +1,4 @@ -#!/bin/sh +#!/usr/bin/env bash set -eux @@ -8,6 +8,7 @@ mkdir -p "$CI_PROJECT_DIR"/.local/bin CI_PROJECT_DIR=$(pwd) + ecabal() { cabal "$@" } @@ -34,6 +35,8 @@ git describe --always ### build +rm -rf "${GHCUP_DIR}"/share + ecabal update if [ "${OS}" = "DARWIN" ] ; then @@ -94,16 +97,17 @@ rm -rf "${GHCUP_DIR}" eghcup --numeric-version eghcup install ghc ${GHC_VERSION} -[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ] -[ `eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version` = "${GHC_VERSION}" ] +ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})" +[ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ] +[ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ] eghcup set ghc ${GHC_VERSION} eghcup install cabal ${CABAL_VERSION} -[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] +[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] eghcup unset cabal "$GHCUP_BIN"/cabal --version && exit 1 || echo yes eghcup set cabal ${CABAL_VERSION} -[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] -[ `eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version` = "${CABAL_VERSION}" ] +[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] +[ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ] if [ "${OS}" != "FREEBSD" ] ; then if [ "${ARCH}" = "64" ] ; then @@ -212,7 +216,7 @@ eghcup rm $(ghc --numeric-version) # https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116 if [ "${OS}" = "LINUX" ] ; then if [ "${ARCH}" = "64" ] ; then - eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4 + eghcup install cabal -u https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.7.0.0-pre20220407/cabal-install-3.7-x86_64-linux-alpine.tar.xz 3.4.0.0-rc4 eghcup rm cabal 3.4.0.0-rc4 fi fi @@ -285,7 +289,20 @@ fi eghcup upgrade eghcup upgrade -f +# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke' +mkdir no_nuke/ +mkdir no_nuke/bar +echo 'foo' > no_nuke/file +echo 'bar' > no_nuke/bar/file +ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/cache/no_nuke +ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/logs/no_nuke # nuke eghcup nuke [ ! -e "${GHCUP_DIR}" ] + +# make sure nuke doesn't resolve symlinks +[ -e "$CI_PROJECT_DIR"/no_nuke/file ] +[ -e "$CI_PROJECT_DIR"/no_nuke/bar/file ] + + diff --git a/.hlint.yaml b/.hlint.yaml index 3540f0e..e7fea9c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -20,6 +20,7 @@ - ignore: {name: "Avoid lambda"} - ignore: {name: "Use uncurry"} - ignore: {name: "Use replicateM"} +- ignore: {name: "Use unless"} - ignore: {name: "Redundant irrefutable pattern"} diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index de367e8..f1fb54d 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -13,9 +13,10 @@ import GHCup.Errors import GHCup.Types.Optics ( getDirs ) import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils -import GHCup.Utils.Logger -import GHCup.Utils.Prelude ( decUTF8Safe ) -import GHCup.Utils.File +import GHCup.Prelude ( decUTF8Safe ) +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.Process import Brick import Brick.Widgets.Border @@ -44,7 +45,6 @@ import Data.Vector ( Vector import Data.Versions hiding ( str ) import Haskus.Utils.Variant.Excepts import Prelude hiding ( appendFile ) -import System.Directory ( canonicalizePath ) import System.FilePath import System.Exit import System.IO.Unsafe @@ -438,6 +438,8 @@ install' _ (_, ListResult {..}) = do , FileAlreadyExistsError , ProcessError , GHCupShadowed + , UninstallFailed + , MergeFileTreeError ] run (do @@ -512,7 +514,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif del' _ (_, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - let run = runE @'[NotInstalled] + let run = runE @'[NotInstalled, UninstallFailed] run (do let vi = getVersionInfo lVer lTool dls diff --git a/app/ghcup/GHCup/OptParse/ChangeLog.hs b/app/ghcup/GHCup/OptParse/ChangeLog.hs index 7c8db99..652d850 100644 --- a/app/ghcup/GHCup/OptParse/ChangeLog.hs +++ b/app/ghcup/GHCup/OptParse/ChangeLog.hs @@ -12,9 +12,11 @@ module GHCup.OptParse.ChangeLog where import GHCup.Types -import GHCup.Utils.Logger import GHCup.OptParse.Common -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ +import GHCup.Prelude.Process (exec) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -34,8 +36,6 @@ import GHCup.Types.Optics import GHCup.Utils import Data.Versions import URI.ByteString (serializeURIRef') -import GHCup.Utils.Prelude -import GHCup.Utils.File (exec) import Data.Char (toLower) diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs index 35867c7..234fcbb 100644 --- a/app/ghcup/GHCup/OptParse/Common.hs +++ b/app/ghcup/GHCup/OptParse/Common.hs @@ -16,10 +16,10 @@ import GHCup.Platform import GHCup.Types import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.MegaParsec -import GHCup.Utils.Prelude +import GHCup.Prelude +import GHCup.Prelude.Process +import GHCup.Prelude.Logger +import GHCup.Prelude.MegaParsec import Control.DeepSeq import Control.Concurrent @@ -52,7 +52,6 @@ import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) import Safe -import System.Directory import System.Process ( readProcess ) import System.FilePath import Text.HTML.TagSoup hiding ( Tag ) diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index 6989af9..5c2019a 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -13,13 +13,12 @@ module GHCup.OptParse.Compile where import GHCup import GHCup.Errors -import GHCup.Utils.File import GHCup.Types import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.Logger +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common -import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -388,6 +387,8 @@ type GHCEffects = '[ AlreadyInstalled , ProcessError , CopyError , BuildFailed + , UninstallFailed + , MergeFileTreeError ] type HLSEffects = '[ AlreadyInstalled , BuildFailed @@ -406,6 +407,8 @@ type HLSEffects = '[ AlreadyInstalled , NotInstalled , DirNotEmpty , ArchiveResult + , UninstallFailed + , MergeFileTreeError ] @@ -492,7 +495,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do case keepDirs settings of Never -> runLogger $ logError $ T.pack $ prettyShow err _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> - "Check the logs at " <> T.pack logsDir <> " and the build directory " + "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 9 @@ -551,7 +554,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do case keepDirs settings of Never -> runLogger $ logError $ T.pack $ prettyShow err _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> - "Check the logs at " <> T.pack logsDir <> " and the build directory " + "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 9 diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index c8072ab..c03b849 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -7,7 +7,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExplicitForAll #-} module GHCup.OptParse.Config where @@ -15,9 +14,9 @@ module GHCup.OptParse.Config where import GHCup.Errors import GHCup.Types import GHCup.Utils -import GHCup.Utils.Prelude -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common #if !MIN_VERSION_base(4,13,0) diff --git a/app/ghcup/GHCup/OptParse/DInfo.hs b/app/ghcup/GHCup/OptParse/DInfo.hs index 46c3d3d..23ced6e 100644 --- a/app/ghcup/GHCup/OptParse/DInfo.hs +++ b/app/ghcup/GHCup/OptParse/DInfo.hs @@ -17,9 +17,10 @@ import GHCup import GHCup.Errors import GHCup.Version import GHCup.Types -import GHCup.Utils.Prelude import GHCup.Utils.Dirs -import GHCup.Utils.Logger +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.Process #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -36,7 +37,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow ) import qualified Data.Text as T import Control.Exception.Safe (MonadMask) -import GHCup.Utils.File import Language.Haskell.TH diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs index f8a1310..d74dd8e 100644 --- a/app/ghcup/GHCup/OptParse/GC.hs +++ b/app/ghcup/GHCup/OptParse/GC.hs @@ -14,8 +14,8 @@ module GHCup.OptParse.GC where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -56,26 +56,26 @@ data GCOptions = GCOptions --[ Parsers ]-- --------------- - + gcP :: Parser GCOptions gcP = GCOptions - <$> + <$> switch (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'") - <*> + <*> switch (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions") - <*> + <*> switch (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)") - <*> + <*> switch (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version") - <*> + <*> switch (short 'c' <> long "cache" <> help "GC the GHCup cache") - <*> + <*> switch (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers") @@ -98,7 +98,7 @@ gcFooter = [s|Discussion: --------------------------- -type GCEffects = '[ NotInstalled ] +type GCEffects = '[ NotInstalled, UninstallFailed ] runGC :: MonadUnliftIO m @@ -129,7 +129,7 @@ gc :: ( Monad m -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode gc GCOptions{..} runAppState runLogger = runGC runAppState (do - when gcOldGHC rmOldGHC + when gcOldGHC (liftE rmOldGHC) lift $ when gcProfilingLibs rmProfilingLibs lift $ when gcShareDir rmShareDir liftE $ when gcHLSNoGHC rmHLSNoGHC diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 363ce51..a67b183 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -18,8 +18,9 @@ import GHCup.OptParse.Common import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Utils.Dirs +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import Codec.Archive #if !MIN_VERSION_base(4,13,0) @@ -257,6 +258,8 @@ type InstallEffects = '[ AlreadyInstalled , NoToolVersionSet , FileAlreadyExistsError , ProcessError + , UninstallFailed + , MergeFileTreeError , (AlreadyInstalled, ()) , (UnknownArchive, ()) @@ -264,9 +267,10 @@ type InstallEffects = '[ AlreadyInstalled , (FileDoesNotExistError, ()) , (CopyError, ()) , (NotInstalled, ()) + , (UninstallFailed, ()) + , (MergeFileTreeError, ()) , (DirNotEmpty, ()) , (NoDownload, ()) - , (NotInstalled, ()) , (BuildFailed, ()) , (TagNotFound, ()) , (DigestError, ()) @@ -287,6 +291,8 @@ type InstallEffects = '[ AlreadyInstalled , (DirNotEmpty, NotInstalled) , (NoDownload, NotInstalled) , (NotInstalled, NotInstalled) + , (UninstallFailed, NotInstalled) + , (MergeFileTreeError, NotInstalled) , (BuildFailed, NotInstalled) , (TagNotFound, NotInstalled) , (DigestError, NotInstalled) @@ -319,6 +325,8 @@ type InstallGHCEffects = '[ TagNotFound , BuildFailed , DirNotEmpty , AlreadyInstalled + , UninstallFailed + , MergeFileTreeError , (AlreadyInstalled, NotInstalled) , (UnknownArchive, NotInstalled) @@ -328,6 +336,8 @@ type InstallGHCEffects = '[ TagNotFound , (NotInstalled, NotInstalled) , (DirNotEmpty, NotInstalled) , (NoDownload, NotInstalled) + , (UninstallFailed, NotInstalled) + , (MergeFileTreeError, NotInstalled) , (BuildFailed, NotInstalled) , (TagNotFound, NotInstalled) , (DigestError, NotInstalled) @@ -347,6 +357,8 @@ type InstallGHCEffects = '[ TagNotFound , (NotInstalled, ()) , (DirNotEmpty, ()) , (NoDownload, ()) + , (UninstallFailed, ()) + , (MergeFileTreeError, ()) , (BuildFailed, ()) , (TagNotFound, ()) , (DigestError, ()) @@ -441,21 +453,21 @@ install installCommand settings getAppState' runLogger = case installCommand of case keepDirs settings of Never -> runLogger (logError $ T.pack $ prettyShow err) _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> - "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> + "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 3 VLeft err@(V (BuildFailed tmpdir _, ())) -> do case keepDirs settings of Never -> runLogger (logError $ T.pack $ prettyShow err) _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> - "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> + "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 3 VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir + logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 3 @@ -507,7 +519,7 @@ install installCommand settings getAppState' runLogger = case installCommand of VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir + logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 4 installHLS :: InstallOptions -> IO ExitCode @@ -567,7 +579,7 @@ install installCommand settings getAppState' runLogger = case installCommand of VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir + logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 4 installStack :: InstallOptions -> IO ExitCode @@ -618,6 +630,6 @@ install installCommand settings getAppState' runLogger = case installCommand of VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e - logError $ "Also check the logs in " <> T.pack logsDir + logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 4 diff --git a/app/ghcup/GHCup/OptParse/List.hs b/app/ghcup/GHCup/OptParse/List.hs index d1bfc65..72cd2bb 100644 --- a/app/ghcup/GHCup/OptParse/List.hs +++ b/app/ghcup/GHCup/OptParse/List.hs @@ -11,7 +11,7 @@ module GHCup.OptParse.List where import GHCup -import GHCup.Utils.Prelude +import GHCup.Prelude import GHCup.Types import GHCup.OptParse.Common diff --git a/app/ghcup/GHCup/OptParse/Nuke.hs b/app/ghcup/GHCup/OptParse/Nuke.hs index 75537de..84712d4 100644 --- a/app/ghcup/GHCup/OptParse/Nuke.hs +++ b/app/ghcup/GHCup/OptParse/Nuke.hs @@ -14,7 +14,7 @@ module GHCup.OptParse.Nuke where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger +import GHCup.Prelude.Logger #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay) --------------------------- -type NukeEffects = '[ NotInstalled ] +type NukeEffects = '[ NotInstalled, UninstallFailed ] runNuke :: AppState diff --git a/app/ghcup/GHCup/OptParse/Prefetch.hs b/app/ghcup/GHCup/OptParse/Prefetch.hs index 87f6bdb..221ecef 100644 --- a/app/ghcup/GHCup/OptParse/Prefetch.hs +++ b/app/ghcup/GHCup/OptParse/Prefetch.hs @@ -14,9 +14,10 @@ module GHCup.OptParse.Prefetch where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common -import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -33,7 +34,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow ) import qualified Data.Text as T import Control.Exception.Safe (MonadMask) -import GHCup.Utils.Prelude import GHCup.Download (getDownloadsF) diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs index 591840e..26d7471 100644 --- a/app/ghcup/GHCup/OptParse/Rm.hs +++ b/app/ghcup/GHCup/OptParse/Rm.hs @@ -18,9 +18,9 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.Logger +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common -import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -127,7 +127,7 @@ rmFooter = [s|Discussion: --------------------------- -type RmEffects = '[ NotInstalled ] +type RmEffects = '[ NotInstalled, UninstallFailed ] runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a)) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 7f95021..90938f6 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -10,14 +10,17 @@ module GHCup.OptParse.Run where import GHCup import GHCup.Utils -import GHCup.Utils.Prelude -import GHCup.Utils.File import GHCup.OptParse.Common import GHCup.Errors import GHCup.Types import GHCup.Types.Optics -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.File +#ifdef IS_WINDOWS +import GHCup.Prelude.Process +#endif +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import Control.Exception.Safe ( MonadMask, MonadCatch ) #if !MIN_VERSION_base(4,13,0) @@ -32,7 +35,6 @@ import Data.List ( intercalate ) import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) -import System.Directory import System.FilePath import System.Environment import System.Exit @@ -176,6 +178,8 @@ type RunEffects = '[ AlreadyInstalled , NoToolVersionSet , FileAlreadyExistsError , ProcessError + , UninstallFailed + , MergeFileTreeError ] runLeanRUN :: (MonadUnliftIO m, MonadIO m) @@ -339,6 +343,8 @@ run RunOptions{..} runAppState leanAppstate runLogger = do , AlreadyInstalled , FileAlreadyExistsError , CopyError + , UninstallFailed + , MergeFileTreeError ] (ResourceT (ReaderT AppState m)) () installToolChainFull Toolchain{..} tmp = do forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs index 5514085..22f8da6 100644 --- a/app/ghcup/GHCup/OptParse/Set.hs +++ b/app/ghcup/GHCup/OptParse/Set.hs @@ -17,8 +17,8 @@ import GHCup.OptParse.Common import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/ToolRequirements.hs b/app/ghcup/GHCup/OptParse/ToolRequirements.hs index f7048ea..f917a05 100644 --- a/app/ghcup/GHCup/OptParse/ToolRequirements.hs +++ b/app/ghcup/GHCup/OptParse/ToolRequirements.hs @@ -11,8 +11,8 @@ module GHCup.OptParse.ToolRequirements where import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -30,7 +30,7 @@ import qualified Data.Text.IO as T import Control.Exception.Safe (MonadMask) import GHCup.Types.Optics import GHCup.Platform -import GHCup.Utils.Prelude +import GHCup.Prelude import GHCup.Requirements import System.IO diff --git a/app/ghcup/GHCup/OptParse/UnSet.hs b/app/ghcup/GHCup/OptParse/UnSet.hs index fd3c4fa..08e804d 100644 --- a/app/ghcup/GHCup/OptParse/UnSet.hs +++ b/app/ghcup/GHCup/OptParse/UnSet.hs @@ -16,8 +16,8 @@ module GHCup.OptParse.UnSet where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Upgrade.hs b/app/ghcup/GHCup/OptParse/Upgrade.hs index bceb4dc..193d178 100644 --- a/app/ghcup/GHCup/OptParse/Upgrade.hs +++ b/app/ghcup/GHCup/OptParse/Upgrade.hs @@ -14,7 +14,8 @@ module GHCup.OptParse.Upgrade where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger +import GHCup.Prelude.File +import GHCup.Prelude.Logger #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Whereis.hs b/app/ghcup/GHCup/OptParse/Whereis.hs index 02c27b6..ed86697 100644 --- a/app/ghcup/GHCup/OptParse/Whereis.hs +++ b/app/ghcup/GHCup/OptParse/Whereis.hs @@ -17,8 +17,9 @@ import GHCup import GHCup.Errors import GHCup.OptParse.Common import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Utils +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -299,7 +300,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do pure $ ExitFailure 30 (WhereisBaseDir, _) -> do - liftIO $ putStr baseDir + liftIO $ putStr $ fromGHCupPath baseDir pure ExitSuccess (WhereisBinDir, _) -> do @@ -307,13 +308,13 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do pure ExitSuccess (WhereisCacheDir, _) -> do - liftIO $ putStr cacheDir + liftIO $ putStr $ fromGHCupPath cacheDir pure ExitSuccess (WhereisLogsDir, _) -> do - liftIO $ putStr logsDir + liftIO $ putStr $ fromGHCupPath logsDir pure ExitSuccess (WhereisConfDir, _) -> do - liftIO $ putStr confDir + liftIO $ putStr $ fromGHCupPath confDir pure ExitSuccess diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 2dd0f6e..ee2cf08 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -22,9 +22,9 @@ import GHCup.Platform import GHCup.Types import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.Version import Cabal.Plan ( findPlanJson, SearchPlanJson(..) ) @@ -155,7 +155,6 @@ main = do versions. It maintains a self-contained ~/.ghcup directory. ENV variables: - * TMPDIR: where ghcup does the work (unpacking, building, ...) * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME) * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories @@ -220,7 +219,7 @@ Report bugs at |] let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig race_ (liftIO $ runReaderT cleanupTrash s') - (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually")) + (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack (fromGHCupPath recycleDir) <> " manually")) case optCommand of Nuke -> pure () diff --git a/cabal.project b/cabal.project index 8751e9c..3c3e419 100644 --- a/cabal.project +++ b/cabal.project @@ -31,4 +31,7 @@ package cabal-plan package aeson flags: +ordered-keymap +package streamly + flags: +use-unliftio + allow-newer: base, ghc-prim, template-haskell, language-c diff --git a/cbits/dirutils.c b/cbits/dirutils.c new file mode 100644 index 0000000..2ba92ab --- /dev/null +++ b/cbits/dirutils.c @@ -0,0 +1,7 @@ +#include "dirutils.h" + +unsigned int + __posixdir_d_type(struct dirent* d) + { + return(d -> d_type); + } diff --git a/cbits/dirutils.h b/cbits/dirutils.h new file mode 100644 index 0000000..e2d7498 --- /dev/null +++ b/cbits/dirutils.h @@ -0,0 +1,15 @@ +#ifndef POSIXPATHS_CBITS_DIRUTILS_H +#define POSIXPATHS_CBITS_DIRUTILS_H + +#include +#include +#include +#include +#include + + +extern unsigned int + __posixdir_d_type(struct dirent* d) + ; + +#endif diff --git a/docs/guide.md b/docs/guide.md index f5fba69..0b15fa5 100644 --- a/docs/guide.md +++ b/docs/guide.md @@ -76,7 +76,6 @@ Partial configuration is fine. Command line options always override the config f This is the complete list of env variables that change GHCup behavior: * `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above -* `TMPDIR`: where ghcup does the work (unpacking, building, ...) * `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`) * `GHCUP_CURL_OPTS`: additional options that can be passed to curl * `GHCUP_WGET_OPTS`: additional options that can be passed to wget diff --git a/ghcup.cabal b/ghcup.cabal index ddde39b..ee0f476 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup -version: 0.1.17.10 +version: 0.1.18.0 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020 @@ -44,31 +44,39 @@ flag internal-downloader manual: True flag no-exe - description: Don't build any executables + description: Don't build any executables default: False manual: True library exposed-modules: GHCup + GHCup.Cabal GHCup.Download GHCup.Download.Utils GHCup.Errors + GHCup.GHC + GHCup.HLS + GHCup.List GHCup.Platform + GHCup.Prelude + GHCup.Prelude.File + GHCup.Prelude.File.Search + GHCup.Prelude.Internal + GHCup.Prelude.Logger + GHCup.Prelude.Logger.Internal + GHCup.Prelude.MegaParsec + GHCup.Prelude.Process + GHCup.Prelude.String.QQ + GHCup.Prelude.Version.QQ GHCup.Requirements + GHCup.Stack GHCup.Types GHCup.Types.JSON GHCup.Types.JSON.Utils GHCup.Types.Optics GHCup.Utils GHCup.Utils.Dirs - GHCup.Utils.File - GHCup.Utils.File.Common - GHCup.Utils.Logger - GHCup.Utils.MegaParsec - GHCup.Utils.Prelude - GHCup.Utils.String.QQ - GHCup.Utils.Version.QQ GHCup.Version hs-source-dirs: lib @@ -109,6 +117,7 @@ library , deepseq ^>=1.4.4.0 , directory ^>=1.3.6.0 , disk-free-space ^>=0.1.0.1 + , exceptions ^>=0.10 , filepath ^>=1.4.2.1 , haskus-utils-types ^>=1.5 , haskus-utils-variant ^>=3.2.1 @@ -126,6 +135,7 @@ library , safe ^>=0.3.18 , safe-exceptions ^>=0.1 , split ^>=0.2.3.4 + , streamly ^>=0.8.2 , strict-base ^>=0.4 , template-haskell >=2.7 && <2.18 , temporary ^>=1.3 @@ -153,9 +163,9 @@ library if os(windows) cpp-options: -DIS_WINDOWS other-modules: - GHCup.Utils.File.Windows - GHCup.Utils.Prelude.Windows - GHCup.Utils.Windows + GHCup.Prelude.File.Windows + GHCup.Prelude.Process.Windows + GHCup.Prelude.Windows build-depends: , bzlib @@ -164,10 +174,13 @@ library else other-modules: - GHCup.Utils.File.Posix - GHCup.Utils.Posix - GHCup.Utils.Prelude.Posix + GHCup.Prelude.File.Posix + GHCup.Prelude.File.Posix.Foreign + GHCup.Prelude.File.Posix.Traversals + GHCup.Prelude.Posix + GHCup.Prelude.Process.Posix + c-sources: cbits/dirutils.c build-depends: , bz2 >=0.5.0.5 && <1.1 , terminal-size ^>=0.3.2.1 @@ -271,7 +284,6 @@ executable ghcup if flag(no-exe) buildable: False - test-suite ghcup-test type: exitcode-stdio-1.0 main-is: Main.hs @@ -280,6 +292,7 @@ test-suite ghcup-test other-modules: GHCup.ArbitraryTypes GHCup.Types.JSONSpec + GHCup.Utils.FileSpec Spec default-language: Haskell2010 @@ -299,12 +312,15 @@ test-suite ghcup-test , base >=4.12 && <5 , bytestring ^>=0.10 , containers ^>=0.6 + , directory ^>=1.3.6.0 + , filepath ^>=1.4.2.1 , generic-arbitrary >=0.1.0 && <0.3 , ghcup , hspec >=2.7.10 && <2.10 , hspec-golden-aeson ^>=0.9 , QuickCheck ^>=2.14.1 , quickcheck-arbitrary-adt ^>=0.3.1.0 + , streamly ^>=0.8.2 , text ^>=1.2.4.0 , uri-bytestring ^>=0.3.2.2 , versions >=4.0.1 && <5.1 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 68c50eb..ffeca3a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -6,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-| Module : GHCup @@ -23,9 +22,21 @@ and so on. These are the entry points. -} -module GHCup where +module GHCup ( + module GHCup, + module GHCup.Cabal, + module GHCup.GHC, + module GHCup.HLS, + module GHCup.Stack, + module GHCup.List +) where +import GHCup.Cabal +import GHCup.GHC +import GHCup.HLS +import GHCup.Stack +import GHCup.List import GHCup.Download import GHCup.Errors import GHCup.Platform @@ -33,17 +44,13 @@ import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ -import GHCup.Utils.Version.QQ +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.Version -import Codec.Archive ( ArchiveResult ) import Control.Applicative -import Control.DeepSeq ( force ) -import Control.Exception ( evaluate ) import Control.Exception.Safe import Control.Monad #if !MIN_VERSION_base(4,13,0) @@ -52,52 +59,26 @@ import Control.Monad.Fail ( MonadFail ) import Control.Monad.Reader import Control.Monad.Trans.Resource hiding ( throwM ) -import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Data.ByteString ( ByteString ) import Data.Either import Data.List import Data.Maybe -import Data.List.NonEmpty ( NonEmpty((:|)) ) -import Data.String ( fromString ) -import Data.Text ( Text ) -import Data.Time.Clock -import Data.Time.Format.ISO8601 import Data.Versions hiding ( patch ) -import Distribution.Types.Version hiding ( Version ) -import Distribution.Types.PackageId -import Distribution.Types.PackageDescription -import Distribution.Types.GenericPackageDescription -import Distribution.PackageDescription.Parsec import GHC.IO.Exception import Haskus.Utils.Variant.Excepts -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) ) import Optics import Prelude hiding ( abs , writeFile ) -import Safe hiding ( at ) -import System.Directory hiding ( findFiles ) import System.Environment import System.FilePath import System.IO.Error -import System.IO.Temp -import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix -import URI.ByteString -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.List.NonEmpty as NE -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map.Strict as Map import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Encoding as E -import qualified Text.Megaparsec as MP -import GHCup.Utils.MegaParsec -import Control.Concurrent (threadDelay) +import qualified Streamly.Prelude as S + + --------------------- @@ -134,1814 +115,14 @@ fetchToolBindist v t mfp = do liftE $ downloadCached' dlinfo Nothing mfp -fetchGHCSrc :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => Version - -> Maybe FilePath - -> Excepts - '[ DigestError - , GPGError - , DownloadFailed - , NoDownload - ] - m - FilePath -fetchGHCSrc v mfp = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - dlInfo <- - preview (ix GHC % ix v % viSourceDL % _Just) dls - ?? NoDownload - liftE $ downloadCached' dlInfo Nothing mfp + ------------ + --[ Nuke ]-- + ------------ - ------------------------- - --[ Tool installation ]-- - ------------------------- --- | Like 'installGHCBin', except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installGHCBindist :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => DownloadInfo -- ^ where/how to download - -> Version -- ^ the version to install - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , DirNotEmpty - , ArchiveResult - , ProcessError - ] - m - () -installGHCBindist dlinfo ver installDir forceInstall = do - let tver = mkTVer ver - - lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver - - regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver - - if - | not forceInstall - , regularGHCInstalled - , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled GHC ver - - | forceInstall - , regularGHCInstalled - , GHCupInternal <- installDir -> do - lift $ logInfo "Removing the currently installed GHC version first!" - liftE $ rmGHCVer tver - - | otherwise -> pure () - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - - toolchainSanityChecks - - case installDir of - IsolateDir isoDir -> do -- isolated install - lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall - GHCupInternal -> do -- regular install - -- prepare paths - ghcdir <- lift $ ghcupGHCDir tver - - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall - - -- make symlinks & stuff when regular install, - liftE $ postGHCInstall tver - - where - toolchainSanityChecks = do - r <- forM ["CC", "LD"] (liftIO . lookupEnv) - case catMaybes r of - [] -> pure () - _ -> do - lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker" - <> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda" - <> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall." - - --- | Install a packed GHC distribution. This only deals with unpacking and the GHC --- build system and nothing else. -installPackedGHC :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasPlatformReq env - , HasSettings env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => FilePath -- ^ Path to the packed GHC bindist - -> Maybe TarDir -- ^ Subdir of the archive - -> InstallDirResolved - -> Version -- ^ The GHC version - -> Bool -- ^ Force install - -> Excepts - '[ BuildFailed - , UnknownArchive - , TarDirDoesNotExist - , DirNotEmpty - , ArchiveResult - , ProcessError - ] m () -installPackedGHC dl msubdir inst ver forceInstall = do - PlatformRequest {..} <- lift getPlatformReq - - unless forceInstall - (liftE $ installDestSanityCheck inst) - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - msubdir - - liftE $ runBuildAction tmpUnpack - (case inst of - IsolateDirResolved _ -> Nothing -- don't clean up for isolated installs, since that'd potentially delete other - -- user files if '--force' is supplied - GHCupDir d -> Just d - ) - (installUnpackedGHC workdir inst ver) - - --- | Install an unpacked GHC distribution. This only deals with the GHC --- build system and nothing else. -installUnpackedGHC :: ( MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadUnliftIO m - , MonadMask m - ) - => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides) - -> InstallDirResolved -- ^ Path to install to - -> Version -- ^ The GHC version - -> Excepts '[ProcessError] m () -installUnpackedGHC path inst ver - | isWindows = do - lift $ logInfo "Installing GHC (this may take a while)" - -- Windows bindists are relocatable and don't need - -- to run configure. - -- We also must make sure to preserve mtime to not confuse ghc-pkg. - lift $ withRunInIO $ \run -> flip onException (case inst of - IsolateDirResolved _ -> pure () - GHCupDir d -> run $ recyclePathForcibly d - ) $ copyDirectoryRecursive path (fromInstallDir inst) $ \source dest -> do - mtime <- getModificationTime source - moveFilePortable source dest - setModificationTime dest mtime - | otherwise = do - PlatformRequest {..} <- lift getPlatformReq - - let alpineArgs - | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform - = ["--disable-ld-override"] - | otherwise - = [] - - lift $ logInfo "Installing GHC (this may take a while)" - lEM $ execLogged "sh" - ("./configure" : ("--prefix=" <> fromInstallDir inst) - : alpineArgs - ) - (Just path) - "ghc-configure" - Nothing - lEM $ make ["install"] (Just path) - pure () - - --- | Installs GHC into @~\/.ghcup\/ghc/\@ and places the --- following symlinks in @~\/.ghcup\/bin@: --- --- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@ --- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version) -installGHCBin :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => Version -- ^ the version to install - -> InstallDir - -> Bool -- ^ force install - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , DirNotEmpty - , ArchiveResult - , ProcessError - ] - m - () -installGHCBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo GHC ver - liftE $ installGHCBindist dlinfo ver installDir forceInstall - - --- | Like 'installCabalBin', except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installCabalBindist :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => DownloadInfo - -> Version - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installCabalBindist dlinfo ver installDir forceInstall = do - lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver - - PlatformRequest {..} <- lift getPlatformReq - Dirs {..} <- lift getDirs - - -- check if we already have a regular cabal already installed - regularCabalInstalled <- lift $ checkIfToolInstalled Cabal ver - - if - | not forceInstall - , regularCabalInstalled - , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled Cabal ver - - | forceInstall - , regularCabalInstalled - , GHCupInternal <- installDir -> do - lift $ logInfo "Removing the currently installed version first!" - liftE $ rmCabalVer ver - - | otherwise -> pure () - - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - case installDir of - IsolateDir isoDir -> do -- isolated install - lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir - liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - - GHCupInternal -> do -- regular install - liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall - - --- | Install an unpacked cabal distribution.Symbol -installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) - => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) - -> InstallDirResolved -- ^ Path to install to - -> Version - -> Bool -- ^ Force Install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installCabalUnpacked path inst ver forceInstall = do - lift $ logInfo "Installing cabal" - let cabalFile = "cabal" - liftIO $ createDirRecursive' (fromInstallDir inst) - let destFileName = cabalFile - <> (case inst of - IsolateDirResolved _ -> "" - GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - let destPath = fromInstallDir inst destFileName - - unless forceInstall -- Overwrite it when it IS a force install - (liftE $ throwIfFileAlreadyExists destPath) - - copyFileE - (path cabalFile <> exeExt) - destPath - lift $ chmod_755 destPath - --- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and --- creates a default @cabal -> cabal-x.y.z.q@ symlink for --- the latest installed version. -installCabalBin :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Version - -> InstallDir - -> Bool -- force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installCabalBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo Cabal ver - installCabalBindist dlinfo ver installDir forceInstall - - --- | Like 'installHLSBin, except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installHLSBindist :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => DownloadInfo - -> Version - -> InstallDir -- ^ isolated install path, if user passed any - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - , ProcessError - , DirNotEmpty - ] - m - () -installHLSBindist dlinfo ver installDir forceInstall = do - lift $ logDebug $ "Requested to install hls version " <> prettyVer ver - - PlatformRequest {..} <- lift getPlatformReq - Dirs {..} <- lift getDirs - - regularHLSInstalled <- lift $ checkIfToolInstalled HLS ver - - if - | not forceInstall - , regularHLSInstalled - , GHCupInternal <- installDir -> do -- regular install - throwE $ AlreadyInstalled HLS ver - - | forceInstall - , regularHLSInstalled - , GHCupInternal <- installDir -> do -- regular forced install - lift $ logInfo "Removing the currently installed version of HLS before force installing!" - liftE $ rmHLSVer ver - - | otherwise -> pure () - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - legacy <- liftIO $ isLegacyHLSBindist workdir - - if - | not forceInstall - , not legacy - , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp) - | otherwise -> pure () - - case installDir of - IsolateDir isoDir -> do - lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir - if legacy - then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall - else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver - - GHCupInternal -> do - if legacy - then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall - else do - inst <- ghcupHLSDir ver - liftE $ runBuildAction tmpUnpack (Just inst) - $ installHLSUnpacked workdir (GHCupDir inst) ver - liftE $ setHLS ver SetHLS_XYZ Nothing - - -isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist - -> IO Bool -isLegacyHLSBindist path = do - not <$> doesFileExist (path "GNUmakefile") - --- | Install an unpacked hls distribution. -installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> InstallDirResolved -- ^ Path to install to - -> Version - -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m () -installHLSUnpacked path (fromInstallDir -> inst) _ = do - lift $ logInfo "Installing HLS" - liftIO $ createDirRecursive' inst - lEM $ make ["PREFIX=" <> inst, "install"] (Just path) - --- | Install an unpacked hls distribution (legacy). -installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> InstallDirResolved -- ^ Path to install to - -> Version - -> Bool -- ^ is it a force install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installHLSUnpackedLegacy path installDir ver forceInstall = do - lift $ logInfo "Installing HLS" - liftIO $ createDirRecursive' (fromInstallDir installDir) - - -- install haskell-language-server- - bins@(_:_) <- liftIO $ findFiles - path - (makeRegexOpts compExtended - execBlank - ([s|^haskell-language-server-[0-9].*$|] :: ByteString) - ) - forM_ bins $ \f -> do - let toF = dropSuffix exeExt f - <> (case installDir of - IsolateDirResolved _ -> "" - GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - - let srcPath = path f - let destPath = fromInstallDir installDir toF - - unless forceInstall -- if it is a force install, overwrite it. - (liftE $ throwIfFileAlreadyExists destPath) - - copyFileE - srcPath - destPath - lift $ chmod_755 destPath - - -- install haskell-language-server-wrapper - let wrapper = "haskell-language-server-wrapper" - toF = wrapper - <> (case installDir of - IsolateDirResolved _ -> "" - GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - srcWrapperPath = path wrapper <> exeExt - destWrapperPath = fromInstallDir installDir toF - - unless forceInstall - (liftE $ throwIfFileAlreadyExists destWrapperPath) - - copyFileE - srcWrapperPath - destWrapperPath - - lift $ chmod_755 destWrapperPath - - - --- | Installs hls binaries @haskell-language-server-\@ --- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. -installHLSBin :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Version - -> InstallDir - -> Bool -- force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - , ProcessError - , DirNotEmpty - ] - m - () -installHLSBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo HLS ver - installHLSBindist dlinfo ver installDir forceInstall - - -compileHLS :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Either Version GitBranch - -> [Version] - -> Maybe Int - -> Maybe Version - -> InstallDir - -> Maybe (Either FilePath URI) - -> Maybe URI - -> Maybe (Either FilePath [URI]) -- ^ patches - -> [Text] -- ^ additional args to cabal install - -> Excepts '[ NoDownload - , GPGError - , DownloadFailed - , DigestError - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , BuildFailed - , NotInstalled - ] m Version -compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do - PlatformRequest { .. } <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - Dirs { .. } <- lift getDirs - - - (workdir, tver) <- case targetHLS of - -- unpack from version tarball - Left tver -> do - lift $ logDebug $ "Requested to compile: " <> prettyVer tver - - -- download source tarball - dlInfo <- - preview (ix HLS % ix tver % viSourceDL % _Just) dls - ?? NoDownload - dl <- liftE $ downloadCached dlInfo Nothing - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack - - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - (view dlSubdir dlInfo) - - pure (workdir, tver) - - -- clone from git - Right GitBranch{..} -> do - tmpUnpack <- lift mkGhcupTmpDir - let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing - tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do - let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo - lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" - lEM $ git [ "init" ] - lEM $ git [ "remote" - , "add" - , "origin" - , fromString rep ] - - let fetch_args = - [ "fetch" - , "--depth" - , "1" - , "--quiet" - , "origin" - , fromString ref ] - lEM $ git fetch_args - - lEM $ git [ "checkout", "FETCH_HEAD" ] - (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (tmpUnpack "haskell-language-server.cabal")) - pure . (\c -> Version Nothing c [] Nothing) - . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral) - . versionNumbers - . pkgVersion - . package - . packageDescription - $ gpd - - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack - lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver - - pure (tmpUnpack, tver) - - -- the version that's installed may differ from the - -- compiled version, so the user can overwrite it - let installVer = fromMaybe tver ov - - liftE $ runBuildAction - workdir - Nothing - (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do - let tmpInstallDir = workdir "out" - liftIO $ createDirRecursive' tmpInstallDir - - -- apply patches - liftE $ applyAnyPatch patches workdir - - -- set up project files - cp <- case cabalProject of - Just (Left cp) - | isAbsolute cp -> do - copyFileE cp (workdir "cabal.project") - pure "cabal.project" - | otherwise -> pure (takeFileName cp) - Just (Right uri) -> do - tmpUnpack <- lift withGHCupTmpDir - cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False - copyFileE cp (workdir "cabal.project") - pure "cabal.project" - Nothing -> pure "cabal.project" - forM_ cabalProjectLocal $ \uri -> do - tmpUnpack <- lift withGHCupTmpDir - cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False - copyFileE cpl (workdir cp <.> "local") - artifacts <- forM (sort ghcs) $ \ghc -> do - let ghcInstallDir = tmpInstallDir T.unpack (prettyVer ghc) - liftIO $ createDirRecursive' tmpInstallDir - lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc - liftE $ lEM @_ @'[ProcessError] $ - execLogged "cabal" ( [ "v2-install" - , "-w" - , "ghc-" <> T.unpack (prettyVer ghc) - , "--install-method=copy" - ] ++ - maybe [] (\j -> ["--jobs=" <> show j]) jobs ++ - [ "--overwrite-policy=always" - , "--disable-profiling" - , "--disable-tests" - , "--installdir=" <> ghcInstallDir - , "--project-file=" <> cp - ] ++ fmap T.unpack cabalArgs ++ [ - "exe:haskell-language-server" - , "exe:haskell-language-server-wrapper"] - ) - (Just workdir) "cabal" Nothing - pure ghcInstallDir - - forM_ artifacts $ \artifact -> do - liftIO $ renameFile (artifact "haskell-language-server" <.> exeExt) - (tmpInstallDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) - liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) - (tmpInstallDir "haskell-language-server-wrapper" <.> exeExt) - liftIO $ rmPathForcibly artifact - - case installDir of - IsolateDir isoDir -> do - lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir - liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True - GHCupInternal -> do - liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True - ) - - pure installVer - - - --- | Installs stack into @~\/.ghcup\/bin/stack-\@ and --- creates a default @stack -> stack-x.y.z.q@ symlink for --- the latest installed version. -installStackBin :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Version - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installStackBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo Stack ver - installStackBindist dlinfo ver installDir forceInstall - - --- | Like 'installStackBin', except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installStackBindist :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => DownloadInfo - -> Version - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installStackBindist dlinfo ver installDir forceInstall = do - lift $ logDebug $ "Requested to install stack version " <> prettyVer ver - - PlatformRequest {..} <- lift getPlatformReq - Dirs {..} <- lift getDirs - - regularStackInstalled <- lift $ checkIfToolInstalled Stack ver - - if - | not forceInstall - , regularStackInstalled - , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled Stack ver - - | forceInstall - , regularStackInstalled - , GHCupInternal <- installDir -> do - lift $ logInfo "Removing the currently installed version of Stack first!" - liftE $ rmStackVer ver - - | otherwise -> pure () - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - case installDir of - IsolateDir isoDir -> do -- isolated install - lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir - liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - GHCupInternal -> do -- regular install - liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall - - --- | Install an unpacked stack distribution. -installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) - -> InstallDirResolved - -> Version - -> Bool -- ^ Force install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installStackUnpacked path installDir ver forceInstall = do - lift $ logInfo "Installing stack" - let stackFile = "stack" - liftIO $ createDirRecursive' (fromInstallDir installDir) - let destFileName = stackFile - <> (case installDir of - IsolateDirResolved _ -> "" - GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - destPath = fromInstallDir installDir destFileName - - unless forceInstall - (liftE $ throwIfFileAlreadyExists destPath) - - copyFileE - (path stackFile <> exeExt) - destPath - lift $ chmod_755 destPath - - - --------------------- - --[ Set GHC/cabal ]-- - --------------------- - - - --- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends --- on `SetGHC`: --- --- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ --- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ --- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\ -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ --- --- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ --- for 'SetGHCOnly' constructor. -setGHC :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadCatch m - , MonadMask m - , MonadUnliftIO m - ) - => GHCTargetVersion - -> SetGHC - -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin - -- and don't want mess with other versions - -> Excepts '[NotInstalled] m GHCTargetVersion -setGHC ver sghc mBinDir = do - let verS = T.unpack $ prettyVer (_tvVersion ver) - ghcdir <- lift $ ghcupGHCDir ver - - whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) - - -- symlink destination - binDir <- case mBinDir of - Just x -> pure x - Nothing -> do - Dirs {binDir = f} <- lift getDirs - pure f - - -- first delete the old symlinks (this fixes compatibility issues - -- with old ghcup) - when (isNothing mBinDir) $ - case sghc of - SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver) - SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver - SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver - - -- for ghc tools (ghc, ghci, haddock, ...) - verfiles <- ghcToolFiles ver - forM_ verfiles $ \file -> do - mTargetFile <- case sghc of - SetGHCOnly -> pure $ Just file - SetGHC_XY -> do - handle - (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ do - (mj, mi) <- getMajorMinorV (_tvVersion ver) - let major' = intToText mj <> "." <> intToText mi - pure $ Just (file <> "-" <> T.unpack major') - SetGHC_XYZ -> - pure $ Just (file <> "-" <> verS) - - -- create symlink - forM_ mTargetFile $ \targetFile -> do - bindir <- ghcInternalBinDir ver - let fullF = binDir targetFile <> exeExt - fileWithExt = bindir file <> exeExt - destL <- binarySymLinkDestination binDir fileWithExt - lift $ createLink destL fullF - - when (isNothing mBinDir) $ do - -- create symlink for share dir - when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS - - when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility - - pure ver - - where - - symlinkShareDir :: ( MonadReader env m - , HasDirs env - , MonadIO m - , HasLog env - , MonadCatch m - , MonadMask m - ) - => FilePath - -> String - -> m () - symlinkShareDir ghcdir ver' = do - Dirs {..} <- getDirs - let destdir = baseDir - case sghc of - SetGHCOnly -> do - let sharedir = "share" - let fullsharedir = ghcdir sharedir - logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir - whenM (liftIO $ doesDirectoryExist fullsharedir) $ do - let fullF = destdir sharedir - let targetF = "." "ghc" ver' sharedir - logDebug $ "rm -f " <> T.pack fullF - hideError doesNotExistErrorType $ rmDirectoryLink fullF - logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF - - if isWindows - then liftIO - -- On windows we need to be more permissive - -- in case symlinks can't be created, be just - -- give up here. This symlink isn't strictly necessary. - $ hideError permissionErrorType - $ hideError illegalOperationErrorType - $ createDirectoryLink targetF fullF - else liftIO - $ createDirectoryLink targetF fullF - _ -> pure () - -unsetGHC :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadMask m - ) - => Maybe Text - -> Excepts '[NotInstalled] m () -unsetGHC = rmPlainGHC - - --- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -setCabal :: ( MonadMask m - , MonadReader env m - , HasDirs env - , HasLog env - , MonadFail m - , MonadIO m - , MonadUnliftIO m) - => Version - -> Excepts '[NotInstalled] m () -setCabal ver = do - let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt - - -- symlink destination - Dirs {..} <- lift getDirs - - whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) - $ throwE - $ NotInstalled Cabal (GHCTargetVersion Nothing ver) - - let cabalbin = binDir "cabal" <> exeExt - - -- create link - let destL = targetFile - lift $ createLink destL cabalbin - - pure () - -unsetCabal :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadIO m) - => m () -unsetCabal = do - Dirs {..} <- getDirs - let cabalbin = binDir "cabal" <> exeExt - hideError doesNotExistErrorType $ rmLink cabalbin - - --- | Set the haskell-language-server symlinks. -setHLS :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadIO m - , MonadMask m - , MonadFail m - , MonadUnliftIO m - ) - => Version - -> SetHLS - -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin - -- and don't want mess with other versions - -> Excepts '[NotInstalled] m () -setHLS ver shls mBinDir = do - whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))) - - -- symlink destination - binDir <- case mBinDir of - Just x -> pure x - Nothing -> do - Dirs {binDir = f} <- lift getDirs - pure f - - -- first delete the old symlinks - when (isNothing mBinDir) $ - case shls of - -- not for legacy - SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver - -- legacy and new - SetHLSOnly -> liftE rmPlainHLS - - case shls of - -- not for legacy - SetHLS_XYZ -> do - bins <- lift $ hlsInternalServerScripts ver Nothing - - forM_ bins $ \f -> do - let fname = takeFileName f - destL <- binarySymLinkDestination binDir f - let target = if "haskell-language-server-wrapper" `isPrefixOf` fname - then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt - else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt - lift $ createLink destL (binDir target) - - -- legacy and new - SetHLSOnly -> do - -- set haskell-language-server- symlinks - bins <- lift $ hlsServerBinaries ver Nothing - when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) - - forM_ bins $ \f -> do - let destL = f - let target = (<> exeExt) . head . splitOn "~" $ f - lift $ createLink destL (binDir target) - - -- set haskell-language-server-wrapper symlink - let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt - let wrapper = binDir "haskell-language-server-wrapper" <> exeExt - - lift $ createLink destL wrapper - - when (isNothing mBinDir) $ - lift warnAboutHlsCompatibility - - -unsetHLS :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadIO m) - => m () -unsetHLS = do - Dirs {..} <- getDirs - let wrapper = binDir "haskell-language-server-wrapper" <> exeExt - bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles' - binDir - (MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof) - forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir )) - hideError doesNotExistErrorType $ rmLink wrapper - - --- | Set the @~\/.ghcup\/bin\/stack@ symlink. -setStack :: ( MonadMask m - , MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -setStack ver = do - let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt - - -- symlink destination - Dirs {..} <- lift getDirs - - whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) - $ throwE - $ NotInstalled Stack (GHCTargetVersion Nothing ver) - - let stackbin = binDir "stack" <> exeExt - - lift $ createLink targetFile stackbin - - pure () - - -unsetStack :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadIO m) - => m () -unsetStack = do - Dirs {..} <- getDirs - let stackbin = binDir "stack" <> exeExt - hideError doesNotExistErrorType $ rmLink stackbin - - --- | Warn if the installed and set HLS is not compatible with the installed and --- set GHC version. -warnAboutHlsCompatibility :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadCatch m - , MonadIO m - ) - => m () -warnAboutHlsCompatibility = do - supportedGHC <- hlsGHCVersions - currentGHC <- fmap _tvVersion <$> ghcSet Nothing - currentHLS <- hlsSet - - case (currentGHC, currentHLS) of - (Just gv, Just hv) | gv `notElem` supportedGHC -> do - logWarn $ - "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <> - "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <> - "Haskell IDE support may not work until this is fixed." <> "\n" <> - "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <> - T.pack (prettyShow supportedGHC) - - _ -> return () - - ------------------ - --[ List tools ]-- - ------------------ - - --- | Filter data type for 'listVersions'. -data ListCriteria = ListInstalled - | ListSet - | ListAvailable - deriving Show - --- | A list result describes a single tool version --- and various of its properties. -data ListResult = ListResult - { lTool :: Tool - , lVer :: Version - , lCross :: Maybe Text -- ^ currently only for GHC - , lTag :: [Tag] - , lInstalled :: Bool - , lSet :: Bool -- ^ currently active version - , fromSrc :: Bool -- ^ compiled from source - , lStray :: Bool -- ^ not in download info - , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch - , hlsPowered :: Bool - } - deriving (Eq, Ord, Show) - - --- | Extract all available tool versions and their tags. -availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo -availableToolVersions av tool = view - (at tool % non Map.empty) - av - - --- | List all versions from the download info, as well as stray --- versions. -listVersions :: ( MonadCatch m - , HasLog env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadReader env m - , HasDirs env - , HasPlatformReq env - , HasGHCupInfo env - ) - => Maybe Tool - -> Maybe ListCriteria - -> m [ListResult] -listVersions lt' criteria = do - -- some annoying work to avoid too much repeated IO - cSet <- cabalSet - cabals <- getInstalledCabals - hlsSet' <- hlsSet - hlses <- getInstalledHLSs - sSet <- stackSet - stacks <- getInstalledStacks - - go lt' cSet cabals hlsSet' hlses sSet stacks - where - go lt cSet cabals hlsSet' hlses sSet stacks = do - case lt of - Just t -> do - GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo - -- get versions from GHCupDownloads - let avTools = availableToolVersions dls t - lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) - - case t of - GHC -> do - slr <- strayGHCs avTools - pure (sort (slr ++ lr)) - Cabal -> do - slr <- strayCabals avTools cSet cabals - pure (sort (slr ++ lr)) - HLS -> do - slr <- strayHLS avTools hlsSet' hlses - pure (sort (slr ++ lr)) - Stack -> do - slr <- strayStacks avTools sSet stacks - pure (sort (slr ++ lr)) - GHCup -> do - let cg = maybeToList $ currentGHCup avTools - pure (sort (cg ++ lr)) - Nothing -> do - ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks - cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks - hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks - ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks - stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks - pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) - strayGHCs :: ( MonadCatch m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - ) - => Map.Map Version VersionInfo - -> m [ListResult] - strayGHCs avTools = do - ghcs <- getInstalledGHCs - fmap catMaybes $ forM ghcs $ \case - Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do - case Map.lookup _tvVersion avTools of - Just _ -> pure Nothing - Nothing -> do - lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions - pure $ Just $ ListResult - { lTool = GHC - , lVer = _tvVersion - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup _tvVersion avTools) - , lNoBindist = False - , .. - } - Right tver@GHCTargetVersion{ .. } -> do - lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions - pure $ Just $ ListResult - { lTool = GHC - , lVer = _tvVersion - , lCross = _tvTarget - , lTag = [] - , lInstalled = True - , lStray = True -- NOTE: cross currently cannot be installed via bindist - , lNoBindist = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - strayCabals :: ( MonadReader env m - , HasDirs env - , MonadCatch m - , MonadThrow m - , HasLog env - , MonadIO m - ) - => Map.Map Version VersionInfo - -> Maybe Version - -> [Either FilePath Version] - -> m [ListResult] - strayCabals avTools cSet cabals = do - fmap catMaybes $ forM cabals $ \case - Right ver -> - case Map.lookup ver avTools of - Just _ -> pure Nothing - Nothing -> do - let lSet = cSet == Just ver - pure $ Just $ ListResult - { lTool = Cabal - , lVer = ver - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup ver avTools) - , lNoBindist = False - , fromSrc = False -- actually, we don't know :> - , hlsPowered = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - strayHLS :: ( MonadReader env m - , HasDirs env - , MonadCatch m - , MonadThrow m - , HasLog env - , MonadIO m) - => Map.Map Version VersionInfo - -> Maybe Version - -> [Either FilePath Version] - -> m [ListResult] - strayHLS avTools hlsSet' hlss = do - fmap catMaybes $ forM hlss $ \case - Right ver -> - case Map.lookup ver avTools of - Just _ -> pure Nothing - Nothing -> do - let lSet = hlsSet' == Just ver - pure $ Just $ ListResult - { lTool = HLS - , lVer = ver - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup ver avTools) - , lNoBindist = False - , fromSrc = False -- actually, we don't know :> - , hlsPowered = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - strayStacks :: ( MonadReader env m - , HasDirs env - , MonadCatch m - , MonadThrow m - , HasLog env - , MonadIO m - ) - => Map.Map Version VersionInfo - -> Maybe Version - -> [Either FilePath Version] - -> m [ListResult] - strayStacks avTools stackSet' stacks = do - fmap catMaybes $ forM stacks $ \case - Right ver -> - case Map.lookup ver avTools of - Just _ -> pure Nothing - Nothing -> do - let lSet = stackSet' == Just ver - pure $ Just $ ListResult - { lTool = Stack - , lVer = ver - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup ver avTools) - , lNoBindist = False - , fromSrc = False -- actually, we don't know :> - , hlsPowered = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult - currentGHCup av = - let currentVer = fromJust $ pvpToVersion ghcUpVer "" - listVer = Map.lookup currentVer av - latestVer = fst <$> headOf (getTagged Latest) av - recommendedVer = fst <$> headOf (getTagged Latest) av - isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer - in if | Map.member currentVer av -> Nothing - | otherwise -> Just $ ListResult { lVer = currentVer - , lTag = maybe (if isOld then [Old] else []) _viTags listVer - , lCross = Nothing - , lTool = GHCup - , fromSrc = False - , lStray = isNothing listVer - , lSet = True - , lInstalled = True - , lNoBindist = False - , hlsPowered = False - } - - -- NOTE: this are not cross ones, because no bindists - toListResult :: ( HasLog env - , MonadReader env m - , HasDirs env - , HasGHCupInfo env - , HasPlatformReq env - , MonadIO m - , MonadCatch m - ) - => Tool - -> Maybe Version - -> [Either FilePath Version] - -> Maybe Version - -> [Either FilePath Version] - -> Maybe Version - -> [Either FilePath Version] - -> (Version, VersionInfo) - -> m ListResult - toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do - case t of - GHC -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v - let tver = mkTVer v - lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing - lInstalled <- ghcInstalled tver - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem v) hlsGHCVersions - pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } - Cabal -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v - let lSet = cSet == Just v - let lInstalled = elem v $ rights cabals - pure ListResult { lVer = v - , lCross = Nothing - , lTag = tags - , lTool = t - , fromSrc = False - , lStray = False - , hlsPowered = False - , .. - } - GHCup -> do - let lSet = prettyPVP ghcUpVer == prettyVer v - let lInstalled = lSet - pure ListResult { lVer = v - , lTag = tags - , lCross = Nothing - , lTool = t - , fromSrc = False - , lStray = False - , lNoBindist = False - , hlsPowered = False - , .. - } - HLS -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v - let lSet = hlsSet' == Just v - let lInstalled = elem v $ rights hlses - pure ListResult { lVer = v - , lCross = Nothing - , lTag = tags - , lTool = t - , fromSrc = False - , lStray = False - , hlsPowered = False - , .. - } - Stack -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v - let lSet = stackSet' == Just v - let lInstalled = elem v $ rights stacks - pure ListResult { lVer = v - , lCross = Nothing - , lTag = tags - , lTool = t - , fromSrc = False - , lStray = False - , hlsPowered = False - , .. - } - - - filter' :: [ListResult] -> [ListResult] - filter' lr = case criteria of - Nothing -> lr - Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr - Just ListSet -> filter (\ListResult {..} -> lSet) lr - Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr - - - - -------------------- - --[ GHC/cabal rm ]-- - -------------------- - - --- | Delete a ghc version and all its symlinks. --- --- This may leave GHCup without a "set" version. --- Will try to fix the ghc-x.y symlink after removal (e.g. to an --- older version). -rmGHCVer :: ( MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadMask m - , MonadUnliftIO m - ) - => GHCTargetVersion - -> Excepts '[NotInstalled] m () -rmGHCVer ver = do - isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver) - - whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) - dir <- lift $ ghcupGHCDir ver - - -- this isn't atomic, order matters - when isSetGHC $ do - lift $ logInfo "Removing ghc symlinks" - liftE $ rmPlainGHC (_tvTarget ver) - - lift $ logInfo "Removing ghc-x.y.z symlinks" - liftE $ rmMinorGHCSymlinks ver - - lift $ logInfo "Removing/rewiring ghc-x.y symlinks" - -- first remove - handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver - -- then fix them (e.g. with an earlier version) - - lift $ logInfo $ "Removing directory recursively: " <> T.pack dir - lift $ recyclePathForcibly dir - - v' <- - handle - (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ fmap Just - $ getMajorMinorV (_tvVersion ver) - forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver)) - >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) - - Dirs {..} <- lift getDirs - - lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir "share") - - --- | Delete a cabal version. Will try to fix the @cabal@ symlink --- after removal (e.g. setting it to an older version). -rmCabalVer :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -rmCabalVer ver = do - whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver)) - - cSet <- lift cabalSet - - Dirs {..} <- lift getDirs - - let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt - lift $ hideError doesNotExistErrorType $ recycleFile (binDir cabalFile) - - when (Just ver == cSet) $ do - cVers <- lift $ fmap rights getInstalledCabals - case headMay . reverse . sort $ cVers of - Just latestver -> setCabal latestver - Nothing -> lift $ rmLink (binDir "cabal" <> exeExt) - - --- | Delete a hls version. Will try to fix the hls symlinks --- after removal (e.g. setting it to an older version). -rmHLSVer :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -rmHLSVer ver = do - whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) - - isHlsSet <- lift hlsSet - - liftE $ rmMinorHLSSymlinks ver - hlsDir <- ghcupHLSDir ver - recyclePathForcibly hlsDir - - when (Just ver == isHlsSet) $ do - -- delete all set symlinks - rmPlainHLS - -- set latest hls - hlsVers <- lift $ fmap rights getInstalledHLSs - case headMay . reverse . sort $ hlsVers of - Just latestver -> setHLS latestver SetHLSOnly Nothing - Nothing -> pure () - - --- | Delete a stack version. Will try to fix the @stack@ symlink --- after removal (e.g. setting it to an older version). -rmStackVer :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -rmStackVer ver = do - whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver)) - - sSet <- lift stackSet - - Dirs {..} <- lift getDirs - - let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt - lift $ hideError doesNotExistErrorType $ recycleFile (binDir stackFile) - - when (Just ver == sSet) $ do - sVers <- lift $ fmap rights getInstalledStacks - case headMay . reverse . sort $ sVers of - Just latestver -> setStack latestver - Nothing -> lift $ rmLink (binDir "stack" <> exeExt) - - --- assuming the current scheme of having just 1 ghcup bin, no version info is required. -rmGhcup :: ( MonadReader env m - , HasDirs env - , MonadIO m - , MonadCatch m - , HasLog env - , MonadMask m - , MonadUnliftIO m - ) - => m () -rmGhcup = do - Dirs { .. } <- getDirs - let ghcupFilename = "ghcup" <> exeExt - let ghcupFilepath = binDir ghcupFilename - - currentRunningExecPath <- liftIO getExecutablePath - - -- if paths do no exist, warn user, and continue to compare them, as is, - -- which should eventually fail and result in a non-standard install warning - - p1 <- handleIO' doesNotExistErrorType - (handlePathNotPresent currentRunningExecPath) - (liftIO $ canonicalizePath currentRunningExecPath) - - p2 <- handleIO' doesNotExistErrorType - (handlePathNotPresent ghcupFilepath) - (liftIO $ canonicalizePath ghcupFilepath) - - let areEqualPaths = equalFilePath p1 p2 - - unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath - - if isWindows - then do - -- since it doesn't seem possible to delete a running exe on windows - -- we move it to temp dir, to be deleted at next reboot - tempFilepath <- mkGhcupTmpDir - hideError UnsupportedOperation $ - liftIO $ hideError NoSuchThing $ - moveFile ghcupFilepath (tempFilepath "ghcup") - else - -- delete it. - hideError doesNotExistErrorType $ rmFile ghcupFilepath - - where - handlePathNotPresent fp _err = do - logDebug $ "Error: The path does not exist, " <> T.pack fp - pure fp - - nonStandardInstallLocationMsg path = T.pack $ - "current ghcup is invoked from a non-standard location: \n" - <> path <> - "\n you may have to uninstall it manually." - rmTool :: ( MonadReader env m , HasDirs env , HasLog env @@ -1949,15 +130,15 @@ rmTool :: ( MonadReader env m , MonadMask m , MonadUnliftIO m) => ListResult - -> Excepts '[NotInstalled ] m () + -> Excepts '[NotInstalled, UninstallFailed] m () rmTool ListResult {lVer, lTool, lCross} = do case lTool of GHC -> let ghcTargetVersion = GHCTargetVersion lCross lVer in rmGHCVer ghcTargetVersion HLS -> rmHLSVer lVer - Cabal -> rmCabalVer lVer - Stack -> rmStackVer lVer + Cabal -> liftE $ rmCabalVer lVer + Stack -> liftE $ rmStackVer lVer GHCup -> lift rmGhcup @@ -1975,9 +156,11 @@ rmGhcupDirs = do , logsDir , cacheDir , recycleDir + , dbDir + , tmpDir } <- getDirs - let envFilePath = baseDir "env" + let envFilePath = fromGHCupPath baseDir "env" confFilePath <- getConfigFilePath @@ -1985,20 +168,22 @@ rmGhcupDirs = do handleRm $ rmConfFile confFilePath -- for xdg dirs, the order matters here - handleRm $ rmDir logsDir - handleRm $ rmDir cacheDir + handleRm $ rmPathForcibly logsDir + handleRm $ rmPathForcibly tmpDir + handleRm $ rmPathForcibly cacheDir handleRm $ rmBinDir binDir - handleRm $ rmDir recycleDir + handleRm $ rmPathForcibly recycleDir + handleRm $ rmPathForcibly dbDir when isWindows $ do - logInfo $ "removing " <> T.pack (baseDir "msys64") - handleRm $ rmPathForcibly (baseDir "msys64") + logInfo $ "removing " <> T.pack (fromGHCupPath baseDir "msys64") + handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64") - handleRm $ removeEmptyDirsRecursive baseDir + handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir) -- report files in baseDir that are left-over after -- the standard location deletions above - hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir + hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles (fromGHCupPath baseDir) where handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m () @@ -2008,22 +193,12 @@ rmGhcupDirs = do rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmEnvFile enFilePath = do logInfo "Removing Ghcup Environment File" - hideErrorDef [permissionErrorType] () $ deleteFile enFilePath + hideErrorDef [permissionErrorType] () $ rmFileForce enFilePath rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmConfFile confFilePath = do logInfo "removing Ghcup Config File" - hideErrorDef [permissionErrorType] () $ deleteFile confFilePath - - rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () - rmDir dir = - -- 'getDirectoryContentsRecursive' is lazy IO. In case - -- an error leaks through, we catch it here as well, - -- althought 'deleteFile' should already handle it. - hideErrorDef [doesNotExistErrorType] () $ do - logInfo $ "removing " <> T.pack dir - contents <- liftIO $ getDirectoryContentsRecursive dir - forM_ contents (deleteFile . (dir )) + hideErrorDef [permissionErrorType] () $ rmFileForce confFilePath rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmBinDir binDir @@ -2034,11 +209,9 @@ rmGhcupDirs = do then removeDirIfEmptyOrIsSymlink binDir else pure () - reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath] + reportRemainingFiles :: (MonadMask m, MonadIO m) => FilePath -> m [FilePath] reportRemainingFiles dir = do - -- force the files so the errors don't leak - (force -> !remainingFiles) <- liftIO - (getDirectoryContentsRecursive dir >>= evaluate) + remainingFiles <- liftIO $ S.toList (getDirectoryContentsRecursiveUnsafe dir) let normalizedFilePaths = fmap normalise remainingFiles let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths let remainingFilesAbsolute = fmap (dir ) sortedByDepthRemainingFiles @@ -2052,34 +225,6 @@ rmGhcupDirs = do compareFn :: FilePath -> FilePath -> Ordering compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2) - removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () - removeEmptyDirsRecursive fp = do - cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp ) - forM_ cs removeEmptyDirsRecursive - hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp - - - -- we expect only files inside cache/log dir - -- we report remaining files/dirs later, - -- hence the force/quiet mode in these delete functions below. - - deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m () - deleteFile filepath = do - hideError doesNotExistErrorType - $ hideError InappropriateType $ rmFile filepath - - removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () - removeDirIfEmptyOrIsSymlink filepath = - hideError UnsatisfiedConstraints $ - handleIO' InappropriateType - (handleIfSym filepath) - (liftIO $ rmDirectory filepath) - where - handleIfSym fp e = do - isSym <- liftIO $ pathIsSymbolicLink fp - if isSym - then deleteFile fp - else liftIO $ ioError e @@ -2102,10 +247,10 @@ getDebugInfo :: ( Alternative m DebugInfo getDebugInfo = do Dirs {..} <- lift getDirs - let diBaseDir = baseDir + let diBaseDir = fromGHCupPath baseDir let diBinDir = binDir - diGHCDir <- lift ghcupGHCBaseDir - let diCacheDir = cacheDir + diGHCDir <- fromGHCupPath <$> lift ghcupGHCBaseDir + let diCacheDir = fromGHCupPath cacheDir diArch <- lE getArchitecture diPlatform <- liftE getPlatform pure $ DebugInfo { .. } @@ -2113,480 +258,9 @@ getDebugInfo = do - --------------- - --[ Compile ]-- - --------------- - - --- | Compile a GHC from source. This behaves wrt symlinks and installation --- the same as 'installGHCBin'. -compileGHC :: ( MonadMask m - , MonadReader env m - , HasDirs env - , HasPlatformReq env - , HasGHCupInfo env - , HasSettings env - , MonadThrow m - , MonadResource m - , HasLog env - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Either GHCTargetVersion GitBranch -- ^ version to install - -> Maybe Version -- ^ overwrite version - -> Either Version FilePath -- ^ version to bootstrap with - -> Maybe Int -- ^ jobs - -> Maybe FilePath -- ^ build config - -> Maybe (Either FilePath [URI]) -- ^ patches - -> [Text] -- ^ additional args to ./configure - -> Maybe String -- ^ build flavour - -> Bool - -> InstallDir - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , GHCupSetError - , NoDownload - , NotFoundInPATH - , PatchFailed - , UnknownArchive - , TarDirDoesNotExist - , NotInstalled - , DirNotEmpty - , ArchiveResult - , FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , ProcessError - , CopyError - , BuildFailed - ] - m - GHCTargetVersion -compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir - = do - PlatformRequest { .. } <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - - (workdir, tmpUnpack, tver) <- case targetGhc of - -- unpack from version tarball - Left tver -> do - lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap - - -- download source tarball - dlInfo <- - preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls - ?? NoDownload - dl <- liftE $ downloadCached dlInfo Nothing - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack - - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - (view dlSubdir dlInfo) - liftE $ applyAnyPatch patches workdir - - pure (workdir, tmpUnpack, tver) - - -- clone from git - Right GitBranch{..} -> do - tmpUnpack <- lift mkGhcupTmpDir - let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing - tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do - let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo - lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" - lEM $ git [ "init" ] - lEM $ git [ "remote" - , "add" - , "origin" - , fromString rep ] - - let fetch_args = - [ "fetch" - , "--depth" - , "1" - , "--quiet" - , "origin" - , fromString ref ] - lEM $ git fetch_args - - lEM $ git [ "checkout", "FETCH_HEAD" ] - lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] - liftE $ applyAnyPatch patches tmpUnpack - lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" - lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" - CapturedProcess {..} <- lift $ makeOut - ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack) - case _exitCode of - ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut - ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) - - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack - lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver - - pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) - -- the version that's installed may differ from the - -- compiled version, so the user can overwrite it - let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov - - alreadyInstalled <- lift $ ghcInstalled installVer - alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) - - when alreadyInstalled $ do - case installDir of - IsolateDir isoDir -> - lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir - GHCupInternal -> - lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version." - lift $ logWarn - "...waiting for 10 seconds before continuing, you can still abort..." - liftIO $ threadDelay 10000000 -- give the user a sec to intervene - - ghcdir <- case installDir of - IsolateDir isoDir -> pure $ IsolateDirResolved isoDir - GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) - - (mBindist, bmk) <- liftE $ runBuildAction - tmpUnpack - Nothing - (do - b <- if hadrian - then compileHadrianBindist tver workdir ghcdir - else compileMakeBindist tver workdir ghcdir - bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir) - pure (b, bmk) - ) - - case installDir of - GHCupInternal -> - -- only remove old ghc in regular installs - when alreadyInstalled $ do - lift $ logInfo "Deleting existing installation" - liftE $ rmGHCVer installVer - - _ -> pure () - - forM_ mBindist $ \bindist -> do - liftE $ installPackedGHC bindist - (Just $ RegexDir "ghc-.*") - ghcdir - (installVer ^. tvVersion) - False -- not a force install, since we already overwrite when compiling. - - liftIO $ B.writeFile (fromInstallDir ghcdir ghcUpSrcBuiltFile) bmk - - case installDir of - -- set and make symlinks for regular (non-isolated) installs - GHCupInternal -> do - reThrowAll GHCupSetError $ postGHCInstall installVer - -- restore - when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing - - _ -> pure () - - pure installVer - - where - defaultConf = - let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) - default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) - in case targetGhc of - Left (GHCTargetVersion (Just _) _) -> cross_mk - _ -> default_mk - - compileHadrianBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadThrow m - , MonadCatch m - , HasLog env - , MonadIO m - , MonadFail m - ) - => GHCTargetVersion - -> FilePath - -> InstallDirResolved - -> Excepts - '[ FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , PatchFailed - , ProcessError - , NotFoundInPATH - , CopyError] - m - (Maybe FilePath) -- ^ output path of bindist, None for cross - compileHadrianBindist tver workdir ghcdir = do - lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap" - - liftE $ configureBindist tver workdir ghcdir - - lift $ logInfo "Building (this may take a while)..." - hadrian_build <- liftE $ findHadrianFile workdir - lEM $ execWithGhcEnv hadrian_build - ( maybe [] (\j -> ["-j" <> show j] ) jobs - ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour - ++ ["binary-dist"] - ) - (Just workdir) "ghc-make" - [tar] <- liftIO $ findFiles - (workdir "_build" "bindist") - (makeRegexOpts compExtended - execBlank - ([s|^ghc-.*\.tar\..*$|] :: ByteString) - ) - liftE $ fmap Just $ copyBindist tver tar (workdir "_build" "bindist") - - findHadrianFile :: (MonadIO m) - => FilePath - -> Excepts - '[HadrianNotFound] - m - FilePath - findHadrianFile workdir = do - let possible_files = if isWindows - then ((workdir "hadrian") ) <$> ["build.bat"] - else ((workdir "hadrian") ) <$> ["build", "build.sh"] - exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f)) - case filter fst exsists of - [] -> throwE HadrianNotFound - ((_, x):_) -> pure x - - compileMakeBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadThrow m - , MonadCatch m - , HasLog env - , MonadIO m - , MonadFail m - ) - => GHCTargetVersion - -> FilePath - -> InstallDirResolved - -> Excepts - '[ FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , PatchFailed - , ProcessError - , NotFoundInPATH - , CopyError] - m - (Maybe FilePath) -- ^ output path of bindist, None for cross - compileMakeBindist tver workdir ghcdir = do - liftE $ configureBindist tver workdir ghcdir - - case mbuildConfig of - Just bc -> liftIOException - doesNotExistErrorType - (FileDoesNotExistError bc) - (liftIO $ copyFile bc (build_mk workdir)) - Nothing -> - liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf) - - liftE $ checkBuildConfig (build_mk workdir) - - lift $ logInfo "Building (this may take a while)..." - lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) - - if | isCross tver -> do - lift $ logInfo "Installing cross toolchain..." - lEM $ make ["install"] (Just workdir) - pure Nothing - | otherwise -> do - lift $ logInfo "Creating bindist..." - lEM $ make ["binary-dist"] (Just workdir) - [tar] <- liftIO $ findFiles - workdir - (makeRegexOpts compExtended - execBlank - ([s|^ghc-.*\.tar\..*$|] :: ByteString) - ) - liftE $ fmap Just $ copyBindist tver tar workdir - - build_mk workdir = workdir "mk" "build.mk" - - copyBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadIO m - , MonadThrow m - , MonadCatch m - , HasLog env - ) - => GHCTargetVersion - -> FilePath -- ^ tar file - -> FilePath -- ^ workdir - -> Excepts - '[CopyError] - m - FilePath - copyBindist tver tar workdir = do - Dirs {..} <- lift getDirs - pfreq <- lift getPlatformReq - c <- liftIO $ BL.readFile (workdir tar) - cDigest <- - fmap (T.take 8) - . lift - . throwEither - . E.decodeUtf8' - . B16.encode - . SHA256.hashlazy - $ c - cTime <- liftIO getCurrentTime - let tarName = makeValid ("ghc-" - <> T.unpack (tVerToText tver) - <> "-" - <> pfReqToString pfreq - <> "-" - <> iso8601Show cTime - <> "-" - <> T.unpack cDigest - <> ".tar" - <> takeExtension tar) - let tarPath = cacheDir tarName - copyFileE (workdir tar) - tarPath - lift $ logInfo $ "Copied bindist to " <> T.pack tarPath - pure tarPath - - checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env) - => FilePath - -> Excepts - '[FileDoesNotExistError, InvalidBuildConfig] - m - () - checkBuildConfig bc = do - c <- liftIOException - doesNotExistErrorType - (FileDoesNotExistError bc) - (liftIO $ B.readFile bc) - let lines' = fmap T.strip . T.lines $ decUTF8Safe c - - -- for cross, we need Stage1Only - case targetGhc of - Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE - (InvalidBuildConfig - [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] - ) - _ -> pure () - - forM_ buildFlavour $ \bf -> - when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do - lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..." - liftIO $ threadDelay 5000000 - - addBuildFlavourToConf bc = case buildFlavour of - Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc - Nothing -> bc - - isCross :: GHCTargetVersion -> Bool - isCross = isJust . _tvTarget - - - configureBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadThrow m - , MonadCatch m - , HasLog env - , MonadIO m - , MonadFail m - ) - => GHCTargetVersion - -> FilePath - -> InstallDirResolved - -> Excepts - '[ FileDoesNotExistError - , InvalidBuildConfig - , PatchFailed - , ProcessError - , NotFoundInPATH - , CopyError - ] - m - () - configureBindist tver workdir (fromInstallDir -> ghcdir) = do - lift $ logInfo [s|configuring build|] - - if | _tvVersion tver >= [vver|8.8.0|] -> do - lEM $ execWithGhcEnv - "sh" - ("./configure" : maybe mempty - (\x -> ["--target=" <> T.unpack x]) - (_tvTarget tver) - ++ ["--prefix=" <> ghcdir] - ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) - ++ fmap T.unpack aargs - ) - (Just workdir) - "ghc-conf" - | otherwise -> do - lEM $ execLogged - "sh" - ( [ "./configure", "--with-ghc=" <> either id id bghc - ] - ++ maybe mempty - (\x -> ["--target=" <> T.unpack x]) - (_tvTarget tver) - ++ ["--prefix=" <> ghcdir] - ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) - ++ fmap T.unpack aargs - ) - (Just workdir) - "ghc-conf" - Nothing - pure () - - execWithGhcEnv :: ( MonadReader env m - , HasSettings env - , HasDirs env - , HasLog env - , MonadIO m - , MonadThrow m) - => FilePath -- ^ thing to execute - -> [String] -- ^ args for the thing - -> Maybe FilePath -- ^ optionally chdir into this - -> FilePath -- ^ log filename (opened in append mode) - -> m (Either ProcessError ()) - execWithGhcEnv fp args dir logf = do - env <- ghcEnv - execLogged fp args dir logf (Just env) - - bghc = case bstrap of - Right g -> Right g - Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) - - ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)] - ghcEnv = do - cEnv <- liftIO getEnvironment - bghcPath <- case bghc of - Right ghc' -> pure ghc' - Left bver -> do - spaths <- liftIO getSearchPath - throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver) - pure (("GHC", bghcPath) : cEnv) - - - - - - - --------------------- - --[ Upgrade GHCup ]-- - --------------------- + ------------------------- + --[ GHCup upgrade etc ]-- + ------------------------- -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, @@ -2630,7 +304,7 @@ upgradeGHCup mtarget force' fatal = do (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer "" when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate dli <- liftE $ getDownloadInfo GHCup latestVer - tmp <- lift withGHCupTmpDir + tmp <- fromGHCupPath <$> lift withGHCupTmpDir let fn = "ghcup" <> exeExt p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False let destDir = takeDirectory destFile @@ -2640,8 +314,7 @@ upgradeGHCup mtarget force' fatal = do lift $ logDebug $ "rm -f " <> T.pack destFile lift $ hideError NoSuchThing $ recycleFile destFile lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile - copyFileE p - destFile + copyFileE p destFile False lift $ chmod_755 destFile liftIO (isInPath destFile) >>= \b -> unless b $ @@ -2664,38 +337,66 @@ upgradeGHCup mtarget force' fatal = do pure latestVer +-- assuming the current scheme of having just 1 ghcup bin, no version info is required. +rmGhcup :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadCatch m + , HasLog env + , MonadMask m + , MonadUnliftIO m + ) + => m () +rmGhcup = do + Dirs { .. } <- getDirs + let ghcupFilename = "ghcup" <> exeExt + let ghcupFilepath = binDir ghcupFilename - ------------- - --[ Other ]-- - ------------- + currentRunningExecPath <- liftIO getExecutablePath + + -- if paths do no exist, warn user, and continue to compare them, as is, + -- which should eventually fail and result in a non-standard install warning + + p1 <- handleIO' doesNotExistErrorType + (handlePathNotPresent currentRunningExecPath) + (liftIO $ canonicalizePath currentRunningExecPath) + + p2 <- handleIO' doesNotExistErrorType + (handlePathNotPresent ghcupFilepath) + (liftIO $ canonicalizePath ghcupFilepath) + + let areEqualPaths = equalFilePath p1 p2 + + unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath + + if isWindows + then do + -- since it doesn't seem possible to delete a running exe on windows + -- we move it to temp dir, to be deleted at next reboot + tempFilepath <- mkGhcupTmpDir + hideError UnsupportedOperation $ + liftIO $ hideError NoSuchThing $ + moveFile ghcupFilepath (fromGHCupPath tempFilepath "ghcup") + else + -- delete it. + hideError doesNotExistErrorType $ rmFile ghcupFilepath + + where + handlePathNotPresent fp _err = do + logDebug $ "Error: The path does not exist, " <> T.pack fp + pure fp + + nonStandardInstallLocationMsg path = T.pack $ + "current ghcup is invoked from a non-standard location: \n" + <> path <> + "\n you may have to uninstall it manually." --- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for --- both installing from source and bindist. -postGHCInstall :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadCatch m - , MonadMask m - , MonadUnliftIO m - ) - => GHCTargetVersion - -> Excepts '[NotInstalled] m () -postGHCInstall ver@GHCTargetVersion {..} = do - void $ liftE $ setGHC ver SetGHC_XYZ Nothing + --------------- + --[ Whereis ]-- + --------------- - -- Create ghc-x.y symlinks. This may not be the current - -- version, create it regardless. - v' <- - handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ fmap Just - $ getMajorMinorV _tvVersion - forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget) - >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) -- | Reports the binary location of a given tool: @@ -2725,7 +426,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do GHC -> do whenM (lift $ fmap not $ ghcInstalled ver) $ throwE (NotInstalled GHC ver) - bdir <- lift $ ghcupGHCDir ver + bdir <- fromGHCupPath <$> lift (ghcupGHCDir ver) pure (bdir "bin" ghcBinaryName ver) Cabal -> do whenM (lift $ fmap not $ cabalInstalled _tvVersion) @@ -2737,7 +438,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do ifM (lift $ isLegacyHLS _tvVersion) (pure (binDir dirs "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt)) $ do - bdir <- lift $ ghcupHLSDir _tvVersion + bdir <- fromGHCupPath <$> lift (ghcupHLSDir _tvVersion) pure (bdir "bin" "haskell-language-server-wrapper" <> exeExt) Stack -> do @@ -2748,6 +449,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do currentRunningExecPath <- liftIO getExecutablePath liftIO $ canonicalizePath currentRunningExecPath + -- | Doesn't work for cross GHC. checkIfToolInstalled :: ( MonadIO m , MonadReader env m @@ -2758,6 +460,7 @@ checkIfToolInstalled :: ( MonadIO m m Bool checkIfToolInstalled tool ver = checkIfToolInstalled' tool (mkTVer ver) + checkIfToolInstalled' :: ( MonadIO m , MonadReader env m , HasDirs env @@ -2773,12 +476,6 @@ checkIfToolInstalled' tool ver = GHC -> ghcInstalled ver _ -> pure False -throwIfFileAlreadyExists :: ( MonadIO m ) => - FilePath -> - Excepts '[FileAlreadyExistsError] m () - -throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp) - (throwE $ FileAlreadyExistsError fp) @@ -2796,7 +493,7 @@ rmOldGHC :: ( MonadReader env m , MonadMask m , MonadUnliftIO m ) - => Excepts '[NotInstalled] m () + => Excepts '[NotInstalled, UninstallFailed] m () rmOldGHC = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls @@ -2823,6 +520,7 @@ rmProfilingLibs = do forM_ regexes $ \regex -> forM_ ghcs $ \ghc -> do d <- ghcupGHCDir ghc + -- TODO: audit findFilesDeep matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep d (makeRegexOpts compExtended @@ -2830,7 +528,7 @@ rmProfilingLibs = do regex ) forM_ matches $ \m -> do - let p = d m + let p = fromGHCupPath d m logDebug $ "rm " <> T.pack p rmFile p @@ -2849,8 +547,8 @@ rmShareDir = do ghcs <- fmap rights getInstalledGHCs forM_ ghcs $ \ghc -> do d <- ghcupGHCDir ghc - let p = d "share" - logDebug $ "rm -rf " <> T.pack p + let p = d `appendGHCupPath` "share" + logDebug $ "rm -rf " <> T.pack (fromGHCupPath p) rmPathForcibly p @@ -2862,7 +560,7 @@ rmHLSNoGHC :: ( MonadReader env m , MonadFail m , MonadUnliftIO m ) - => Excepts '[NotInstalled] m () + => Excepts '[NotInstalled, UninstallFailed] m () rmHLSNoGHC = do Dirs {..} <- getDirs ghcs <- fmap rights getInstalledGHCs @@ -2895,9 +593,9 @@ rmCache :: ( MonadReader env m => m () rmCache = do Dirs {..} <- getDirs - contents <- liftIO $ listDirectory cacheDir + contents <- liftIO $ listDirectory (fromGHCupPath cacheDir) forM_ contents $ \f -> do - let p = cacheDir f + let p = fromGHCupPath cacheDir f logDebug $ "rm " <> T.pack p rmFile p @@ -2910,36 +608,9 @@ rmTmp :: ( MonadReader env m ) => m () rmTmp = do - tmpdir <- liftIO getCanonicalTemporaryDirectory - ghcup_dirs <- liftIO $ handleIO (\_ -> pure []) $ findFiles - tmpdir - (makeRegexOpts compExtended - execBlank - ([s|^ghcup-.*$|] :: ByteString) - ) + ghcup_dirs <- liftIO getGHCupTmpDirs forM_ ghcup_dirs $ \f -> do - let p = tmpdir f - logDebug $ "rm -rf " <> T.pack p - rmPathForcibly p + logDebug $ "rm -rf " <> T.pack (fromGHCupPath f) + rmPathForcibly f -applyAnyPatch :: ( MonadReader env m - , HasDirs env - , HasLog env - , HasSettings env - , MonadUnliftIO m - , MonadCatch m - , MonadResource m - , MonadThrow m - , MonadMask m - , MonadIO m) - => Maybe (Either FilePath [URI]) - -> FilePath - -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m () -applyAnyPatch Nothing _ = pure () -applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir -applyAnyPatch (Just (Right uris)) workdir = do - tmpUnpack <- lift withGHCupTmpDir - forM_ uris $ \uri -> do - patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False - liftE $ applyPatch patch workdir diff --git a/lib/GHCup/Cabal.hs b/lib/GHCup/Cabal.hs new file mode 100644 index 0000000..9f6fe67 --- /dev/null +++ b/lib/GHCup/Cabal.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Cabal +Description : GHCup installation functions for Cabal +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Cabal where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.Either +import Data.List +import Data.Maybe +import Data.Versions hiding ( patch ) +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) +import Safe hiding ( at ) +import System.FilePath +import System.IO.Error + +import qualified Data.Text as T + + + + ------------------------- + --[ Tool installation ]-- + ------------------------- + + +-- | Like 'installCabalBin', except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installCabalBindist :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => DownloadInfo + -> Version + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installCabalBindist dlinfo ver installDir forceInstall = do + lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver + + PlatformRequest {..} <- lift getPlatformReq + Dirs {..} <- lift getDirs + + -- check if we already have a regular cabal already installed + regularCabalInstalled <- lift $ cabalInstalled ver + + if + | not forceInstall + , regularCabalInstalled + , GHCupInternal <- installDir -> do + throwE $ AlreadyInstalled Cabal ver + + | forceInstall + , regularCabalInstalled + , GHCupInternal <- installDir -> do + lift $ logInfo "Removing the currently installed version first!" + liftE $ rmCabalVer ver + + | otherwise -> pure () + + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + case installDir of + IsolateDir isoDir -> do -- isolated install + lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir + liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + + GHCupInternal -> do -- regular install + liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall + + +-- | Install an unpacked cabal distribution.Symbol +installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) + => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) + -> InstallDirResolved -- ^ Path to install to + -> Version + -> Bool -- ^ Force Install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installCabalUnpacked path inst ver forceInstall = do + lift $ logInfo "Installing cabal" + let cabalFile = "cabal" + liftIO $ createDirRecursive' (fromInstallDir inst) + let destFileName = cabalFile + <> (case inst of + IsolateDirResolved _ -> "" + _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + let destPath = fromInstallDir inst destFileName + + copyFileE + (path cabalFile <> exeExt) + destPath + (not forceInstall) + lift $ chmod_755 destPath + +-- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and +-- creates a default @cabal -> cabal-x.y.z.q@ symlink for +-- the latest installed version. +installCabalBin :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Version + -> InstallDir + -> Bool -- force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installCabalBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo Cabal ver + installCabalBindist dlinfo ver installDir forceInstall + + + ----------------- + --[ Set cabal ]-- + ----------------- + + +-- | Set the @~\/.ghcup\/bin\/cabal@ symlink. +setCabal :: ( MonadMask m + , MonadReader env m + , HasDirs env + , HasLog env + , MonadFail m + , MonadIO m + , MonadUnliftIO m) + => Version + -> Excepts '[NotInstalled] m () +setCabal ver = do + let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt + + -- symlink destination + Dirs {..} <- lift getDirs + + whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) + $ throwE + $ NotInstalled Cabal (GHCTargetVersion Nothing ver) + + let cabalbin = binDir "cabal" <> exeExt + + -- create link + let destL = targetFile + lift $ createLink destL cabalbin + + pure () + +unsetCabal :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetCabal = do + Dirs {..} <- getDirs + let cabalbin = binDir "cabal" <> exeExt + hideError doesNotExistErrorType $ rmLink cabalbin + + + ---------------- + --[ Rm cabal ]-- + ---------------- + + +-- | Delete a cabal version. Will try to fix the @cabal@ symlink +-- after removal (e.g. setting it to an older version). +rmCabalVer :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled] m () +rmCabalVer ver = do + whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver)) + + cSet <- lift cabalSet + + Dirs {..} <- lift getDirs + + let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt + lift $ hideError doesNotExistErrorType $ recycleFile (binDir cabalFile) + + when (Just ver == cSet) $ do + cVers <- lift $ fmap rights getInstalledCabals + case headMay . reverse . sort $ cVers of + Just latestver -> setCabal latestver + Nothing -> lift $ rmLink (binDir "cabal" <> exeExt) diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 8327c76..382f6bc 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -34,9 +34,10 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.Prelude +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger.Internal +import GHCup.Prelude.Process import GHCup.Version import Control.Applicative @@ -69,7 +70,6 @@ import Prelude hiding ( abs , writeFile ) import Safe -import System.Directory import System.Environment import System.Exit import System.FilePath @@ -145,7 +145,7 @@ getDownloadsF = do yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath yamlFromCache uri = do Dirs{..} <- getDirs - pure (cacheDir (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)) + pure (fromGHCupPath cacheDir (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)) etagsFile :: FilePath -> FilePath @@ -242,7 +242,7 @@ getBase uri = do Settings { metaCache } <- lift getSettings -- for local files, let's short-circuit and ignore access time - if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True + if | scheme == "file" -> liftE $ download uri' Nothing Nothing (fromGHCupPath cacheDir) Nothing True | e -> do accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime @@ -581,7 +581,7 @@ downloadCached dli mfn = do True -> downloadCached' dli mfn Nothing False -> do tmp <- lift withGHCupTmpDir - liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False + liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False downloadCached' :: ( MonadReader env m @@ -599,7 +599,7 @@ downloadCached' :: ( MonadReader env m -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath downloadCached' dli mfn mDestDir = do Dirs { cacheDir } <- lift getDirs - let destDir = fromMaybe cacheDir mDestDir + let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn let cachfile = destDir fn fileExists <- liftIO $ doesFileExist cachfile diff --git a/lib/GHCup/Download/IOStreams.hs b/lib/GHCup/Download/IOStreams.hs index 9682a64..8f96f38 100644 --- a/lib/GHCup/Download/IOStreams.hs +++ b/lib/GHCup/Download/IOStreams.hs @@ -10,7 +10,7 @@ module GHCup.Download.IOStreams where import GHCup.Download.Utils import GHCup.Errors import GHCup.Types.JSON ( ) -import GHCup.Utils.Prelude +import GHCup.Prelude import Control.Applicative import Control.Exception.Safe diff --git a/lib/GHCup/Download/Utils.hs b/lib/GHCup/Download/Utils.hs index 7a7e3ba..ba5cdaf 100644 --- a/lib/GHCup/Download/Utils.hs +++ b/lib/GHCup/Download/Utils.hs @@ -10,7 +10,7 @@ module GHCup.Download.Utils where import GHCup.Errors import GHCup.Types.Optics import GHCup.Types.JSON ( ) -import GHCup.Utils.Prelude +import GHCup.Prelude import Control.Applicative import Control.Monad diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index df72bd2..6dd405f 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -105,6 +105,15 @@ instance Pretty CopyError where pPrint (CopyError reason) = text ("Unable to copy a file. Reason was: " ++ reason) +-- | Unable to merge file trees. +data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath + deriving Show + +instance Pretty MergeFileTreeError where + pPrint (MergeFileTreeError e from to) = + text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e) + <+> text "\n...tried to clean up" <+> text to <+> text ". Make sure it's gone." + -- | Unable to find a tag of a tool. data TagNotFound = TagNotFound Tag Tool deriving Show @@ -146,6 +155,13 @@ instance Pretty NotInstalled where pPrint (NotInstalled tool ver) = text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed." +data UninstallFailed = UninstallFailed FilePath [FilePath] + deriving Show + +instance Pretty UninstallFailed where + pPrint (UninstallFailed dir files) = + text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually." + -- | An executable was expected to be in PATH, but was not found. data NotFoundInPATH = NotFoundInPATH FilePath deriving Show diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs new file mode 100644 index 0000000..0e8ea65 --- /dev/null +++ b/lib/GHCup/GHC.hs @@ -0,0 +1,1078 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : GHCup.GHC +Description : GHCup installation functions for GHC +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.GHC where + + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ +import GHCup.Prelude.Version.QQ +import GHCup.Prelude.MegaParsec + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Concurrent ( threadDelay ) +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.ByteString ( ByteString ) +import Data.Either +import Data.List +import Data.Maybe +import Data.List.NonEmpty ( NonEmpty((:|)) ) +import Data.String ( fromString ) +import Data.Text ( Text ) +import Data.Time.Clock +import Data.Time.Format.ISO8601 +import Data.Versions hiding ( patch ) +import GHC.IO.Exception +import Haskus.Utils.Variant.Excepts +import Language.Haskell.TH +import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) ) +import Optics +import Prelude hiding ( abs + , writeFile + ) +import System.Environment +import System.FilePath +import System.IO.Error +import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import Text.Regex.Posix +import URI.ByteString + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as E +import qualified Text.Megaparsec as MP + + + --------------------- + --[ Tool fetching ]-- + --------------------- + + + +fetchGHCSrc :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Maybe FilePath + -> Excepts + '[ DigestError + , GPGError + , DownloadFailed + , NoDownload + ] + m + FilePath +fetchGHCSrc v mfp = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlInfo <- + preview (ix GHC % ix v % viSourceDL % _Just) dls + ?? NoDownload + liftE $ downloadCached' dlInfo Nothing mfp + + + + ------------------------- + --[ Tool installation ]-- + ------------------------- + + +-- | Like 'installGHCBin', except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installGHCBindist :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => DownloadInfo -- ^ where/how to download + -> Version -- ^ the version to install + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , DirNotEmpty + , ArchiveResult + , ProcessError + , UninstallFailed + , MergeFileTreeError + ] + m + () +installGHCBindist dlinfo ver installDir forceInstall = do + let tver = mkTVer ver + + lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver + + regularGHCInstalled <- lift $ ghcInstalled tver + + if + | not forceInstall + , regularGHCInstalled + , GHCupInternal <- installDir -> do + throwE $ AlreadyInstalled GHC ver + + | forceInstall + , regularGHCInstalled + , GHCupInternal <- installDir -> do + lift $ logInfo "Removing the currently installed GHC version first!" + liftE $ rmGHCVer tver + + | otherwise -> pure () + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + + toolchainSanityChecks + + case installDir of + IsolateDir isoDir -> do -- isolated install + lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall + GHCupInternal -> do -- regular install + -- prepare paths + ghcdir <- lift $ ghcupGHCDir tver + + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall + + -- make symlinks & stuff when regular install, + liftE $ postGHCInstall tver + + where + toolchainSanityChecks = do + r <- forM ["CC", "LD"] (liftIO . lookupEnv) + case catMaybes r of + [] -> pure () + _ -> do + lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker" + <> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda" + <> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall." + + +-- | Install a packed GHC distribution. This only deals with unpacking and the GHC +-- build system and nothing else. +installPackedGHC :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasSettings env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadUnliftIO m + , MonadFail m + , MonadResource m + ) + => FilePath -- ^ Path to the packed GHC bindist + -> Maybe TarDir -- ^ Subdir of the archive + -> InstallDirResolved + -> Version -- ^ The GHC version + -> Bool -- ^ Force install + -> Excepts + '[ BuildFailed + , UnknownArchive + , TarDirDoesNotExist + , DirNotEmpty + , ArchiveResult + , ProcessError + , MergeFileTreeError + ] m () +installPackedGHC dl msubdir inst ver forceInstall = do + PlatformRequest {..} <- lift getPlatformReq + + unless forceInstall + (liftE $ installDestSanityCheck inst) + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + msubdir + + liftE $ runBuildAction tmpUnpack + (installUnpackedGHC workdir inst ver forceInstall) + + +-- | Install an unpacked GHC distribution. This only deals with the GHC +-- build system and nothing else. +installUnpackedGHC :: ( MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadUnliftIO m + , MonadMask m + , MonadResource m + , MonadFail m + ) + => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides) + -> InstallDirResolved -- ^ Path to install to + -> Version -- ^ The GHC version + -> Bool -- ^ Force install + -> Excepts '[ProcessError, MergeFileTreeError] m () +installUnpackedGHC path inst ver forceInstall + | isWindows = do + lift $ logInfo "Installing GHC (this may take a while)" + -- Windows bindists are relocatable and don't need + -- to run configure. + -- We also must make sure to preserve mtime to not confuse ghc-pkg. + liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do + mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source) + when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest + liftIO $ moveFilePortable source dest + forM_ mtime $ liftIO . setModificationTime dest + | otherwise = do + PlatformRequest {..} <- lift getPlatformReq + + let alpineArgs + | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform + = ["--disable-ld-override"] + | otherwise + = [] + + lift $ logInfo "Installing GHC (this may take a while)" + lEM $ execLogged "sh" + ("./configure" : ("--prefix=" <> fromInstallDir inst) + : alpineArgs + ) + (Just $ fromGHCupPath path) + "ghc-configure" + Nothing + tmpInstallDest <- lift withGHCupTmpDir + lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) + liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + inst + GHC + (mkTVer ver) + (\f t -> liftIO $ do + mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) + install f t (not forceInstall) + forM_ mtime $ setModificationTime t) + + pure () + + +-- | Installs GHC into @~\/.ghcup\/ghc/\@ and places the +-- following symlinks in @~\/.ghcup\/bin@: +-- +-- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@ +-- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version) +installGHCBin :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version -- ^ the version to install + -> InstallDir + -> Bool -- ^ force install + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , DirNotEmpty + , ArchiveResult + , ProcessError + , UninstallFailed + , MergeFileTreeError + ] + m + () +installGHCBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo GHC ver + liftE $ installGHCBindist dlinfo ver installDir forceInstall + + + + + + --------------- + --[ Set GHC ]-- + --------------- + + + +-- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends +-- on `SetGHC`: +-- +-- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ +-- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ +-- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\ -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ +-- +-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ +-- for 'SetGHCOnly' constructor. +setGHC :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => GHCTargetVersion + -> SetGHC + -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin + -- and don't want mess with other versions + -> Excepts '[NotInstalled] m GHCTargetVersion +setGHC ver sghc mBinDir = do + let verS = T.unpack $ prettyVer (_tvVersion ver) + ghcdir <- lift $ ghcupGHCDir ver + + whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) + + -- symlink destination + binDir <- case mBinDir of + Just x -> pure x + Nothing -> do + Dirs {binDir = f} <- lift getDirs + pure f + + -- first delete the old symlinks (this fixes compatibility issues + -- with old ghcup) + when (isNothing mBinDir) $ + case sghc of + SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver) + SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver + SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver + + -- for ghc tools (ghc, ghci, haddock, ...) + verfiles <- ghcToolFiles ver + forM_ verfiles $ \file -> do + mTargetFile <- case sghc of + SetGHCOnly -> pure $ Just file + SetGHC_XY -> do + handle + (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) + $ do + (mj, mi) <- getMajorMinorV (_tvVersion ver) + let major' = intToText mj <> "." <> intToText mi + pure $ Just (file <> "-" <> T.unpack major') + SetGHC_XYZ -> + pure $ Just (file <> "-" <> verS) + + -- create symlink + forM_ mTargetFile $ \targetFile -> do + bindir <- ghcInternalBinDir ver + let fullF = binDir targetFile <> exeExt + fileWithExt = bindir file <> exeExt + destL <- binarySymLinkDestination binDir fileWithExt + lift $ createLink destL fullF + + when (isNothing mBinDir) $ do + -- create symlink for share dir + when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir (fromGHCupPath ghcdir) verS + + when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility + + pure ver + + where + + symlinkShareDir :: ( MonadReader env m + , HasDirs env + , MonadIO m + , HasLog env + , MonadCatch m + , MonadMask m + ) + => FilePath + -> String + -> m () + symlinkShareDir ghcdir ver' = do + Dirs {..} <- getDirs + let destdir = fromGHCupPath baseDir + case sghc of + SetGHCOnly -> do + let sharedir = "share" + let fullsharedir = ghcdir sharedir + logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir + whenM (liftIO $ doesDirectoryExist fullsharedir) $ do + let fullF = destdir sharedir + let targetF = "." "ghc" ver' sharedir + logDebug $ "rm -f " <> T.pack fullF + hideError doesNotExistErrorType $ rmDirectoryLink fullF + logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF + + if isWindows + then liftIO + -- On windows we need to be more permissive + -- in case symlinks can't be created, be just + -- give up here. This symlink isn't strictly necessary. + $ hideError permissionErrorType + $ hideError illegalOperationErrorType + $ createDirectoryLink targetF fullF + else liftIO + $ createDirectoryLink targetF fullF + _ -> pure () + +unsetGHC :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadMask m + ) + => Maybe Text + -> Excepts '[NotInstalled] m () +unsetGHC = rmPlainGHC + + + + + + -------------- + --[ GHC rm ]-- + -------------- + + +-- | Delete a ghc version and all its symlinks. +-- +-- This may leave GHCup without a "set" version. +-- Will try to fix the ghc-x.y symlink after removal (e.g. to an +-- older version). +rmGHCVer :: ( MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => GHCTargetVersion + -> Excepts '[NotInstalled, UninstallFailed] m () +rmGHCVer ver = do + isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver) + + whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) + + -- this isn't atomic, order matters + when isSetGHC $ do + lift $ logInfo "Removing ghc symlinks" + liftE $ rmPlainGHC (_tvTarget ver) + + lift $ logInfo "Removing ghc-x.y.z symlinks" + liftE $ rmMinorGHCSymlinks ver + + lift $ logInfo "Removing/rewiring ghc-x.y symlinks" + -- first remove + handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver + -- then fix them (e.g. with an earlier version) + + dir' <- lift $ ghcupGHCDir ver + let dir = fromGHCupPath dir' + lift (getInstalledFiles GHC ver) >>= \case + Just files -> do + lift $ logInfo $ "Removing files safely from: " <> T.pack dir + forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir dropDrive f)) + removeEmptyDirsRecursive dir + survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir + f <- recordedInstallationFile GHC ver + lift $ recycleFile f + when (not (null survivors)) $ throwE $ UninstallFailed dir survivors + Nothing -> do + lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir + lift $ recyclePathForcibly dir' + + v' <- + handle + (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) + $ fmap Just + $ getMajorMinorV (_tvVersion ver) + forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver)) + >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) + + Dirs {..} <- lift getDirs + + lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir "share") + + + + + --------------- + --[ Compile ]-- + --------------- + + +-- | Compile a GHC from source. This behaves wrt symlinks and installation +-- the same as 'installGHCBin'. +compileGHC :: ( MonadMask m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + , HasSettings env + , MonadThrow m + , MonadResource m + , HasLog env + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Either GHCTargetVersion GitBranch -- ^ version to install + -> Maybe Version -- ^ overwrite version + -> Either Version FilePath -- ^ version to bootstrap with + -> Maybe Int -- ^ jobs + -> Maybe FilePath -- ^ build config + -> Maybe (Either FilePath [URI]) -- ^ patches + -> [Text] -- ^ additional args to ./configure + -> Maybe String -- ^ build flavour + -> Bool + -> InstallDir + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , GHCupSetError + , NoDownload + , NotFoundInPATH + , PatchFailed + , UnknownArchive + , TarDirDoesNotExist + , NotInstalled + , DirNotEmpty + , ArchiveResult + , FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , ProcessError + , CopyError + , BuildFailed + , UninstallFailed + , MergeFileTreeError + ] + m + GHCTargetVersion +compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir + = do + PlatformRequest { .. } <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + + (workdir, tmpUnpack, tver) <- case targetGhc of + -- unpack from version tarball + Left tver -> do + lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap + + -- download source tarball + dlInfo <- + preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls + ?? NoDownload + dl <- liftE $ downloadCached dlInfo Nothing + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform $ fromGHCupPath tmpUnpack + + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + (view dlSubdir dlInfo) + liftE $ applyAnyPatch patches (fromGHCupPath workdir) + + pure (workdir, tmpUnpack, tver) + + -- clone from git + Right GitBranch{..} -> do + tmpUnpack <- lift mkGhcupTmpDir + let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing + tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do + let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo + lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" + lEM $ git [ "init" ] + lEM $ git [ "remote" + , "add" + , "origin" + , fromString rep ] + + let fetch_args = + [ "fetch" + , "--depth" + , "1" + , "--quiet" + , "origin" + , fromString ref ] + lEM $ git fetch_args + + lEM $ git [ "checkout", "FETCH_HEAD" ] + lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] + liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) + lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + CapturedProcess {..} <- lift $ makeOut + ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) + case _exitCode of + ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut + ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) + + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver + + pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) + -- the version that's installed may differ from the + -- compiled version, so the user can overwrite it + let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov + + alreadyInstalled <- lift $ ghcInstalled installVer + alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) + + when alreadyInstalled $ do + case installDir of + IsolateDir isoDir -> + lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir + GHCupInternal -> + lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version." + lift $ logWarn + "...waiting for 10 seconds before continuing, you can still abort..." + liftIO $ threadDelay 10000000 -- give the user a sec to intervene + + ghcdir <- case installDir of + IsolateDir isoDir -> pure $ IsolateDirResolved isoDir + GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) + + (mBindist, bmk) <- liftE $ runBuildAction + tmpUnpack + (do + b <- if hadrian + then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir + else compileMakeBindist tver (fromGHCupPath workdir) ghcdir + bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir) + pure (b, bmk) + ) + + case installDir of + GHCupInternal -> + -- only remove old ghc in regular installs + when alreadyInstalled $ do + lift $ logInfo "Deleting existing installation" + liftE $ rmGHCVer installVer + + _ -> pure () + + forM_ mBindist $ \bindist -> do + liftE $ installPackedGHC bindist + (Just $ RegexDir "ghc-.*") + ghcdir + (installVer ^. tvVersion) + False -- not a force install, since we already overwrite when compiling. + + liftIO $ B.writeFile (fromInstallDir ghcdir ghcUpSrcBuiltFile) bmk + + case installDir of + -- set and make symlinks for regular (non-isolated) installs + GHCupInternal -> do + reThrowAll GHCupSetError $ postGHCInstall installVer + -- restore + when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing + + _ -> pure () + + pure installVer + + where + defaultConf = + let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) + default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) + in case targetGhc of + Left (GHCTargetVersion (Just _) _) -> cross_mk + _ -> default_mk + + compileHadrianBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadThrow m + , MonadCatch m + , HasLog env + , MonadIO m + , MonadFail m + ) + => GHCTargetVersion + -> FilePath + -> InstallDirResolved + -> Excepts + '[ FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , PatchFailed + , ProcessError + , NotFoundInPATH + , CopyError] + m + (Maybe FilePath) -- ^ output path of bindist, None for cross + compileHadrianBindist tver workdir ghcdir = do + lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap" + + liftE $ configureBindist tver workdir ghcdir + + lift $ logInfo "Building (this may take a while)..." + hadrian_build <- liftE $ findHadrianFile workdir + lEM $ execWithGhcEnv hadrian_build + ( maybe [] (\j -> ["-j" <> show j] ) jobs + ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour + ++ ["binary-dist"] + ) + (Just workdir) "ghc-make" + [tar] <- liftIO $ findFiles + (workdir "_build" "bindist") + (makeRegexOpts compExtended + execBlank + ([s|^ghc-.*\.tar\..*$|] :: ByteString) + ) + liftE $ fmap Just $ copyBindist tver tar (workdir "_build" "bindist") + + findHadrianFile :: (MonadIO m) + => FilePath + -> Excepts + '[HadrianNotFound] + m + FilePath + findHadrianFile workdir = do + let possible_files = if isWindows + then ((workdir "hadrian") ) <$> ["build.bat"] + else ((workdir "hadrian") ) <$> ["build", "build.sh"] + exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f)) + case filter fst exsists of + [] -> throwE HadrianNotFound + ((_, x):_) -> pure x + + compileMakeBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadThrow m + , MonadCatch m + , HasLog env + , MonadIO m + , MonadFail m + ) + => GHCTargetVersion + -> FilePath + -> InstallDirResolved + -> Excepts + '[ FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , PatchFailed + , ProcessError + , NotFoundInPATH + , CopyError] + m + (Maybe FilePath) -- ^ output path of bindist, None for cross + compileMakeBindist tver workdir ghcdir = do + liftE $ configureBindist tver workdir ghcdir + + case mbuildConfig of + Just bc -> liftIOException + doesNotExistErrorType + (FileDoesNotExistError bc) + (liftIO $ copyFile bc (build_mk workdir) False) + Nothing -> + liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf) + + liftE $ checkBuildConfig (build_mk workdir) + + lift $ logInfo "Building (this may take a while)..." + lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) + + if | isCross tver -> do + lift $ logInfo "Installing cross toolchain..." + lEM $ make ["install"] (Just workdir) + pure Nothing + | otherwise -> do + lift $ logInfo "Creating bindist..." + lEM $ make ["binary-dist"] (Just workdir) + [tar] <- liftIO $ findFiles + workdir + (makeRegexOpts compExtended + execBlank + ([s|^ghc-.*\.tar\..*$|] :: ByteString) + ) + liftE $ fmap Just $ copyBindist tver tar workdir + + build_mk workdir = workdir "mk" "build.mk" + + copyBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadIO m + , MonadThrow m + , MonadCatch m + , HasLog env + ) + => GHCTargetVersion + -> FilePath -- ^ tar file + -> FilePath -- ^ workdir + -> Excepts + '[CopyError] + m + FilePath + copyBindist tver tar workdir = do + Dirs {..} <- lift getDirs + pfreq <- lift getPlatformReq + c <- liftIO $ BL.readFile (workdir tar) + cDigest <- + fmap (T.take 8) + . lift + . throwEither + . E.decodeUtf8' + . B16.encode + . SHA256.hashlazy + $ c + cTime <- liftIO getCurrentTime + let tarName = makeValid ("ghc-" + <> T.unpack (tVerToText tver) + <> "-" + <> pfReqToString pfreq + <> "-" + <> iso8601Show cTime + <> "-" + <> T.unpack cDigest + <> ".tar" + <> takeExtension tar) + let tarPath = fromGHCupPath cacheDir tarName + copyFileE (workdir tar) tarPath False + lift $ logInfo $ "Copied bindist to " <> T.pack tarPath + pure tarPath + + checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env) + => FilePath + -> Excepts + '[FileDoesNotExistError, InvalidBuildConfig] + m + () + checkBuildConfig bc = do + c <- liftIOException + doesNotExistErrorType + (FileDoesNotExistError bc) + (liftIO $ B.readFile bc) + let lines' = fmap T.strip . T.lines $ decUTF8Safe c + + -- for cross, we need Stage1Only + case targetGhc of + Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE + (InvalidBuildConfig + [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] + ) + _ -> pure () + + forM_ buildFlavour $ \bf -> + when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do + lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..." + liftIO $ threadDelay 5000000 + + addBuildFlavourToConf bc = case buildFlavour of + Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc + Nothing -> bc + + isCross :: GHCTargetVersion -> Bool + isCross = isJust . _tvTarget + + + configureBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadThrow m + , MonadCatch m + , HasLog env + , MonadIO m + , MonadFail m + ) + => GHCTargetVersion + -> FilePath + -> InstallDirResolved + -> Excepts + '[ FileDoesNotExistError + , InvalidBuildConfig + , PatchFailed + , ProcessError + , NotFoundInPATH + , CopyError + ] + m + () + configureBindist tver workdir (fromInstallDir -> ghcdir) = do + lift $ logInfo [s|configuring build|] + + if | _tvVersion tver >= [vver|8.8.0|] -> do + lEM $ execWithGhcEnv + "sh" + ("./configure" : maybe mempty + (\x -> ["--target=" <> T.unpack x]) + (_tvTarget tver) + ++ ["--prefix=" <> ghcdir] + ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) + ++ fmap T.unpack aargs + ) + (Just workdir) + "ghc-conf" + | otherwise -> do + lEM $ execLogged + "sh" + ( [ "./configure", "--with-ghc=" <> either id id bghc + ] + ++ maybe mempty + (\x -> ["--target=" <> T.unpack x]) + (_tvTarget tver) + ++ ["--prefix=" <> ghcdir] + ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) + ++ fmap T.unpack aargs + ) + (Just workdir) + "ghc-conf" + Nothing + pure () + + execWithGhcEnv :: ( MonadReader env m + , HasSettings env + , HasDirs env + , HasLog env + , MonadIO m + , MonadThrow m) + => FilePath -- ^ thing to execute + -> [String] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> FilePath -- ^ log filename (opened in append mode) + -> m (Either ProcessError ()) + execWithGhcEnv fp args dir logf = do + env <- ghcEnv + execLogged fp args dir logf (Just env) + + bghc = case bstrap of + Right g -> Right g + Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) + + ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)] + ghcEnv = do + cEnv <- liftIO getEnvironment + bghcPath <- case bghc of + Right ghc' -> pure ghc' + Left bver -> do + spaths <- liftIO getSearchPath + throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver) + pure (("GHC", bghcPath) : cEnv) + + + + + ------------- + --[ Other ]-- + ------------- + + + +-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for +-- both installing from source and bindist. +postGHCInstall :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => GHCTargetVersion + -> Excepts '[NotInstalled] m () +postGHCInstall ver@GHCTargetVersion {..} = do + void $ liftE $ setGHC ver SetGHC_XYZ Nothing + + -- Create ghc-x.y symlinks. This may not be the current + -- version, create it regardless. + v' <- + handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) + $ fmap Just + $ getMajorMinorV _tvVersion + forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget) + >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) + diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs new file mode 100644 index 0000000..0f4f131 --- /dev/null +++ b/lib/GHCup/HLS.hs @@ -0,0 +1,620 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : GHCup.HLS +Description : GHCup installation functions for HLS +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.HLS where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.ByteString ( ByteString ) +import Data.Either +import Data.List +import Data.Maybe +import Data.String ( fromString ) +import Data.Text ( Text ) +import Data.Versions hiding ( patch ) +import Distribution.Types.Version hiding ( Version ) +import Distribution.Types.PackageId +import Distribution.Types.PackageDescription +import Distribution.Types.GenericPackageDescription +import Distribution.PackageDescription.Parsec +import GHC.IO.Exception +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) +import Safe hiding ( at ) +import System.FilePath +import System.IO.Error +import Text.Regex.Posix +import URI.ByteString + +import qualified Data.List.NonEmpty as NE +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Text.Megaparsec as MP + + + + -------------------- + --[ Installation ]-- + -------------------- + + +-- | Like 'installHLSBin, except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installHLSBindist :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => DownloadInfo + -> Version + -> InstallDir -- ^ isolated install path, if user passed any + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + , ProcessError + , DirNotEmpty + , UninstallFailed + , MergeFileTreeError + ] + m + () +installHLSBindist dlinfo ver installDir forceInstall = do + lift $ logDebug $ "Requested to install hls version " <> prettyVer ver + + PlatformRequest {..} <- lift getPlatformReq + Dirs {..} <- lift getDirs + + regularHLSInstalled <- lift $ hlsInstalled ver + + if + | not forceInstall + , regularHLSInstalled + , GHCupInternal <- installDir -> do -- regular install + throwE $ AlreadyInstalled HLS ver + + | forceInstall + , regularHLSInstalled + , GHCupInternal <- installDir -> do -- regular forced install + lift $ logInfo "Removing the currently installed version of HLS before force installing!" + liftE $ rmHLSVer ver + + | otherwise -> pure () + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + legacy <- liftIO $ isLegacyHLSBindist workdir + + if + | not forceInstall + , not legacy + , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp) + | otherwise -> pure () + + case installDir of + IsolateDir isoDir -> do + lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir + if legacy + then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall + else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + + GHCupInternal -> do + if legacy + then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall + else do + inst <- ghcupHLSDir ver + liftE $ runBuildAction tmpUnpack + $ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall + liftE $ setHLS ver SetHLS_XYZ Nothing + + +isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist + -> IO Bool +isLegacyHLSBindist path = do + not <$> doesFileExist (path "GNUmakefile") + +-- | Install an unpacked hls distribution. +installHLSUnpacked :: ( MonadMask m + , MonadUnliftIO m + , MonadReader env m + , MonadFail m + , HasLog env + , HasDirs env + , HasSettings env + , MonadCatch m + , MonadIO m + , MonadResource m + , HasPlatformReq env + ) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> InstallDirResolved -- ^ Path to install to + -> Version + -> Bool + -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m () +installHLSUnpacked path inst ver forceInstall = do + PlatformRequest { .. } <- lift getPlatformReq + lift $ logInfo "Installing HLS" + tmpInstallDest <- lift withGHCupTmpDir + lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) + liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + inst + HLS + (mkTVer ver) + (\f t -> liftIO $ do + mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) + install f t (not forceInstall) + forM_ mtime $ setModificationTime t) + +-- | Install an unpacked hls distribution (legacy). +installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> InstallDirResolved -- ^ Path to install to + -> Version + -> Bool -- ^ is it a force install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installHLSUnpackedLegacy path installDir ver forceInstall = do + lift $ logInfo "Installing HLS" + liftIO $ createDirRecursive' (fromInstallDir installDir) + + -- install haskell-language-server- + bins@(_:_) <- liftIO $ findFiles + path + (makeRegexOpts compExtended + execBlank + ([s|^haskell-language-server-[0-9].*$|] :: ByteString) + ) + forM_ bins $ \f -> do + let toF = dropSuffix exeExt f + <> (case installDir of + IsolateDirResolved _ -> "" + _ -> ("~" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + + let srcPath = path f + let destPath = fromInstallDir installDir toF + + -- destination could be an existing symlink + -- for new make-based HLSes + liftIO $ rmFileForce destPath + + copyFileE + srcPath + destPath + (not forceInstall) + lift $ chmod_755 destPath + + -- install haskell-language-server-wrapper + let wrapper = "haskell-language-server-wrapper" + toF = wrapper + <> (case installDir of + IsolateDirResolved _ -> "" + _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + srcWrapperPath = path wrapper <> exeExt + destWrapperPath = fromInstallDir installDir toF + + liftIO $ rmFileForce destWrapperPath + copyFileE + srcWrapperPath + destWrapperPath + (not forceInstall) + + lift $ chmod_755 destWrapperPath + + + +-- | Installs hls binaries @haskell-language-server-\@ +-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. +installHLSBin :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Version + -> InstallDir + -> Bool -- force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + , ProcessError + , DirNotEmpty + , UninstallFailed + , MergeFileTreeError + ] + m + () +installHLSBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo HLS ver + installHLSBindist dlinfo ver installDir forceInstall + + +compileHLS :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Either Version GitBranch + -> [Version] + -> Maybe Int + -> Maybe Version + -> InstallDir + -> Maybe (Either FilePath URI) + -> Maybe URI + -> Maybe (Either FilePath [URI]) -- ^ patches + -> [Text] -- ^ additional args to cabal install + -> Excepts '[ NoDownload + , GPGError + , DownloadFailed + , DigestError + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , BuildFailed + , NotInstalled + ] m Version +compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do + PlatformRequest { .. } <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + Dirs { .. } <- lift getDirs + + + (workdir, tver) <- case targetHLS of + -- unpack from version tarball + Left tver -> do + lift $ logDebug $ "Requested to compile: " <> prettyVer tver + + -- download source tarball + dlInfo <- + preview (ix HLS % ix tver % viSourceDL % _Just) dls + ?? NoDownload + dl <- liftE $ downloadCached dlInfo Nothing + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + (view dlSubdir dlInfo) + + pure (workdir, tver) + + -- clone from git + Right GitBranch{..} -> do + tmpUnpack <- lift mkGhcupTmpDir + let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing + tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do + let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo + lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" + lEM $ git [ "init" ] + lEM $ git [ "remote" + , "add" + , "origin" + , fromString rep ] + + let fetch_args = + [ "fetch" + , "--depth" + , "1" + , "--quiet" + , "origin" + , fromString ref ] + lEM $ git fetch_args + + lEM $ git [ "checkout", "FETCH_HEAD" ] + (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack "haskell-language-server.cabal")) + pure . (\c -> Version Nothing c [] Nothing) + . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral) + . versionNumbers + . pkgVersion + . package + . packageDescription + $ gpd + + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver + + pure (tmpUnpack, tver) + + -- the version that's installed may differ from the + -- compiled version, so the user can overwrite it + let installVer = fromMaybe tver ov + + liftE $ runBuildAction + workdir + (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do + let tmpInstallDir = fromGHCupPath workdir "out" + liftIO $ createDirRecursive' tmpInstallDir + + -- apply patches + liftE $ applyAnyPatch patches (fromGHCupPath workdir) + + -- set up project files + cp <- case cabalProject of + Just (Left cp) + | isAbsolute cp -> do + copyFileE cp (fromGHCupPath workdir "cabal.project") False + pure "cabal.project" + | otherwise -> pure (takeFileName cp) + Just (Right uri) -> do + tmpUnpack <- lift withGHCupTmpDir + cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False + copyFileE cp (fromGHCupPath workdir "cabal.project") False + pure "cabal.project" + Nothing -> pure "cabal.project" + forM_ cabalProjectLocal $ \uri -> do + tmpUnpack <- lift withGHCupTmpDir + cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False + copyFileE cpl (fromGHCupPath workdir cp <.> "local") False + artifacts <- forM (sort ghcs) $ \ghc -> do + let ghcInstallDir = tmpInstallDir T.unpack (prettyVer ghc) + liftIO $ createDirRecursive' tmpInstallDir + lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc + liftE $ lEM @_ @'[ProcessError] $ + execLogged "cabal" ( [ "v2-install" + , "-w" + , "ghc-" <> T.unpack (prettyVer ghc) + , "--install-method=copy" + ] ++ + maybe [] (\j -> ["--jobs=" <> show j]) jobs ++ + [ "--overwrite-policy=always" + , "--disable-profiling" + , "--disable-tests" + , "--installdir=" <> ghcInstallDir + , "--project-file=" <> cp + ] ++ fmap T.unpack cabalArgs ++ [ + "exe:haskell-language-server" + , "exe:haskell-language-server-wrapper"] + ) + (Just $ fromGHCupPath workdir) + "cabal" + Nothing + pure ghcInstallDir + + forM_ artifacts $ \artifact -> do + logInfo $ T.pack (show artifact) + liftIO $ renameFile (artifact "haskell-language-server" <.> exeExt) + (tmpInstallDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) + liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) + (tmpInstallDir "haskell-language-server-wrapper" <.> exeExt) + + case installDir of + IsolateDir isoDir -> do + lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir + liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True + GHCupInternal -> do + liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True + ) + + pure installVer + + + ----------------- + --[ Set/Unset ]-- + ----------------- + +-- | Set the haskell-language-server symlinks. +setHLS :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadMask m + , MonadFail m + , MonadUnliftIO m + ) + => Version + -> SetHLS + -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin + -- and don't want mess with other versions + -> Excepts '[NotInstalled] m () +setHLS ver shls mBinDir = do + whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))) + + -- symlink destination + binDir <- case mBinDir of + Just x -> pure x + Nothing -> do + Dirs {binDir = f} <- lift getDirs + pure f + + -- first delete the old symlinks + when (isNothing mBinDir) $ + case shls of + -- not for legacy + SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver + -- legacy and new + SetHLSOnly -> liftE rmPlainHLS + + case shls of + -- not for legacy + SetHLS_XYZ -> do + bins <- lift $ hlsInternalServerScripts ver Nothing + + forM_ bins $ \f -> do + let fname = takeFileName f + destL <- binarySymLinkDestination binDir f + let target = if "haskell-language-server-wrapper" `isPrefixOf` fname + then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt + else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt + lift $ createLink destL (binDir target) + + -- legacy and new + SetHLSOnly -> do + -- set haskell-language-server- symlinks + bins <- lift $ hlsServerBinaries ver Nothing + when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) + + forM_ bins $ \f -> do + let destL = f + let target = (<> exeExt) . head . splitOn "~" $ f + lift $ createLink destL (binDir target) + + -- set haskell-language-server-wrapper symlink + let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt + let wrapper = binDir "haskell-language-server-wrapper" <> exeExt + + lift $ createLink destL wrapper + + when (isNothing mBinDir) $ + lift warnAboutHlsCompatibility + + +unsetHLS :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetHLS = do + Dirs {..} <- getDirs + let wrapper = binDir "haskell-language-server-wrapper" <> exeExt + bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles' + binDir + (MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof) + forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir )) + hideError doesNotExistErrorType $ rmLink wrapper + + + + + --------------- + --[ Removal ]-- + --------------- + + +-- | Delete a hls version. Will try to fix the hls symlinks +-- after removal (e.g. setting it to an older version). +rmHLSVer :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled, UninstallFailed] m () +rmHLSVer ver = do + whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) + + isHlsSet <- lift hlsSet + + liftE $ rmMinorHLSSymlinks ver + + when (Just ver == isHlsSet) $ do + -- delete all set symlinks + liftE rmPlainHLS + + hlsDir' <- ghcupHLSDir ver + let hlsDir = fromGHCupPath hlsDir' + lift (getInstalledFiles HLS (mkTVer ver)) >>= \case + Just files -> do + lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir + forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> hlsDir dropDrive f)) + removeEmptyDirsRecursive hlsDir + survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir + f <- recordedInstallationFile HLS (mkTVer ver) + lift $ recycleFile f + when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors + Nothing -> do + lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir + recyclePathForcibly hlsDir' + + when (Just ver == isHlsSet) $ do + -- set latest hls + hlsVers <- lift $ fmap rights getInstalledHLSs + case headMay . reverse . sort $ hlsVers of + Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing + Nothing -> pure () diff --git a/lib/GHCup/List.hs b/lib/GHCup/List.hs new file mode 100644 index 0000000..91ba381 --- /dev/null +++ b/lib/GHCup/List.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.List +Description : Listing versions and tools +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.List where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude.Logger +import GHCup.Version + +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Data.Either +import Data.List +import Data.Maybe +import Data.Text ( Text ) +import Data.Versions hiding ( patch ) +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + + + + + + + + + + + ------------------ + --[ List tools ]-- + ------------------ + + +-- | Filter data type for 'listVersions'. +data ListCriteria = ListInstalled + | ListSet + | ListAvailable + deriving Show + +-- | A list result describes a single tool version +-- and various of its properties. +data ListResult = ListResult + { lTool :: Tool + , lVer :: Version + , lCross :: Maybe Text -- ^ currently only for GHC + , lTag :: [Tag] + , lInstalled :: Bool + , lSet :: Bool -- ^ currently active version + , fromSrc :: Bool -- ^ compiled from source + , lStray :: Bool -- ^ not in download info + , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch + , hlsPowered :: Bool + } + deriving (Eq, Ord, Show) + + +-- | Extract all available tool versions and their tags. +availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo +availableToolVersions av tool = view + (at tool % non Map.empty) + av + + +-- | List all versions from the download info, as well as stray +-- versions. +listVersions :: ( MonadCatch m + , HasLog env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + ) + => Maybe Tool + -> Maybe ListCriteria + -> m [ListResult] +listVersions lt' criteria = do + -- some annoying work to avoid too much repeated IO + cSet <- cabalSet + cabals <- getInstalledCabals + hlsSet' <- hlsSet + hlses <- getInstalledHLSs + sSet <- stackSet + stacks <- getInstalledStacks + + go lt' cSet cabals hlsSet' hlses sSet stacks + where + go lt cSet cabals hlsSet' hlses sSet stacks = do + case lt of + Just t -> do + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo + -- get versions from GHCupDownloads + let avTools = availableToolVersions dls t + lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) + + case t of + GHC -> do + slr <- strayGHCs avTools + pure (sort (slr ++ lr)) + Cabal -> do + slr <- strayCabals avTools cSet cabals + pure (sort (slr ++ lr)) + HLS -> do + slr <- strayHLS avTools hlsSet' hlses + pure (sort (slr ++ lr)) + Stack -> do + slr <- strayStacks avTools sSet stacks + pure (sort (slr ++ lr)) + GHCup -> do + let cg = maybeToList $ currentGHCup avTools + pure (sort (cg ++ lr)) + Nothing -> do + ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks + cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks + hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks + ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks + stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks + pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) + strayGHCs :: ( MonadCatch m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + ) + => Map.Map Version VersionInfo + -> m [ListResult] + strayGHCs avTools = do + ghcs <- getInstalledGHCs + fmap catMaybes $ forM ghcs $ \case + Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do + case Map.lookup _tvVersion avTools of + Just _ -> pure Nothing + Nothing -> do + lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing + fromSrc <- ghcSrcInstalled tver + hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions + pure $ Just $ ListResult + { lTool = GHC + , lVer = _tvVersion + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup _tvVersion avTools) + , lNoBindist = False + , .. + } + Right tver@GHCTargetVersion{ .. } -> do + lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget + fromSrc <- ghcSrcInstalled tver + hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions + pure $ Just $ ListResult + { lTool = GHC + , lVer = _tvVersion + , lCross = _tvTarget + , lTag = [] + , lInstalled = True + , lStray = True -- NOTE: cross currently cannot be installed via bindist + , lNoBindist = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + strayCabals :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , HasLog env + , MonadIO m + ) + => Map.Map Version VersionInfo + -> Maybe Version + -> [Either FilePath Version] + -> m [ListResult] + strayCabals avTools cSet cabals = do + fmap catMaybes $ forM cabals $ \case + Right ver -> + case Map.lookup ver avTools of + Just _ -> pure Nothing + Nothing -> do + let lSet = cSet == Just ver + pure $ Just $ ListResult + { lTool = Cabal + , lVer = ver + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup ver avTools) + , lNoBindist = False + , fromSrc = False -- actually, we don't know :> + , hlsPowered = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + strayHLS :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , HasLog env + , MonadIO m) + => Map.Map Version VersionInfo + -> Maybe Version + -> [Either FilePath Version] + -> m [ListResult] + strayHLS avTools hlsSet' hlss = do + fmap catMaybes $ forM hlss $ \case + Right ver -> + case Map.lookup ver avTools of + Just _ -> pure Nothing + Nothing -> do + let lSet = hlsSet' == Just ver + pure $ Just $ ListResult + { lTool = HLS + , lVer = ver + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup ver avTools) + , lNoBindist = False + , fromSrc = False -- actually, we don't know :> + , hlsPowered = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + strayStacks :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , HasLog env + , MonadIO m + ) + => Map.Map Version VersionInfo + -> Maybe Version + -> [Either FilePath Version] + -> m [ListResult] + strayStacks avTools stackSet' stacks = do + fmap catMaybes $ forM stacks $ \case + Right ver -> + case Map.lookup ver avTools of + Just _ -> pure Nothing + Nothing -> do + let lSet = stackSet' == Just ver + pure $ Just $ ListResult + { lTool = Stack + , lVer = ver + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup ver avTools) + , lNoBindist = False + , fromSrc = False -- actually, we don't know :> + , hlsPowered = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult + currentGHCup av = + let currentVer = fromJust $ pvpToVersion ghcUpVer "" + listVer = Map.lookup currentVer av + latestVer = fst <$> headOf (getTagged Latest) av + recommendedVer = fst <$> headOf (getTagged Latest) av + isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer + in if | Map.member currentVer av -> Nothing + | otherwise -> Just $ ListResult { lVer = currentVer + , lTag = maybe (if isOld then [Old] else []) _viTags listVer + , lCross = Nothing + , lTool = GHCup + , fromSrc = False + , lStray = isNothing listVer + , lSet = True + , lInstalled = True + , lNoBindist = False + , hlsPowered = False + } + + -- NOTE: this are not cross ones, because no bindists + toListResult :: ( HasLog env + , MonadReader env m + , HasDirs env + , HasGHCupInfo env + , HasPlatformReq env + , MonadIO m + , MonadCatch m + ) + => Tool + -> Maybe Version + -> [Either FilePath Version] + -> Maybe Version + -> [Either FilePath Version] + -> Maybe Version + -> [Either FilePath Version] + -> (Version, VersionInfo) + -> m ListResult + toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do + case t of + GHC -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v + let tver = mkTVer v + lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing + lInstalled <- ghcInstalled tver + fromSrc <- ghcSrcInstalled tver + hlsPowered <- fmap (elem v) hlsGHCVersions + pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } + Cabal -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v + let lSet = cSet == Just v + let lInstalled = elem v $ rights cabals + pure ListResult { lVer = v + , lCross = Nothing + , lTag = tags + , lTool = t + , fromSrc = False + , lStray = False + , hlsPowered = False + , .. + } + GHCup -> do + let lSet = prettyPVP ghcUpVer == prettyVer v + let lInstalled = lSet + pure ListResult { lVer = v + , lTag = tags + , lCross = Nothing + , lTool = t + , fromSrc = False + , lStray = False + , lNoBindist = False + , hlsPowered = False + , .. + } + HLS -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v + let lSet = hlsSet' == Just v + let lInstalled = elem v $ rights hlses + pure ListResult { lVer = v + , lCross = Nothing + , lTag = tags + , lTool = t + , fromSrc = False + , lStray = False + , hlsPowered = False + , .. + } + Stack -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v + let lSet = stackSet' == Just v + let lInstalled = elem v $ rights stacks + pure ListResult { lVer = v + , lCross = Nothing + , lTag = tags + , lTool = t + , fromSrc = False + , lStray = False + , hlsPowered = False + , .. + } + + + filter' :: [ListResult] -> [ListResult] + filter' lr = case criteria of + Nothing -> lr + Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr + Just ListSet -> filter (\ListResult {..} -> lSet) lr + Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr + diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index 62cf01f..58722af 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -23,10 +23,11 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ +import GHCup.Utils.Dirs +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -46,7 +47,6 @@ import Prelude hiding ( abs , writeFile ) import System.Info -import System.Directory import System.OsRelease import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs new file mode 100644 index 0000000..63c2490 --- /dev/null +++ b/lib/GHCup/Prelude.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : GHCup.Prelude +Description : MegaParsec utilities +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable + +GHCup specific prelude. Lots of Excepts functionality. +-} +module GHCup.Prelude + (module GHCup.Prelude, + module GHCup.Prelude.Internal, +#if defined(IS_WINDOWS) + module GHCup.Prelude.Windows +#else + module GHCup.Prelude.Posix +#endif + ) +where + +import GHCup.Prelude.Internal +import GHCup.Types.Optics (HasLog) +import GHCup.Prelude.Logger (logWarn) +#if defined(IS_WINDOWS) +import GHCup.Prelude.Windows +#else +import GHCup.Prelude.Posix +#endif + +import Control.Monad.IO.Class +import Control.Monad.Reader +import Haskus.Utils.Variant.Excepts +import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) +import qualified Data.Text as T + + + +-- for some obscure reason... this won't type-check if we move it to a different module +catchWarn :: forall es m env . ( Pretty (V es) + , MonadReader env m + , HasLog env + , MonadIO m + , Monad m) => Excepts es m () -> Excepts '[] m () +catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v)) + diff --git a/lib/GHCup/Prelude/File.hs b/lib/GHCup/Prelude/File.hs new file mode 100644 index 0000000..a79cd10 --- /dev/null +++ b/lib/GHCup/Prelude/File.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module GHCup.Prelude.File ( + mergeFileTree, + copyFileE, + findFilesDeep, + getDirectoryContentsRecursive, + getDirectoryContentsRecursiveBFS, + getDirectoryContentsRecursiveDFS, + getDirectoryContentsRecursiveUnsafe, + getDirectoryContentsRecursiveBFSUnsafe, + getDirectoryContentsRecursiveDFSUnsafe, + recordedInstallationFile, + module GHCup.Prelude.File.Search, + + chmod_755, + isBrokenSymlink, + copyFile, + deleteFile, + install, + removeEmptyDirectory, + removeDirIfEmptyOrIsSymlink, + removeEmptyDirsRecursive, + rmFileForce, + createDirRecursive', + recyclePathForcibly, + rmDirectory, + recycleFile, + rmFile, + rmDirectoryLink, + moveFilePortable, + moveFile, + rmPathForcibly, + + exeExt, + exeExt', + getLinkTarget, + pathIsLink, + rmLink, + createLink +) where + +import GHCup.Utils.Dirs +import GHCup.Prelude.Logger.Internal (logInfo, logDebug) +import GHCup.Prelude.Internal +import GHCup.Prelude.File.Search +#if IS_WINDOWS +import GHCup.Prelude.File.Windows +import GHCup.Prelude.Windows +#else +import GHCup.Prelude.File.Posix +import GHCup.Prelude.Posix +#endif +import GHCup.Errors +import GHCup.Types +import GHCup.Types.Optics + +import Text.Regex.Posix +import Control.Monad.IO.Unlift ( MonadUnliftIO ) +import Control.Exception.Safe +import Control.Monad.Reader +import Data.ByteString ( ByteString ) +import Haskus.Utils.Variant.Excepts +import System.FilePath +import Text.PrettyPrint.HughesPJClass (prettyShow) + +import qualified Data.Text as T +import qualified Streamly.Prelude as S +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import GHC.IO.Exception +import System.IO.Error + + +-- | Merge one file tree to another given a copy operation. +-- +-- Records every successfully installed file into the destination +-- returned by 'recordedInstallationFile'. +-- +-- If any copy operation fails, the record file is deleted, as well +-- as the partially installed files. +mergeFileTree :: ( MonadMask m + , S.MonadAsync m + , MonadReader env m + , HasDirs env + , HasLog env + , MonadCatch m + ) + => GHCupPath -- ^ source base directory from which to install findFiles + -> InstallDirResolved -- ^ destination base dir + -> Tool + -> GHCTargetVersion + -> (FilePath -> FilePath -> m ()) -- ^ file copy operation + -> Excepts '[MergeFileTreeError] m () +mergeFileTree _ (GHCupBinDir fp) _ _ _ = + throwIO $ userError ("mergeFileTree: internal error, called on " <> fp) +mergeFileTree sourceBase destBase tool v' copyOp = do + lift $ logInfo $ "Merging file tree from \"" + <> T.pack (fromGHCupPath sourceBase) + <> "\" to \"" + <> T.pack (fromInstallDir destBase) + <> "\"" + recFile <- recordedInstallationFile tool v' + + wrapInExcepts $ do + -- These checks are not atomic, but we perform them to have + -- the opportunity to abort before copying has started. + -- + -- The actual copying might still fail. + liftIO $ baseCheck (fromGHCupPath sourceBase) + liftIO $ destCheck (fromInstallDir destBase) + + -- we only record for non-isolated installs + when (isSafeDir destBase) $ do + whenM (liftIO $ doesFileExist recFile) + $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!") + liftIO $ createDirectoryIfMissing True (takeDirectory recFile) + + -- we want the cleanup action to leak through in case of exception + onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do + logDebug "Starting merge" + lift $ flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do + copy f + logDebug $ T.pack "Recording installed file: " <> T.pack f + recordInstalledFile f recFile + pure f + + where + wrapInExcepts = handleIO (\e -> throwE $ MergeFileTreeError e (fromGHCupPath sourceBase) (fromInstallDir destBase)) + + cleanupOnPartialInstall recFile = when (isSafeDir destBase) $ do + (force -> !l) <- hideErrorDef [NoSuchThing] [] $ lines <$> liftIO + (readFile recFile >>= evaluate) + logDebug "Deleting recorded files due to partial install" + forM_ l $ \f -> do + let dest = fromInstallDir destBase dropDrive f + logDebug $ "rm -f " <> T.pack f + hideError NoSuchThing $ rmFile dest + pure () + logDebug $ "rm -f " <> T.pack recFile + hideError NoSuchThing $ rmFile recFile + logDebug $ "rm -f " <> T.pack (fromInstallDir destBase) + hideError UnsatisfiedConstraints $ hideError NoSuchThing $ + removeEmptyDirsRecursive (fromInstallDir destBase) + + + recordInstalledFile f recFile = when (isSafeDir destBase) $ + liftIO $ appendFile recFile (f <> "\n") + + copy source = do + let dest = fromInstallDir destBase source + src = fromGHCupPath sourceBase source + + when (isAbsolute source) + $ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!") + + liftIO . createDirectoryIfMissing True . takeDirectory $ dest + + copyOp src dest + + + baseCheck src = do + when (isRelative src) + $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " is not absolute!") + whenM (not <$> doesDirectoryExist src) + $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " does not exist!") + destCheck dest = do + when (isRelative dest) + $ throwIO $ userError ("mergeFileTree: destination base directory " <> dest <> " is not absolute!") + + + +copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m () +copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to + + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +-- +-- depth first +getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m) + => GHCupPath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp + +-- breadth first +getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m) + => GHCupPath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp + + +getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m) + => GHCupPath + -> S.SerialT m FilePath +getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS + +getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe + +findFilesDeep :: GHCupPath -> Regex -> IO [FilePath] +findFilesDeep path regex = + S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path + + +recordedInstallationFile :: ( MonadReader env m + , HasDirs env + ) + => Tool + -> GHCTargetVersion + -> m FilePath +recordedInstallationFile t v' = do + Dirs {..} <- getDirs + pure (fromGHCupPath dbDir prettyShow t T.unpack (tVerToText v')) + +removeDirIfEmptyOrIsSymlink :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () +removeDirIfEmptyOrIsSymlink filepath = + hideError UnsatisfiedConstraints $ + handleIO' InappropriateType + (handleIfSym filepath) + (liftIO $ removeEmptyDirectory filepath) + where + handleIfSym fp e = do + isSym <- liftIO $ pathIsSymbolicLink fp + if isSym + then rmFileForce fp + else liftIO $ ioError e + +removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () +removeEmptyDirsRecursive = go + where + go fp = do + cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp ) + forM_ cs go + liftIO $ removeEmptyDirectory fp + +rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m () +rmFileForce filepath = do + hideError doesNotExistErrorType + $ hideError InappropriateType $ rmFile filepath + +-- | More permissive version of 'createDirRecursive'. This doesn't +-- error when the destination is a symlink to a directory. +createDirRecursive' :: FilePath -> IO () +createDirRecursive' p = + handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e) + . createDirectoryIfMissing True + $ p + + where + isSymlinkDir e = do + ft <- pathIsSymbolicLink p + case ft of + True -> do + rp <- canonicalizePath p + rft <- doesDirectoryExist rp + case rft of + True -> pure () + _ -> throwIO e + _ -> throwIO e + + +-- https://github.com/haskell/directory/issues/110 +-- https://github.com/haskell/directory/issues/96 +-- https://www.sqlite.org/src/info/89f1848d7f +recyclePathForcibly :: ( MonadIO m + , MonadReader env m + , HasDirs env + , MonadMask m + ) + => GHCupPath + -> m () +recyclePathForcibly fp + | isWindows = do + Dirs { recycleDir } <- getDirs + tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly" + let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp) + liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest)) + `catch` + (\e -> if | isDoesNotExistError e -> pure () + | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp) + | otherwise -> throwIO e) + `finally` + liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) + | otherwise = liftIO $ removePathForcibly fp + + + +rmDirectory :: (MonadIO m, MonadMask m) + => GHCupPath + -> m () +rmDirectory fp + | isWindows = recover (liftIO $ removeDirectory fp) + | otherwise = liftIO $ removeDirectory fp + + +-- https://www.sqlite.org/src/info/89f1848d7f +-- https://github.com/haskell/directory/issues/96 +recycleFile :: ( MonadIO m + , MonadMask m + , MonadReader env m + , HasDirs env + ) + => FilePath + -> m () +recycleFile fp + | isWindows = do + Dirs { recycleDir } <- getDirs + liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp)) + tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile" + let dest = fromGHCupPath tmp takeFileName fp + liftIO (moveFile fp dest) + `catch` + (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e) + `finally` + liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) + | otherwise = liftIO $ removeFile fp + + +rmFile :: ( MonadIO m + , MonadMask m + ) + => FilePath + -> m () +rmFile fp + | isWindows = recover (liftIO $ removeFile fp) + | otherwise = liftIO $ removeFile fp + + +rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) + => FilePath + -> m () +rmDirectoryLink fp + | isWindows = recover (liftIO $ removeDirectoryLink fp) + | otherwise = liftIO $ removeDirectoryLink fp + + +rmPathForcibly :: ( MonadIO m + , MonadMask m + ) + => GHCupPath + -> m () +rmPathForcibly fp + | isWindows = recover (liftIO $ removePathForcibly fp) + | otherwise = liftIO $ removePathForcibly fp + + +-- | The file extension for executables. +exeExt :: String +exeExt + | isWindows = ".exe" + | otherwise = "" + +-- | The file extension for executables. +exeExt' :: ByteString +exeExt' + | isWindows = ".exe" + | otherwise = "" + + +rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m () +rmLink fp + | isWindows = do + hideError doesNotExistErrorType . recycleFile $ fp + hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim") + | otherwise = hideError doesNotExistErrorType . recycleFile $ fp + + +-- | Creates a symbolic link on unix and a fake symlink on windows for +-- executables, which: +-- 1. is a shim exe +-- 2. has a corresponding .shim file in the same directory that +-- contains the target +-- +-- This overwrites previously existing files. +-- +-- On windows, this requires that 'ensureGlobalTools' was run beforehand. +createLink :: ( MonadMask m + , MonadThrow m + , HasLog env + , MonadIO m + , MonadReader env m + , HasDirs env + , MonadUnliftIO m + , MonadFail m + ) + => FilePath -- ^ path to the target executable + -> FilePath -- ^ path to be created + -> m () +createLink link exe + | isWindows = do + dirs <- getDirs + let shimGen = fromGHCupPath (cacheDir dirs) "gs.exe" + + let shim = dropExtension exe <.> "shim" + -- For hardlinks, link needs to be absolute. + -- If link is relative, it's relative to the target exe. + -- Note that () drops lhs when rhs is absolute. + fullLink = takeDirectory exe link + shimContents = "path = " <> fullLink + + logDebug $ "rm -f " <> T.pack exe + rmLink exe + + logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe + liftIO $ copyFile shimGen exe False + liftIO $ writeFile shim shimContents + | otherwise = do + logDebug $ "rm -f " <> T.pack exe + hideError doesNotExistErrorType $ recycleFile exe + + logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe + liftIO $ createFileLink link exe diff --git a/lib/GHCup/Prelude/File/Posix.hs b/lib/GHCup/Prelude/File/Posix.hs new file mode 100644 index 0000000..1b774ac --- /dev/null +++ b/lib/GHCup/Prelude/File/Posix.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CApiFFI #-} + +{-| +Module : GHCup.Utils.File.Posix +Description : File and directory handling for unix +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : POSIX +-} +module GHCup.Prelude.File.Posix where + +import GHCup.Prelude.File.Posix.Traversals + +import Control.Exception.Safe +import Control.Monad.Reader +import Foreign.C.String +import Foreign.C.Error +import Foreign.C.Types +import System.IO ( hClose, hSetBinaryMode ) +import System.IO.Error hiding ( catchIOError ) +import System.FilePath +import System.Directory ( removeFile, pathIsSymbolicLink, getSymbolicLinkTarget, doesPathExist ) +import System.Posix.Directory +import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) +import System.Posix.Internals ( withFilePath ) +import System.Posix.Files +import System.Posix.Types + + +import qualified System.Posix.Directory as PD +import qualified System.Posix.Files as PF +import qualified System.Posix.IO as SPI +import qualified System.Posix as Posix +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Internal.FileSystem.Handle + as IFH +import qualified Streamly.Prelude as S +import qualified GHCup.Prelude.File.Posix.Foreign as FD +import qualified Streamly.Internal.Data.Stream.StreamD.Type + as D +import Streamly.Internal.Data.Unfold.Type +import qualified Streamly.Internal.Data.Unfold as U +import Streamly.Internal.Control.Concurrent ( withRunInIO ) +import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) + + +-- | On unix, we can use symlinks, so we just get the +-- symbolic link target. +-- +-- On windows, we have to emulate symlinks via shims, +-- see 'createLink'. +getLinkTarget :: FilePath -> IO FilePath +getLinkTarget = getSymbolicLinkTarget + + +-- | Checks whether the path is a link. +pathIsLink :: FilePath -> IO Bool +pathIsLink = pathIsSymbolicLink + + +chmod_755 :: MonadIO m => FilePath -> m () +chmod_755 fp = do + let exe_mode = + nullFileMode + `unionFileModes` ownerExecuteMode + `unionFileModes` ownerReadMode + `unionFileModes` ownerWriteMode + `unionFileModes` groupExecuteMode + `unionFileModes` groupReadMode + `unionFileModes` otherExecuteMode + `unionFileModes` otherReadMode + liftIO $ setFileMode fp exe_mode + + +-- |Default permissions for a new file. +newFilePerms :: FileMode +newFilePerms = + ownerWriteMode + `unionFileModes` ownerReadMode + `unionFileModes` groupWriteMode + `unionFileModes` groupReadMode + `unionFileModes` otherWriteMode + `unionFileModes` otherReadMode + + +-- | Checks whether the binary is a broken link. +isBrokenSymlink :: FilePath -> IO Bool +isBrokenSymlink fp = do + try (pathIsSymbolicLink fp) >>= \case + Right True -> do + let symDir = takeDirectory fp + tfp <- getSymbolicLinkTarget fp + not <$> doesPathExist + -- this drops 'symDir' if 'tfp' is absolute + (symDir tfp) + Right b -> pure b + Left e | isDoesNotExistError e -> pure False + | otherwise -> throwIO e + +copyFile :: FilePath -- ^ source file + -> FilePath -- ^ destination file + -> Bool -- ^ fail if file exists + -> IO () +copyFile from to fail' = do + bracket + (openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing) + (hClose . snd) + $ \(fromFd, fH) -> do + sourceFileMode <- fileMode <$> getFdStatus fromFd + let dflags = [ FD.oNofollow + , if fail' then FD.oExcl else FD.oTrunc + ] + bracket + (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode) + (hClose . snd) + $ \(_, tH) -> do + hSetBinaryMode fH True + hSetBinaryMode tH True + streamlyCopy (fH, tH) + where + openFdHandle fp omode flags fM = do + fd <- openFd' fp omode flags fM + handle' <- SPI.fdToHandle fd + pure (fd, handle') + streamlyCopy (fH, tH) = + S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH + +foreign import capi unsafe "fcntl.h open" + c_open :: CString -> CInt -> Posix.CMode -> IO CInt + + +open_ :: CString + -> Posix.OpenMode + -> [FD.Flags] + -> Maybe Posix.FileMode + -> IO Posix.Fd +open_ str how optional_flags maybe_mode = do + fd <- c_open str all_flags mode_w + return (Posix.Fd fd) + where + all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat + + + (creat, mode_w) = case maybe_mode of + Nothing -> ([],0) + Just x -> ([FD.oCreat], x) + + open_mode = case how of + Posix.ReadOnly -> FD.oRdonly + Posix.WriteOnly -> FD.oWronly + Posix.ReadWrite -> FD.oRdwr + + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +-- +-- Note that passing @Just x@ as the 4th argument triggers the +-- `oCreat` status flag, which must be set when you pass in `oExcl` +-- to the status flags. Also see the manpage for @open(2)@. +openFd' :: FilePath + -> Posix.OpenMode + -> [FD.Flags] -- ^ status flags of @open(2)@ + -> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist. + -> IO Posix.Fd +openFd' name how optional_flags maybe_mode = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how optional_flags maybe_mode + + +-- |Deletes the given file. Raises `eISDIR` +-- if run on a directory. Does not follow symbolic links. +-- +-- Throws: +-- +-- - `InappropriateType` for wrong file type (directory) +-- - `NoSuchThing` if the file does not exist +-- - `PermissionDenied` if the directory cannot be read +-- +-- Notes: calls `unlink` +deleteFile :: FilePath -> IO () +deleteFile = removeLink + + +-- |Recreate a symlink. +-- +-- In `Overwrite` copy mode only files and empty directories are deleted. +-- +-- Safety/reliability concerns: +-- +-- * `Overwrite` mode is inherently non-atomic +-- +-- Throws: +-- +-- - `InvalidArgument` if source file is wrong type (not a symlink) +-- - `PermissionDenied` if output directory cannot be written to +-- - `PermissionDenied` if source directory cannot be opened +-- - `SameFile` if source and destination are the same file +-- (`HPathIOException`) +-- +-- +-- Throws in `Strict` mode only: +-- +-- - `AlreadyExists` if destination already exists +-- +-- Throws in `Overwrite` mode only: +-- +-- - `UnsatisfiedConstraints` if destination file is non-empty directory +-- +-- Notes: +-- +-- - calls `symlink` +recreateSymlink :: FilePath -- ^ the old symlink file + -> FilePath -- ^ destination file + -> Bool -- ^ fail if destination file exists + -> IO () +recreateSymlink symsource newsym fail' = do + sympoint <- readSymbolicLink symsource + case fail' of + True -> pure () + False -> + handleIO (\e -> if doesNotExistErrorType == ioeGetErrorType e then pure () else liftIO . ioError $ e) $ deleteFile newsym + createSymbolicLink sympoint newsym + + +-- copys files, recreates symlinks, fails on all other types +install :: FilePath -> FilePath -> Bool -> IO () +install from to fail' = do + fs <- PF.getSymbolicLinkStatus from + decide fs + where + decide fs | PF.isRegularFile fs = copyFile from to fail' + | PF.isSymbolicLink fs = recreateSymlink from to fail' + | otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from) + +moveFile :: FilePath -> FilePath -> IO () +moveFile = rename + + +moveFilePortable :: FilePath -> FilePath -> IO () +moveFilePortable from to = do + catchErrno [eXDEV] (moveFile from to) $ do + copyFile from to True + removeFile from + + +catchErrno :: [Errno] -- ^ errno to catch + -> IO a -- ^ action to try, which can raise an IOException + -> IO a -- ^ action to carry out in case of an IOException and + -- if errno matches + -> IO a +catchErrno en a1 a2 = + catchIOError a1 $ \e -> do + errno <- getErrno + if errno `elem` en + then a2 + else ioError e + +removeEmptyDirectory :: FilePath -> IO () +removeEmptyDirectory = PD.removeDirectory + + +-- | Create an 'Unfold' of directory contents. +unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) +unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return) + where + {-# INLINE [0] step #-} + step dirstream = do + (typ, e) <- liftIO $ readDirEnt dirstream + return $ if + | null e -> D.Stop + | "." == e -> D.Skip dirstream + | ".." == e -> D.Skip dirstream + | otherwise -> D.Yield (typ, e) dirstream + + +getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveDFSUnsafe fp = go "" + where + go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> + if | t == FD.dtDir -> go (cd f) + | otherwise -> pure (cd f) + + +getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath +getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""])) + where + {-# INLINE [0] step #-} + step (_, Nothing, []) = return D.Stop + + step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do + (dt, f) <- liftIO $ readDirEnt dirstream + if | FD.dtUnknown == dt -> do + runIOFinalizer finalizer + return $ D.Skip (topdir, Nothing, dirs) + | f == "." || f == ".." + -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs) + | FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir f):dirs) + | otherwise -> return $ D.Yield (cdir f) (topdir, Just (cdir, dirstream, finalizer), dirs) + + step (topdir, Nothing, dir:dirs) = do + (s, f) <- acquire (topdir dir) + return $ D.Skip (topdir, Just (dir, s, f), dirs) + + acquire dir = + withRunInIO $ \run -> mask_ $ run $ do + dirstream <- liftIO $ openDirStream dir + ref <- newIOFinalizer (liftIO $ closeDirStream dirstream) + return (dirstream, ref) + +getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold + + diff --git a/lib/GHCup/Prelude/File/Posix/Foreign.hsc b/lib/GHCup/Prelude/File/Posix/Foreign.hsc new file mode 100644 index 0000000..ed3f696 --- /dev/null +++ b/lib/GHCup/Prelude/File/Posix/Foreign.hsc @@ -0,0 +1,58 @@ +{-# LANGUAGE PatternSynonyms #-} + +module GHCup.Prelude.File.Posix.Foreign where + +import Data.Bits +import Data.List (foldl') +import Foreign.C.Types + +#include +#include +#include +#include +#include +#include + +newtype DirType = DirType Int deriving (Eq, Show) +data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show) + +unFlags :: Flags -> Int +unFlags (Flags i) = i +unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform") + +-- |Returns @True@ if posix-paths was compiled with support for the provided +-- flag. (As of this writing, the only flag for which this check may be +-- necessary is 'oCloexec'; all other flags will always yield @True@.) +isSupported :: Flags -> Bool +isSupported (Flags _) = True +isSupported _ = False + +-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use +-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was +-- compiled into your version of posix-paths. (If not, using @oCloexec@ will +-- throw an exception.) +oCloexec :: Flags +#ifdef O_CLOEXEC +oCloexec = Flags #{const O_CLOEXEC} +#else +{-# WARNING oCloexec + "This version of posix-paths was compiled without @O_CLOEXEC@ support." #-} +oCloexec = UnsupportedFlag "O_CLOEXEC" +#endif + + + +-- If these enum declarations occur earlier in the file, haddock +-- gets royally confused about the above doc comments. +-- Probably http://trac.haskell.org/haddock/ticket/138 + +#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN} + +#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC} + +pathMax :: Int +pathMax = #{const PATH_MAX} + +unionFlags :: [Flags] -> CInt +unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0 + diff --git a/lib/GHCup/Prelude/File/Posix/Traversals.hs b/lib/GHCup/Prelude/File/Posix/Traversals.hs new file mode 100644 index 0000000..f3a0490 --- /dev/null +++ b/lib/GHCup/Prelude/File/Posix/Traversals.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} + + +module GHCup.Prelude.File.Posix.Traversals ( +-- lower-level stuff + readDirEnt +, unpackDirStream +) where + + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import GHCup.Prelude.File.Posix.Foreign + +import Unsafe.Coerce (unsafeCoerce) +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable +import System.Posix +import Foreign (alloca) +import System.Posix.Internals (peekFilePath) + + + + + +---------------------------------------------------------- +-- dodgy stuff + +type CDir = () +type CDirent = () + +-- Posix doesn't export DirStream, so to re-use that type we need to use +-- unsafeCoerce. It's just a newtype, so this is a legitimate usage. +-- ugly trick. +unpackDirStream :: DirStream -> Ptr CDir +unpackDirStream = unsafeCoerce + +-- the __hscore_* functions are defined in the unix package. We can import them and let +-- the linker figure it out. +foreign import ccall unsafe "__hscore_readdir" + c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_free_dirent" + c_freeDirEnt :: Ptr CDirent -> IO () + +foreign import ccall unsafe "__hscore_d_name" + c_name :: Ptr CDirent -> IO CString + +foreign import ccall unsafe "__posixdir_d_type" + c_type :: Ptr CDirent -> IO DirType + +---------------------------------------------------------- +-- less dodgy but still lower-level + + +readDirEnt :: DirStream -> IO (DirType, FilePath) +readDirEnt (unpackDirStream -> dirp) = + alloca $ \ptr_dEnt -> loop ptr_dEnt + where + loop ptr_dEnt = do + resetErrno + r <- c_readdir dirp ptr_dEnt + if r == 0 + then do + dEnt <- peek ptr_dEnt + if dEnt == nullPtr + then return (dtUnknown, mempty) + else do + dName <- c_name dEnt >>= peekFilePath + dType <- c_type dEnt + c_freeDirEnt dEnt + return (dType, dName) + else do + errno <- getErrno + if errno == eINTR + then loop ptr_dEnt + else do + let (Errno eo) = errno + if eo == 0 + then return (dtUnknown, mempty) + else throwErrno "readDirEnt" + diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Prelude/File/Search.hs similarity index 78% rename from lib/GHCup/Utils/File/Common.hs rename to lib/GHCup/Prelude/File/Search.hs index 4818fa9..6a667c5 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Prelude/File/Search.hs @@ -1,13 +1,13 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -module GHCup.Utils.File.Common ( - module GHCup.Utils.File.Common +module GHCup.Prelude.File.Search ( + module GHCup.Prelude.File.Search , ProcessError(..) , CapturedProcess(..) ) where -import GHCup.Utils.Prelude import GHCup.Types(ProcessError(..), CapturedProcess(..)) import Control.Monad.Reader @@ -15,15 +15,19 @@ import Data.Maybe import Data.Text ( Text ) import Data.Void import GHC.IO.Exception -import Optics hiding ((<|), (|>)) -import System.Directory hiding (findFiles) +import System.Directory hiding ( removeDirectory + , removeDirectoryRecursive + , removePathForcibly + , findFiles + ) import System.FilePath -import Text.PrettyPrint.HughesPJClass hiding ( (<>) ) import Text.Regex.Posix + import qualified Data.Text as T -import qualified Data.ByteString.Lazy as BL import qualified Text.Megaparsec as MP +import Control.Exception.Safe (handleIO) +import System.Directory.Internal.Prelude (ioeGetErrorType) @@ -35,7 +39,7 @@ searchPath paths needle = go paths where go [] = pure Nothing go (x : xs) = - hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs) + handleIO (\e -> if ioeGetErrorType e `elem` [InappropriateType, PermissionDenied, NoSuchThing] then go xs else ioError e) $ do contents <- listDirectory x findM (isMatch x) contents >>= \case @@ -49,6 +53,12 @@ searchPath paths needle = go paths isExecutable :: FilePath -> IO Bool isExecutable file = executable <$> getPermissions file + -- TODO: inlined from GHCup.Prelude + findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing) + ifM ~b ~t ~f = do + b' <- b + if b' then t else f + -- | Check wether a binary is shadowed by another one that comes before -- it in PATH. Returns the path to said binary, if any. @@ -96,10 +106,6 @@ findFiles path regex = do contents <- listDirectory path pure $ filter (match regex) contents -findFilesDeep :: FilePath -> Regex -> IO [FilePath] -findFilesDeep path regex = do - contents <- getDirectoryContentsRecursive path - pure $ filter (match regex) contents findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath] findFiles' path parser = do @@ -107,5 +113,3 @@ findFiles' path parser = do pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents -checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool -checkFileAlreadyExists fp = liftIO $ doesFileExist fp diff --git a/lib/GHCup/Prelude/File/Windows.hs b/lib/GHCup/Prelude/File/Windows.hs new file mode 100644 index 0000000..acfca8b --- /dev/null +++ b/lib/GHCup/Prelude/File/Windows.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} + +{-| +Module : GHCup.Utils.File.Windows +Description : File and directory handling for windows +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : Windows +-} +module GHCup.Prelude.File.Windows where + +import GHCup.Utils.Dirs +import GHCup.Prelude.Internal + +import Control.Exception.Safe +import Control.Monad +import Control.Monad.Reader +import Data.List +import qualified GHC.Unicode as U +import System.FilePath +import qualified System.IO.Error as IOE + +import qualified System.Win32.Info as WS +import qualified System.Win32.File as WS + +import qualified Streamly.Internal.Data.Stream.StreamD.Type + as D +import Streamly.Internal.Data.Unfold.Type hiding ( concatMap ) +import Data.Bits ((.&.)) +import qualified Streamly.Prelude as S +import qualified Streamly.Internal.Data.Unfold as U +import Streamly.Internal.Control.Concurrent ( withRunInIO ) +import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) + + + +-- | On unix, we can use symlinks, so we just get the +-- symbolic link target. +-- +-- On windows, we have to emulate symlinks via shims, +-- see 'createLink'. +getLinkTarget :: FilePath -> IO FilePath +getLinkTarget fp = do + content <- readFile (dropExtension fp <.> "shim") + [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content + pure $ stripNewline $ dropPrefix "path = " p + + +-- | Checks whether the path is a link. +pathIsLink :: FilePath -> IO Bool +pathIsLink fp = doesPathExist (dropExtension fp <.> "shim") + + + +chmod_755 :: MonadIO m => FilePath -> m () +chmod_755 fp = + let perm = setOwnerWritable True emptyPermissions + in liftIO $ setPermissions fp perm + + +-- | Checks whether the binary is a broken link. +isBrokenSymlink :: FilePath -> IO Bool +isBrokenSymlink fp = do + b <- pathIsLink fp + if b + then do + tfp <- getLinkTarget fp + not <$> doesPathExist + -- this drops 'symDir' if 'tfp' is absolute + (takeDirectory fp tfp) + else pure False + + +copyFile :: FilePath -- ^ source file + -> FilePath -- ^ destination file + -> Bool -- ^ fail if file exists + -> IO () +copyFile = WS.copyFile + +deleteFile :: FilePath -> IO () +deleteFile = WS.deleteFile + + +install :: FilePath -> FilePath -> Bool -> IO () +install = copyFile + + +moveFile :: FilePath -> FilePath -> IO () +moveFile from to = WS.moveFileEx from (Just to) 0 + + +moveFilePortable :: FilePath -> FilePath -> IO () +moveFilePortable = WS.moveFile + + +removeEmptyDirectory :: FilePath -> IO () +removeEmptyDirectory = WS.removeDirectory + + +unfoldDirContents :: (S.MonadAsync m, MonadIO m, MonadCatch m, MonadMask m) => Unfold m FilePath (WS.FileAttributeOrFlag, FilePath) +unfoldDirContents = U.bracket alloc dealloc (Unfold step return) + where + {-# INLINE [0] step #-} + step (_, False, _, _) = return D.Stop + step (topdir, True, h, fd) = flip onException (liftIO $ WS.findClose h) $ do + f <- liftIO $ WS.getFindDataFileName fd + more <- liftIO $ WS.findNextFile h fd + + -- can't get file attribute from FindData yet (needs Win32 PR) + fattr <- liftIO $ WS.getFileAttributes (topdir f) + + if | f == "." || f == ".." -> return $ D.Skip (topdir, more, h, fd) + | otherwise -> return $ D.Yield (fattr, f) (topdir, more, h, fd) + + alloc topdir = do + query <- liftIO $ furnishPath (topdir "*") + (h, fd) <- liftIO $ WS.findFirstFile query + pure (topdir, True, h, fd) + + dealloc (_, _, fd, _) = liftIO $ WS.findClose fd + + +getDirectoryContentsRecursiveDFSUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m, S.IsStream t) + => FilePath + -> t m FilePath +getDirectoryContentsRecursiveDFSUnsafe fp = go "" + where + isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0 + + go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> + if | isDir t -> go (cd f) + | otherwise -> pure (cd f) + + +getDirectoryContentsRecursiveUnfold :: (MonadCatch m, S.MonadAsync m, MonadMask m) => Unfold m FilePath FilePath +getDirectoryContentsRecursiveUnfold = Unfold step init' + where + {-# INLINE [0] step #-} + step (_, Nothing, []) = return D.Stop + + step (topdir, state@(Just (cdir, (h, findData, ref))), dirs) = flip onException (runIOFinalizer ref) $ do + f <- liftIO $ WS.getFindDataFileName findData + + more <- liftIO $ WS.findNextFile h findData + when (not more) $ runIOFinalizer ref + let nextState = if more then state else Nothing + + -- can't get file attribute from FindData yet (needs Win32 PR) + fattr <- liftIO $ WS.getFileAttributes (topdir cdir f) + + if | f == "." || f == ".." -> return $ D.Skip (topdir, nextState, dirs) + | isDir fattr -> return $ D.Skip (topdir, nextState, (cdir f):dirs) + | otherwise -> return $ D.Yield (cdir f) (topdir, nextState, dirs) + + step (topdir, Nothing, dir:dirs) = do + (h, findData, ref) <- acquire (topdir dir) + return $ D.Skip (topdir, Just (dir, (h, findData, ref)), dirs) + + init' topdir = do + (h, findData, ref) <- acquire topdir + return (topdir, Just ("", (h, findData, ref)), []) + + isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0 + + acquire dir = do + query <- liftIO $ furnishPath (dir "*") + withRunInIO $ \run -> mask_ $ run $ do + (h, findData) <- liftIO $ WS.findFirstFile query + ref <- newIOFinalizer (liftIO $ WS.findClose h) + return (h, findData, ref) + + +getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold + + + + -------------------------------------- + --[ Inlined from directory package ]-- + -------------------------------------- + + +furnishPath :: FilePath -> IO FilePath +furnishPath path = + (toExtendedLengthPath <$> rawPrependCurrentDirectory path) + `IOE.catchIOError` \ _ -> + pure path + + +toExtendedLengthPath :: FilePath -> FilePath +toExtendedLengthPath path + | isRelative path = simplifiedPath + | otherwise = + case simplifiedPath of + '\\' : '?' : '?' : '\\' : _ -> simplifiedPath + '\\' : '\\' : '?' : '\\' : _ -> simplifiedPath + '\\' : '\\' : '.' : '\\' : _ -> simplifiedPath + '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath + _ -> "\\\\?\\" <> simplifiedPath + where simplifiedPath = simplify path + + +simplify :: FilePath -> FilePath +simplify = simplifyWindows + +simplifyWindows :: FilePath -> FilePath +simplifyWindows "" = "" +simplifyWindows path = + case drive' of + "\\\\?\\" -> drive' <> subpath + _ -> simplifiedPath + where + simplifiedPath = joinDrive drive' subpath' + (drive, subpath) = splitDrive path + drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive)) + subpath' = appendSep . avoidEmpty . prependSep . joinPath . + stripPardirs . expandDots . skipSeps . + splitDirectories $ subpath + + upperDrive d = case d of + c : ':' : s | U.isAlpha c && all isPathSeparator s -> U.toUpper c : ':' : s + _ -> d + skipSeps = filter (not . (`elem` (pure <$> pathSeparators))) + stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..") + | otherwise = id + prependSep | subpathIsAbsolute = (pathSeparator :) + | otherwise = id + avoidEmpty | not pathIsAbsolute + && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:." + = emptyToCurDir + | otherwise = id + appendSep p | hasTrailingPathSep + && not (pathIsAbsolute && null p) + = addTrailingPathSeparator p + | otherwise = p + pathIsAbsolute = not (isRelative path) + subpathIsAbsolute = any isPathSeparator (take 1 subpath) + hasTrailingPathSep = hasTrailingPathSeparator subpath + +emptyToCurDir :: FilePath -> FilePath +emptyToCurDir "" = "." +emptyToCurDir path = path + +normaliseTrailingSep :: FilePath -> FilePath +normaliseTrailingSep path = do + let path' = reverse path + let (sep, path'') = span isPathSeparator path' + let addSep = if null sep then id else (pathSeparator :) + reverse (addSep path'') + +normalisePathSeps :: FilePath -> FilePath +normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p + +expandDots :: [FilePath] -> [FilePath] +expandDots = reverse . go [] + where + go ys' xs' = + case xs' of + [] -> ys' + x : xs -> + case x of + "." -> go ys' xs + ".." -> + case ys' of + [] -> go (x : ys') xs + ".." : _ -> go (x : ys') xs + _ : ys -> go ys xs + _ -> go (x : ys') xs + +rawPrependCurrentDirectory :: FilePath -> IO FilePath +rawPrependCurrentDirectory path + | isRelative path = + ((`ioeAddLocation` "prependCurrentDirectory") . + (`IOE.ioeSetFileName` path)) `IOE.modifyIOError` do + getFullPathName path + | otherwise = pure path + +ioeAddLocation :: IOError -> String -> IOError +ioeAddLocation e loc = do + IOE.ioeSetLocation e newLoc + where + newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc + oldLoc = IOE.ioeGetLocation e + +getFullPathName :: FilePath -> IO FilePath +getFullPathName path = + fromExtendedLengthPath <$> WS.getFullPathName (toExtendedLengthPath path) + +fromExtendedLengthPath :: FilePath -> FilePath +fromExtendedLengthPath ePath = + case ePath of + '\\' : '\\' : '?' : '\\' : path -> + case path of + 'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath + drive : ':' : subpath + -- if the path is not "regular", then the prefix is necessary + -- to ensure the path is interpreted literally + | U.isAlpha drive && U.isAscii drive && isPathRegular subpath -> path + _ -> ePath + _ -> ePath + where + isPathRegular path = + not ('/' `elem` path || + "." `elem` splitDirectories path || + ".." `elem` splitDirectories path) diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Prelude/Internal.hs similarity index 60% rename from lib/GHCup/Utils/Prelude.hs rename to lib/GHCup/Prelude/Internal.hs index db2fbdc..093f3e1 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Prelude/Internal.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} {-| -Module : GHCup.Utils.Prelude +Module : GHCup.Prelude.Internal Description : MegaParsec utilities Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 @@ -15,27 +15,11 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -GHCup specific prelude. Lots of Excepts functionality. +Stuff that doesn't need GHCup modules, so we can avoid +recursive imports. -} -module GHCup.Utils.Prelude - (module GHCup.Utils.Prelude, -#if defined(IS_WINDOWS) - module GHCup.Utils.Prelude.Windows -#else - module GHCup.Utils.Prelude.Posix -#endif - ) -where +module GHCup.Prelude.Internal where -import GHCup.Types -import GHCup.Errors -import GHCup.Types.Optics -import {-# SOURCE #-} GHCup.Utils.Logger (logWarn) -#if defined(IS_WINDOWS) -import GHCup.Utils.Prelude.Windows -#else -import GHCup.Utils.Prelude.Posix -#endif import Control.Applicative import Control.Exception.Safe @@ -44,22 +28,15 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Data.Bifunctor import Data.ByteString ( ByteString ) -import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse ) +import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd ) import Data.Maybe -import Data.Foldable -import Data.List.NonEmpty ( NonEmpty( (:|) )) import Data.String import Data.Text ( Text ) import Data.Versions import Data.Word8 hiding ( isDigit ) import Haskus.Utils.Types.List import Haskus.Utils.Variant.Excepts -import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) import System.IO.Error -import System.IO.Temp -import System.IO.Unsafe -import System.Directory -import System.FilePath import Control.Retry import GHC.IO.Exception @@ -68,7 +45,6 @@ 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.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding.Error as E @@ -78,6 +54,7 @@ import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Encoding as TLE + -- $setup -- >>> import Data.ByteString.Internal (c2w, w2c) -- >>> import Test.QuickCheck @@ -181,13 +158,6 @@ lEM' :: forall e' e es a m -> Excepts es m a lEM' f em = lift em >>= lE . first f --- for some obscure reason... this won't type-check if we move it to a different module -catchWarn :: forall es m env . ( Pretty (V es) - , MonadReader env m - , HasLog env - , MonadIO m - , Monad m) => Excepts es m () -> Excepts '[] m () -catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v)) fromEither :: Either a b -> VEither '[a] b fromEither = either (VLeft . V) VRight @@ -308,56 +278,6 @@ intToText :: Integral a => a -> T.Text intToText = TL.toStrict . B.toLazyText . B.decimal -pvpToVersion :: MonadThrow m => PVP -> Text -> m Version -pvpToVersion pvp_ rest = - either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_ - --- | Convert a version to a PVP and unparsable rest. --- --- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v -versionToPVP :: MonadThrow m => Version -> m (PVP, Text) -versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch" -versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v - where - alternative :: MonadThrow m => Version -> m PVP - alternative v' = case NE.takeWhile isDigit (_vChunks v') of - [] -> throwM $ ParseError "Couldn't convert Version to PVP" - xs -> pure $ pvpFromList (unsafeDigit <$> xs) - - rest :: Version -> Text - rest (Version _ cs pr me) = - let chunks = NE.dropWhile isDigit cs - ver = intersperse (T.pack ".") . chunksAsT $ chunks - me' = maybe [] (\m -> [T.pack "+",m]) me - pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr) - prefix = case (ver, pr', me') of - (_:_, _, _) -> T.pack "." - _ -> T.pack "" - in prefix <> mconcat (ver <> pr' <> me') - where - chunksAsT :: Functor t => t VChunk -> t Text - chunksAsT = fmap (foldMap f) - where - f :: VUnit -> Text - f (Digits i) = T.pack $ show i - f (Str s) = s - - foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b - foldable d g f | null f = d - | otherwise = g f - - - - isDigit :: VChunk -> Bool - isDigit (Digits _ :| []) = True - isDigit _ = False - - unsafeDigit :: VChunk -> Int - unsafeDigit (Digits x :| []) = fromIntegral x - unsafeDigit _ = error "unsafeDigit: wrong input" - -pvpFromList :: [Int] -> PVP -pvpFromList = PVP . NE.fromList . fmap fromIntegral -- | Safe 'decodeUtf8With'. Replaces an invalid input byte with -- the Unicode replacement character U+FFFD. @@ -376,167 +296,6 @@ escapeVerRex = B.pack . go . B.unpack . verToBS go (x : xs) | x == _period = [_backslash, _period] ++ go xs | otherwise = x : go xs --- | More permissive version of 'createDirRecursive'. This doesn't --- error when the destination is a symlink to a directory. -createDirRecursive' :: FilePath -> IO () -createDirRecursive' p = - handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e) - . createDirectoryIfMissing True - $ p - - where - isSymlinkDir e = do - ft <- pathIsSymbolicLink p - case ft of - True -> do - rp <- canonicalizePath p - rft <- doesDirectoryExist rp - case rft of - True -> pure () - _ -> throwIO e - _ -> throwIO e - - --- | Recursively copy the contents of one directory to another path. --- --- This is a rip-off of Cabal library. -copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO () -copyDirectoryRecursive srcDir destDir doCopy = do - srcFiles <- getDirectoryContentsRecursive srcDir - copyFilesWith destDir [ (srcDir, f) - | f <- srcFiles ] - where - -- | Common implementation of 'copyFiles', 'installOrdinaryFiles', - -- 'installExecutableFiles' and 'installMaybeExecutableFiles'. - copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO () - copyFilesWith targetDir srcFiles = do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - traverse_ (createDirectoryIfMissing True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in doCopy src dest - | (srcBase, srcFile) <- srcFiles ] - - --- | List all the files in a directory and all subdirectories. --- --- The order places files in sub-directories after all the files in their --- parent directories. The list is generated lazily so is not well defined if --- the source directory structure changes before the list is used. --- -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive topdir = recurseDirectories [""] - where - recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) - files' <- recurseDirectories (dirs' ++ dirs) - return (files ++ files') - - where - collect files dirs' [] = return (reverse files - ,reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do - let dirEntry = dir entry - isDirectory <- doesDirectoryExist (topdir dirEntry) - if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - 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 -recyclePathForcibly :: ( MonadIO m - , MonadReader env m - , HasDirs env - , MonadMask m - ) - => FilePath - -> m () -recyclePathForcibly fp - | isWindows = do - Dirs { recycleDir } <- getDirs - tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly" - let dest = tmp takeFileName fp - liftIO (moveFile fp dest) - `catch` - (\e -> if | isDoesNotExistError e -> pure () - | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp) - | otherwise -> throwIO e) - `finally` - liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) - | otherwise = liftIO $ removePathForcibly fp - - -rmPathForcibly :: ( MonadIO m - , MonadMask m - ) - => FilePath - -> m () -rmPathForcibly fp - | isWindows = recover (liftIO $ removePathForcibly fp) - | otherwise = liftIO $ removePathForcibly fp - - -rmDirectory :: (MonadIO m, MonadMask m) - => FilePath - -> m () -rmDirectory fp - | isWindows = recover (liftIO $ removeDirectory fp) - | otherwise = liftIO $ removeDirectory fp - - --- https://www.sqlite.org/src/info/89f1848d7f --- https://github.com/haskell/directory/issues/96 -recycleFile :: ( MonadIO m - , MonadMask m - , MonadReader env m - , HasDirs env - ) - => FilePath - -> m () -recycleFile fp - | isWindows = do - 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 (moveFile fp dest) - `catch` - (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e) - `finally` - liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) - | otherwise = liftIO $ removeFile fp - - -rmFile :: ( MonadIO m - , MonadMask m - ) - => FilePath - -> m () -rmFile fp - | isWindows = recover (liftIO $ removeFile fp) - | otherwise = liftIO $ removeFile fp - - -rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) - => FilePath - -> m () -rmDirectoryLink fp - | isWindows = recover (liftIO $ removeDirectoryLink fp) - | otherwise = liftIO $ removeDirectoryLink fp recover :: (MonadIO m, MonadMask m) => m a -> m a @@ -549,10 +308,6 @@ recover action = (\_ -> action) -copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m () -copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from - - -- | Gathering monoidal values -- -- >>> traverseFold (pure . (:["0"])) ["1","2"] @@ -762,4 +517,3 @@ breakOn :: Eq a => [a] -> [a] -> ([a], [a]) breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack) breakOn _ [] = ([], []) breakOn needle (x:xs) = first (x:) $ breakOn needle xs - diff --git a/lib/GHCup/Prelude/Logger.hs b/lib/GHCup/Prelude/Logger.hs new file mode 100644 index 0000000..b256cf9 --- /dev/null +++ b/lib/GHCup/Prelude/Logger.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Utils.Logger +Description : logger definition +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable + +Here we define our main logger. +-} +module GHCup.Prelude.Logger + ( module GHCup.Prelude.Logger + , module GHCup.Prelude.Logger.Internal + ) +where + +import GHCup.Prelude.Logger.Internal +import GHCup.Types +import GHCup.Types.Optics +import GHCup.Utils.Dirs (fromGHCupPath) +import GHCup.Prelude.Internal +import GHCup.Prelude.File.Search (findFiles) +import GHCup.Prelude.File (recycleFile) +import GHCup.Prelude.String.QQ + +import Control.Exception.Safe +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Prelude hiding ( appendFile ) +import System.FilePath +import System.IO.Error +import Text.Regex.Posix + +import qualified Data.ByteString as B + + + +initGHCupFileLogging :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadMask m + ) => m FilePath +initGHCupFileLogging = do + Dirs { logsDir } <- getDirs + let logfile = fromGHCupPath logsDir "ghcup.log" + logFiles <- liftIO $ findFiles + (fromGHCupPath logsDir) + (makeRegexOpts compExtended + execBlank + ([s|^.*\.log$|] :: B.ByteString) + ) + forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir ) + + liftIO $ writeFile logfile "" + pure logfile diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Prelude/Logger/Internal.hs similarity index 73% rename from lib/GHCup/Utils/Logger.hs rename to lib/GHCup/Prelude/Logger/Internal.hs index a30c697..446f10e 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Prelude/Logger/Internal.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-| -Module : GHCup.Utils.Logger +Module : GHCup.Utils.Logger.Internal Description : logger definition Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 @@ -11,16 +11,13 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -Here we define our main logger. +Breaking import cycles. -} -module GHCup.Utils.Logger where +module GHCup.Prelude.Logger.Internal where import GHCup.Types import GHCup.Types.Optics -import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles) -import GHCup.Utils.String.QQ -import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader @@ -28,12 +25,7 @@ import Data.Text ( Text ) import Optics import Prelude hiding ( appendFile ) import System.Console.Pretty -import System.FilePath -import System.IO.Error -import Text.Regex.Posix -import qualified Data.ByteString as B -import GHCup.Utils.Prelude import qualified Data.Text as T logInfo :: ( MonadReader env m @@ -91,7 +83,7 @@ logInternal logLevel msg = do let strs = T.split (== '\n') msg let out = case strs of [] -> T.empty - (x:xs) -> + (x:xs) -> foldr (\a b -> a <> "\n" <> b) mempty . ((l <> " " <> x) :) . fmap (\line' -> style' "[ ... ] " <> line' ) @@ -109,22 +101,3 @@ logInternal logLevel msg = do let outr = lr <> " " <> msg <> "\n" liftIO $ fileOutter outr - -initGHCupFileLogging :: ( MonadReader env m - , HasDirs env - , MonadIO m - , MonadMask m - ) => m FilePath -initGHCupFileLogging = do - Dirs { logsDir } <- getDirs - let logfile = logsDir "ghcup.log" - logFiles <- liftIO $ findFiles - logsDir - (makeRegexOpts compExtended - execBlank - ([s|^.*\.log$|] :: B.ByteString) - ) - forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir ) - - liftIO $ writeFile logfile "" - pure logfile diff --git a/lib/GHCup/Utils/MegaParsec.hs b/lib/GHCup/Prelude/MegaParsec.hs similarity index 98% rename from lib/GHCup/Utils/MegaParsec.hs rename to lib/GHCup/Prelude/MegaParsec.hs index b622eb8..2f8d06b 100644 --- a/lib/GHCup/Utils/MegaParsec.hs +++ b/lib/GHCup/Prelude/MegaParsec.hs @@ -10,7 +10,7 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -} -module GHCup.Utils.MegaParsec where +module GHCup.Prelude.MegaParsec where import GHCup.Types diff --git a/lib/GHCup/Utils/Posix.hs b/lib/GHCup/Prelude/Posix.hs similarity index 78% rename from lib/GHCup/Utils/Posix.hs rename to lib/GHCup/Prelude/Posix.hs index 4b2dcee..c7c13de 100644 --- a/lib/GHCup/Utils/Posix.hs +++ b/lib/GHCup/Prelude/Posix.hs @@ -1,4 +1,4 @@ -module GHCup.Utils.Posix where +module GHCup.Prelude.Posix where -- | Enables ANSI support on windows, does nothing on unix. @@ -12,3 +12,8 @@ module GHCup.Utils.Posix where enableAnsiSupport :: IO (Either String Bool) enableAnsiSupport = pure (Right True) +isWindows, isNotWindows :: Bool +isWindows = False +isNotWindows = not isWindows + + diff --git a/lib/GHCup/Prelude/Process.hs b/lib/GHCup/Prelude/Process.hs new file mode 100644 index 0000000..ed38b4e --- /dev/null +++ b/lib/GHCup/Prelude/Process.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} + +{-| +Module : GHCup.Utils.Process +Description : Process handling +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Prelude.Process ( + executeOut, + execLogged, + exec, + toProcessError, +) where + + +#if IS_WINDOWS +import GHCup.Prelude.Process.Windows +#else +import GHCup.Prelude.Process.Posix +#endif + diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Prelude/Process/Posix.hs similarity index 87% rename from lib/GHCup/Utils/File/Posix.hs rename to lib/GHCup/Prelude/Process/Posix.hs index ac60b3c..4e9670b 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Prelude/Process/Posix.hs @@ -1,29 +1,31 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CApiFFI #-} {-| Module : GHCup.Utils.File.Posix -Description : File and unix APIs +Description : Process handling for unix Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 Maintainer : hasufell@hasufell.de Stability : experimental Portability : POSIX - -This module handles file and executable handling. -Some of these functions use sophisticated logging. -} -module GHCup.Utils.File.Posix where +module GHCup.Prelude.Process.Posix where -import GHCup.Utils.File.Common -import GHCup.Utils.Prelude -import GHCup.Utils.Logger +import GHCup.Utils.Dirs +import GHCup.Prelude.File +import GHCup.Prelude.File.Posix +import GHCup.Prelude +import GHCup.Prelude.Logger import GHCup.Types import GHCup.Types.Optics import Control.Concurrent import Control.Concurrent.Async -import Control.Exception ( evaluate ) +import qualified Control.Exception as E import Control.Exception.Safe import Control.Monad import Control.Monad.Reader @@ -36,11 +38,9 @@ import Data.List import Data.Word8 import GHC.IO.Exception import System.IO ( stderr ) -import System.IO.Error +import System.IO.Error hiding ( catchIOError ) import System.FilePath -import System.Directory import System.Posix.Directory -import System.Posix.Files import System.Posix.IO import System.Posix.Process ( ProcessStatus(..) ) import System.Posix.Types @@ -87,7 +87,7 @@ execLogged exe args chdir lfile env = do Settings {..} <- getSettings Dirs {..} <- getDirs logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args - let logfile = logsDir lfile <> ".log" + let logfile = fromGHCupPath logsDir lfile <> ".log" liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True }) closeFd (action verbose noColor) @@ -262,7 +262,7 @@ captureOutStreams action = do -- execute the action a <- action - void $ evaluate a + void $ E.evaluate a -- close everything we don't need closeFd childStdoutWrite @@ -360,42 +360,3 @@ toProcessError exe args mps = case mps of -chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m () -chmod_755 fp = do - let exe_mode = - nullFileMode - `unionFileModes` ownerExecuteMode - `unionFileModes` ownerReadMode - `unionFileModes` ownerWriteMode - `unionFileModes` groupExecuteMode - `unionFileModes` groupReadMode - `unionFileModes` otherExecuteMode - `unionFileModes` otherReadMode - logDebug ("chmod 755 " <> T.pack fp) - liftIO $ setFileMode fp exe_mode - - --- |Default permissions for a new file. -newFilePerms :: FileMode -newFilePerms = - ownerWriteMode - `unionFileModes` ownerReadMode - `unionFileModes` groupWriteMode - `unionFileModes` groupReadMode - `unionFileModes` otherWriteMode - `unionFileModes` otherReadMode - - --- | Checks whether the binary is a broken link. -isBrokenSymlink :: FilePath -> IO Bool -isBrokenSymlink fp = do - try (pathIsSymbolicLink fp) >>= \case - Right True -> do - let symDir = takeDirectory fp - tfp <- getSymbolicLinkTarget fp - not <$> doesPathExist - -- this drops 'symDir' if 'tfp' is absolute - (symDir tfp) - Right b -> pure b - Left e | isDoesNotExistError e -> pure False - | otherwise -> throwIO e diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Prelude/Process/Windows.hs similarity index 89% rename from lib/GHCup/Utils/File/Windows.hs rename to lib/GHCup/Prelude/Process/Windows.hs index 5942531..17c75ac 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Prelude/Process/Windows.hs @@ -1,24 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} {-| -Module : GHCup.Utils.File.Windows -Description : File and windows APIs +Module : GHCup.Utils.Process.Windows +Description : Process handling for windows Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 Maintainer : hasufell@hasufell.de Stability : experimental Portability : Windows - -This module handles file and executable handling. -Some of these functions use sophisticated logging. -} -module GHCup.Utils.File.Windows where +module GHCup.Prelude.Process.Windows where -import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink ) import GHCup.Utils.Dirs -import GHCup.Utils.File.Common -import GHCup.Utils.Logger +import GHCup.Prelude.File.Search +import GHCup.Prelude.Logger.Internal import GHCup.Types import GHCup.Types.Optics @@ -31,12 +28,11 @@ import Data.List import Foreign.C.Error import GHC.IO.Exception import GHC.IO.Handle -import System.Directory import System.Environment import System.FilePath import System.IO import System.Process - + import qualified Control.Exception as EX import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL @@ -45,6 +41,7 @@ import qualified Data.Text as T + toProcessError :: FilePath -> [FilePath] -> ExitCode @@ -164,8 +161,8 @@ execLogged :: ( MonadReader env m execLogged exe args chdir lfile env = do Dirs {..} <- getDirs logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args - let stdoutLogfile = logsDir lfile <> ".stdout.log" - stderrLogfile = logsDir lfile <> ".stderr.log" + let stdoutLogfile = fromGHCupPath logsDir lfile <> ".stdout.log" + stderrLogfile = fromGHCupPath logsDir lfile <> ".stderr.log" cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir , env = env @@ -199,7 +196,7 @@ execLogged exe args chdir lfile env = do -- subprocess stdout also goes to stderr for logging void $ BS.hPut stderr some go - + -- | Thin wrapper around `executeFile`. exec :: MonadIO m @@ -228,12 +225,6 @@ execShell exe args chdir env = do pure $ toProcessError cmd [] exit_code -chmod_755 :: MonadIO m => FilePath -> m () -chmod_755 fp = - let perm = setOwnerWritable True emptyPermissions - in liftIO $ setPermissions fp perm - - createProcessWithMingwPath :: MonadIO m => CreateProcess -> m CreateProcess @@ -256,16 +247,5 @@ ghcupMsys2Dir = Just fp -> pure fp Nothing -> do baseDir <- liftIO ghcupBaseDir - pure (baseDir "msys64") + pure (fromGHCupPath baseDir "msys64") --- | Checks whether the binary is a broken link. -isBrokenSymlink :: FilePath -> IO Bool -isBrokenSymlink fp = do - b <- pathIsLink fp - if b - then do - tfp <- getLinkTarget fp - not <$> doesPathExist - -- this drops 'symDir' if 'tfp' is absolute - (takeDirectory fp tfp) - else pure False diff --git a/lib/GHCup/Utils/String/QQ.hs b/lib/GHCup/Prelude/String/QQ.hs similarity index 97% rename from lib/GHCup/Utils/String/QQ.hs rename to lib/GHCup/Prelude/String/QQ.hs index ec249de..822a34e 100644 --- a/lib/GHCup/Utils/String/QQ.hs +++ b/lib/GHCup/Prelude/String/QQ.hs @@ -30,7 +30,7 @@ Any instance of the IsString type is permitted. (For GHC versions 6, write "[$s||]" instead of "[s||]".) -} -module GHCup.Utils.String.QQ +module GHCup.Prelude.String.QQ ( s ) where diff --git a/lib/GHCup/Utils/Version/QQ.hs b/lib/GHCup/Prelude/Version/QQ.hs similarity index 98% rename from lib/GHCup/Utils/Version/QQ.hs rename to lib/GHCup/Prelude/Version/QQ.hs index fe87237..d3d03c6 100644 --- a/lib/GHCup/Utils/Version/QQ.hs +++ b/lib/GHCup/Prelude/Version/QQ.hs @@ -16,7 +16,7 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -} -module GHCup.Utils.Version.QQ where +module GHCup.Prelude.Version.QQ where import Data.Data import Data.Text ( Text ) diff --git a/lib/GHCup/Utils/Windows.hs b/lib/GHCup/Prelude/Windows.hs similarity index 93% rename from lib/GHCup/Utils/Windows.hs rename to lib/GHCup/Prelude/Windows.hs index 14ffbd8..25b8731 100644 --- a/lib/GHCup/Utils/Windows.hs +++ b/lib/GHCup/Prelude/Windows.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module GHCup.Utils.Windows where +module GHCup.Prelude.Windows where import Control.Exception.Safe @@ -46,3 +46,8 @@ enableAnsiSupport = handleIO (pure . Left . displayException) $ do >> pure (Right False) else pure (Right True) + +isWindows, isNotWindows :: Bool +isWindows = True +isNotWindows = not isWindows + diff --git a/lib/GHCup/Stack.hs b/lib/GHCup/Stack.hs new file mode 100644 index 0000000..cfc7587 --- /dev/null +++ b/lib/GHCup/Stack.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Stack +Description : GHCup installation functions for Stack +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Stack where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.Either +import Data.List +import Data.Maybe +import Data.Versions hiding ( patch ) +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) +import Safe hiding ( at ) +import System.FilePath +import System.IO.Error + +import qualified Data.Text as T + + + + -------------------- + --[ Installation ]-- + -------------------- + + +-- | Installs stack into @~\/.ghcup\/bin/stack-\@ and +-- creates a default @stack -> stack-x.y.z.q@ symlink for +-- the latest installed version. +installStackBin :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Version + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installStackBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo Stack ver + installStackBindist dlinfo ver installDir forceInstall + + +-- | Like 'installStackBin', except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installStackBindist :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => DownloadInfo + -> Version + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installStackBindist dlinfo ver installDir forceInstall = do + lift $ logDebug $ "Requested to install stack version " <> prettyVer ver + + PlatformRequest {..} <- lift getPlatformReq + Dirs {..} <- lift getDirs + + regularStackInstalled <- lift $ stackInstalled ver + + if + | not forceInstall + , regularStackInstalled + , GHCupInternal <- installDir -> do + throwE $ AlreadyInstalled Stack ver + + | forceInstall + , regularStackInstalled + , GHCupInternal <- installDir -> do + lift $ logInfo "Removing the currently installed version of Stack first!" + liftE $ rmStackVer ver + + | otherwise -> pure () + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + case installDir of + IsolateDir isoDir -> do -- isolated install + lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir + liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + GHCupInternal -> do -- regular install + liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall + + +-- | Install an unpacked stack distribution. +installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) + => GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides) + -> InstallDirResolved + -> Version + -> Bool -- ^ Force install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installStackUnpacked path installDir ver forceInstall = do + lift $ logInfo "Installing stack" + let stackFile = "stack" + liftIO $ createDirRecursive' (fromInstallDir installDir) + let destFileName = stackFile + <> (case installDir of + IsolateDirResolved _ -> "" + _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + destPath = fromInstallDir installDir destFileName + + copyFileE + (fromGHCupPath path stackFile <> exeExt) + destPath + (not forceInstall) + lift $ chmod_755 destPath + + + + ----------------- + --[ Set stack ]-- + ----------------- + + +-- | Set the @~\/.ghcup\/bin\/stack@ symlink. +setStack :: ( MonadMask m + , MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled] m () +setStack ver = do + let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt + + -- symlink destination + Dirs {..} <- lift getDirs + + whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) + $ throwE + $ NotInstalled Stack (GHCTargetVersion Nothing ver) + + let stackbin = binDir "stack" <> exeExt + + lift $ createLink targetFile stackbin + + pure () + + +unsetStack :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetStack = do + Dirs {..} <- getDirs + let stackbin = binDir "stack" <> exeExt + hideError doesNotExistErrorType $ rmLink stackbin + + + ---------------- + --[ Rm stack ]-- + ---------------- + +-- | Delete a stack version. Will try to fix the @stack@ symlink +-- after removal (e.g. setting it to an older version). +rmStackVer :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled] m () +rmStackVer ver = do + whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver)) + + sSet <- lift stackSet + + Dirs {..} <- lift getDirs + + let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt + lift $ hideError doesNotExistErrorType $ recycleFile (binDir stackFile) + + when (Just ver == sSet) $ do + sVers <- lift $ fmap rights getInstalledStacks + case headMay . reverse . sort $ sVers of + Just latestver -> setStack latestver + Nothing -> lift $ rmLink (binDir "stack" <> exeExt) diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 93b985e..63761d2 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -26,6 +26,8 @@ module GHCup.Types ) where +import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath ) + import Control.DeepSeq ( NFData, rnf ) import Data.Map.Strict ( Map ) import Data.List.NonEmpty ( NonEmpty (..) ) @@ -438,12 +440,14 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR instance NFData Settings data Dirs = Dirs - { baseDir :: FilePath - , binDir :: FilePath - , cacheDir :: FilePath - , logsDir :: FilePath - , confDir :: FilePath - , recycleDir :: FilePath -- mainly used on windows + { baseDir :: GHCupPath + , binDir :: FilePath + , cacheDir :: GHCupPath + , logsDir :: GHCupPath + , confDir :: GHCupPath + , dbDir :: GHCupPath + , recycleDir :: GHCupPath -- mainly used on windows + , tmpDir :: GHCupPath } deriving (Show, GHC.Generic) @@ -635,9 +639,25 @@ data InstallDir = IsolateDir FilePath deriving (Eq, Show) data InstallDirResolved = IsolateDirResolved FilePath - | GHCupDir FilePath + | GHCupDir GHCupPath + | GHCupBinDir FilePath deriving (Eq, Show) fromInstallDir :: InstallDirResolved -> FilePath fromInstallDir (IsolateDirResolved fp) = fp -fromInstallDir (GHCupDir fp) = fp +fromInstallDir (GHCupDir fp) = fromGHCupPath fp +fromInstallDir (GHCupBinDir fp) = fp + + +isSafeDir :: InstallDirResolved -> Bool +isSafeDir (IsolateDirResolved _) = False +isSafeDir (GHCupDir _) = True +isSafeDir (GHCupBinDir _) = False + + + + + + + + diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 8d7cd3b..35d8b83 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -23,7 +23,7 @@ module GHCup.Types.JSON where import GHCup.Types import GHCup.Types.JSON.Utils -import GHCup.Utils.MegaParsec +import GHCup.Prelude.MegaParsec import Control.Applicative ( (<|>) ) import Data.Aeson hiding (Key) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index e142cc9..e46bf69 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,18 +23,18 @@ module GHCup.Utils ( module GHCup.Utils.Dirs , module GHCup.Utils #if defined(IS_WINDOWS) - , module GHCup.Utils.Windows + , module GHCup.Prelude.Windows #else - , module GHCup.Utils.Posix + , module GHCup.Prelude.Posix #endif ) where #if defined(IS_WINDOWS) -import GHCup.Utils.Windows +import GHCup.Prelude.Windows #else -import GHCup.Utils.Posix +import GHCup.Prelude.Posix #endif import GHCup.Download import GHCup.Errors @@ -41,11 +42,13 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.MegaParsec -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ +import GHCup.Version +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger.Internal +import GHCup.Prelude.MegaParsec +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ import Codec.Archive hiding ( Directory ) import Control.Applicative @@ -71,10 +74,10 @@ import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Optics import Safe -import System.Directory hiding ( findFiles ) import System.FilePath import System.IO.Error import Text.Regex.Posix +import Text.PrettyPrint.HughesPJClass (prettyShow) import URI.ByteString import qualified Codec.Compression.BZip as BZip @@ -86,6 +89,9 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP import qualified Data.List.NonEmpty as NE +import qualified Streamly.Prelude as S +import Control.DeepSeq (force) +import GHC.IO (evaluate) -- $setup @@ -96,14 +102,14 @@ import qualified Data.List.NonEmpty as NE -- >>> import System.Directory -- >>> import URI.ByteString -- >>> import qualified Data.Text as T --- >>> import GHCup.Utils.Prelude +-- >>> import GHCup.Prelude -- >>> import GHCup.Download -- >>> import GHCup.Version -- >>> import GHCup.Errors -- >>> import GHCup.Types -- >>> import GHCup.Types.Optics -- >>> import Optics --- >>> import GHCup.Utils.Version.QQ +-- >>> import GHCup.Prelude.Version.QQ -- >>> import qualified Data.Text.Encoding as E -- >>> import Control.Monad.Reader -- >>> import Haskus.Utils.Variant.Excepts @@ -277,14 +283,14 @@ rmPlainHLS = do ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver - liftIO $ doesDirectoryExist ghcdir + liftIO $ doesDirectoryExist (fromGHCupPath ghcdir) -- | Whether the given GHC version is installed from source. ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled ver = do ghcdir <- ghcupGHCDir ver - liftIO $ doesFileExist (ghcdir ghcUpSrcBuiltFile) + liftIO $ doesFileExist (fromGHCupPath ghcdir ghcUpSrcBuiltFile) -- | Whether the given GHC version is set as the current. @@ -327,7 +333,7 @@ ghcSet mtarget = do getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion] getInstalledGHCs = do ghcdir <- ghcupGHCBaseDir - fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir + fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath ghcdir) forM fs $ \f -> case parseGHCupGHCDir f of Right r -> pure $ Right r Left _ -> pure $ Left f @@ -430,7 +436,7 @@ getInstalledHLSs = do Nothing -> pure $ Left f hlsdir <- ghcupHLSBaseDir - fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir + fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath hlsdir) new <- forM fs $ \f -> case parseGHCupHLSDir f of Right r -> pure $ Right r Left _ -> pure $ Left f @@ -515,7 +521,7 @@ hlsInstalled ver = do isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool isLegacyHLS ver = do bdir <- ghcupHLSDir ver - not <$> liftIO (doesDirectoryExist bdir) + not <$> liftIO (doesDirectoryExist $ fromGHCupPath bdir) -- Return the currently set hls version, if any. @@ -616,7 +622,7 @@ hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThr -> m [FilePath] hlsInternalServerScripts ver mghcVer = do dir <- ghcupHLSDir ver - let bdir = dir "bin" + let bdir = fromGHCupPath dir "bin" fmap (bdir ) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer) <$> liftIO (listDirectory bdir) @@ -627,7 +633,7 @@ hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadTh -> Maybe Version -- ^ optional GHC version -> m [FilePath] hlsInternalServerBinaries ver mghcVer = do - dir <- ghcupHLSDir ver + dir <- fromGHCupPath <$> ghcupHLSDir ver let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir "lib"), Right regex, Left "bin"] fmap (bdir ) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer) @@ -641,7 +647,7 @@ hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow -> Version -- ^ GHC version -> m [FilePath] hlsInternalServerLibs ver ghcVer = do - dir <- ghcupHLSDir ver + dir <- fromGHCupPath <$> ghcupHLSDir ver let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir "lib"), Right regex, Left ("lib" T.unpack (prettyVer ghcVer))] fmap (bdir ) <$> liftIO (listDirectory bdir) @@ -845,21 +851,21 @@ getArchiveFiles av = do intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m) - => FilePath -- ^ unpacked tar dir + => GHCupPath -- ^ unpacked tar dir -> TarDir -- ^ how to descend - -> Excepts '[TarDirDoesNotExist] m FilePath + -> Excepts '[TarDirDoesNotExist] m GHCupPath intoSubdir bdir tardir = case tardir of RealDir pr -> do - whenM (fmap not . liftIO . doesDirectoryExist $ (bdir pr)) + whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr)) (throwE $ TarDirDoesNotExist tardir) - pure (bdir pr) + pure (bdir `appendGHCupPath` pr) RegexDir r -> do let rs = split (`elem` pathSeparators) r foldlM (\y x -> - (handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case + (handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case [] -> throwE $ TarDirDoesNotExist tardir - (p : _) -> pure (y p)) . sort + (p : _) -> pure (y `appendGHCupPath` p)) . sort ) bdir rs @@ -905,7 +911,7 @@ ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, => GHCTargetVersion -> m FilePath ghcInternalBinDir ver = do - ghcdir <- ghcupGHCDir ver + ghcdir <- fromGHCupPath <$> ghcupGHCDir ver pure (ghcdir "bin") @@ -1016,6 +1022,28 @@ applyPatch patch ddir = do !? PatchFailed +applyAnyPatch :: ( MonadReader env m + , HasDirs env + , HasLog env + , HasSettings env + , MonadUnliftIO m + , MonadCatch m + , MonadResource m + , MonadThrow m + , MonadMask m + , MonadIO m) + => Maybe (Either FilePath [URI]) + -> FilePath + -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m () +applyAnyPatch Nothing _ = pure () +applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir +applyAnyPatch (Just (Right uris)) workdir = do + tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir + forM_ uris $ \uri -> do + patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False + liftE $ applyPatch patch workdir + + -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m) => Platform @@ -1029,6 +1057,8 @@ darwinNotarization Darwin path = exec darwinNotarization _ _ = pure $ Right () + + getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI getChangeLog dls tool (Left v') = preview (ix tool % ix v' % viChangeLog % _Just) dls @@ -1039,7 +1069,6 @@ getChangeLog dls tool (Right tag) = -- | Execute a build action while potentially cleaning up: -- -- 1. the build directory, depending on the KeepDirs setting --- 2. the install destination, depending on whether the build failed runBuildAction :: ( MonadReader env m , HasDirs env , HasSettings env @@ -1050,15 +1079,12 @@ runBuildAction :: ( MonadReader env m , MonadFail m , MonadCatch m ) - => FilePath -- ^ build directory (cleaned up depending on Settings) - -> Maybe FilePath -- ^ dir to *always* clean up on exception + => GHCupPath -- ^ build directory (cleaned up depending on Settings) -> Excepts e m a -> Excepts e m a -runBuildAction bdir instdir action = do +runBuildAction bdir action = do Settings {..} <- lift getSettings let exAction = do - forM_ instdir $ \dir -> - hideError doesNotExistErrorType $ recyclePathForcibly dir when (keepDirs == Never) $ rmBDir bdir v <- @@ -1080,7 +1106,7 @@ cleanUpOnError :: ( MonadReader env m , MonadFail m , MonadCatch m ) - => FilePath -- ^ build directory (cleaned up depending on Settings) + => GHCupPath -- ^ build directory (cleaned up depending on Settings) -> Excepts e m a -> Excepts e m a cleanUpOnError bdir action = do @@ -1089,13 +1115,33 @@ cleanUpOnError bdir action = do flip onException (lift exAction) $ onE_ exAction action +-- | Clean up the given directory if the action fails, +-- depending on the Settings. +cleanFinally :: ( MonadReader env m + , HasDirs env + , HasSettings env + , MonadIO m + , MonadMask m + , HasLog env + , MonadUnliftIO m + , MonadFail m + , MonadCatch m + ) + => GHCupPath -- ^ build directory (cleaned up depending on Settings) + -> Excepts e m a + -> Excepts e m a +cleanFinally bdir action = do + Settings {..} <- lift getSettings + let exAction = when (keepDirs == Never) $ rmBDir bdir + flip finally (lift exAction) $ onE_ exAction action + -- | Remove a build directory, ignoring if it doesn't exist and gracefully -- printing other errors without crashing. -rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m () +rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m () rmBDir dir = withRunInIO (\run -> run $ liftIO $ handleIO (\e -> run $ logWarn $ - "Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e)) + "Couldn't remove build dir " <> T.pack (fromGHCupPath dir) <> ", error was: " <> T.pack (displayException e)) $ hideError doesNotExistErrorType $ rmPathForcibly dir) @@ -1113,97 +1159,6 @@ getVersionInfo v' tool = ) --- | The file extension for executables. -exeExt :: String -exeExt - | isWindows = ".exe" - | otherwise = "" - --- | The file extension for executables. -exeExt' :: ByteString -exeExt' - | isWindows = ".exe" - | otherwise = "" - - - - --- | On unix, we can use symlinks, so we just get the --- symbolic link target. --- --- On windows, we have to emulate symlinks via shims, --- see 'createLink'. -getLinkTarget :: FilePath -> IO FilePath -getLinkTarget fp - | isWindows = do - content <- readFile (dropExtension fp <.> "shim") - [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content - pure $ stripNewline $ dropPrefix "path = " p - | otherwise = getSymbolicLinkTarget fp - - --- | Checks whether the path is a link. -pathIsLink :: FilePath -> IO Bool -pathIsLink fp - | isWindows = doesPathExist (dropExtension fp <.> "shim") - | otherwise = pathIsSymbolicLink fp - - -rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m () -rmLink fp - | isWindows = do - hideError doesNotExistErrorType . recycleFile $ fp - hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim") - | otherwise = hideError doesNotExistErrorType . recycleFile $ fp - - --- | Creates a symbolic link on unix and a fake symlink on windows for --- executables, which: --- 1. is a shim exe --- 2. has a corresponding .shim file in the same directory that --- contains the target --- --- This overwrites previously existing files. --- --- On windows, this requires that 'ensureGlobalTools' was run beforehand. -createLink :: ( MonadMask m - , MonadThrow m - , HasLog env - , MonadIO m - , MonadReader env m - , HasDirs env - , MonadUnliftIO m - , MonadFail m - ) - => FilePath -- ^ path to the target executable - -> FilePath -- ^ path to be created - -> m () -createLink link exe - | isWindows = do - dirs <- getDirs - let shimGen = cacheDir dirs "gs.exe" - - let shim = dropExtension exe <.> "shim" - -- For hardlinks, link needs to be absolute. - -- If link is relative, it's relative to the target exe. - -- Note that () drops lhs when rhs is absolute. - fullLink = takeDirectory exe link - shimContents = "path = " <> fullLink - - logDebug $ "rm -f " <> T.pack exe - rmLink exe - - logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe - liftIO $ copyFile shimGen exe - liftIO $ writeFile shim shimContents - | otherwise = do - logDebug $ "rm -f " <> T.pack exe - hideError doesNotExistErrorType $ recycleFile exe - - logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe - liftIO $ createFileLink link exe - - ensureGlobalTools :: ( MonadMask m , MonadThrow m , HasLog env @@ -1225,8 +1180,8 @@ ensureGlobalTools let dl = downloadCached' shimDownload (Just "gs.exe") Nothing void $ (\DigestError{} -> do lift $ logWarn "Digest doesn't match, redownloading gs.exe..." - lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs "gs.exe")) - lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs "gs.exe") + lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) "gs.exe")) + lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) "gs.exe") liftE @'[GPGError, DigestError , DownloadFailed] $ dl ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl | otherwise = pure () @@ -1234,14 +1189,17 @@ ensureGlobalTools -- | Ensure ghcup directory structure exists. ensureDirectories :: Dirs -> IO () -ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do - createDirRecursive' baseDir - createDirRecursive' (baseDir "ghc") +ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir tmpDir) = do + createDirRecursive' (fromGHCupPath baseDir) + createDirRecursive' (fromGHCupPath baseDir "ghc") + createDirRecursive' (fromGHCupPath baseDir "hls") createDirRecursive' binDir - createDirRecursive' cacheDir - createDirRecursive' logsDir - createDirRecursive' confDir - createDirRecursive' trashDir + createDirRecursive' (fromGHCupPath cacheDir) + createDirRecursive' (fromGHCupPath logsDir) + createDirRecursive' (fromGHCupPath confDir) + createDirRecursive' (fromGHCupPath trashDir) + createDirRecursive' (fromGHCupPath dbDir) + createDirRecursive' (fromGHCupPath tmpDir) pure () @@ -1264,11 +1222,56 @@ ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt) -- 3. if it exists and is non-empty -> panic and leave the house installDestSanityCheck :: ( MonadIO m , MonadCatch m + , MonadMask m ) => InstallDirResolved -> Excepts '[DirNotEmpty] m () installDestSanityCheck (IsolateDirResolved isoDir) = do hideErrorDef [doesNotExistErrorType] () $ do - contents <- liftIO $ getDirectoryContentsRecursive isoDir - unless (null contents) (throwE $ DirNotEmpty isoDir) + empty' <- liftIO $ S.null $ getDirectoryContentsRecursiveUnsafe isoDir + when (not empty') (throwE $ DirNotEmpty isoDir) installDestSanityCheck _ = pure () + + +-- | Returns 'Nothing' for legacy installs. +getInstalledFiles :: ( MonadIO m + , MonadCatch m + , MonadReader env m + , HasDirs env + , MonadFail m + ) + => Tool + -> GHCTargetVersion + -> m (Maybe [FilePath]) +getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do + f <- recordedInstallationFile t v' + (force -> !c) <- liftIO + (readFile f >>= evaluate) + pure (Just $ lines c) + + +-- | Warn if the installed and set HLS is not compatible with the installed and +-- set GHC version. +warnAboutHlsCompatibility :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadCatch m + , MonadIO m + ) + => m () +warnAboutHlsCompatibility = do + supportedGHC <- hlsGHCVersions + currentGHC <- fmap _tvVersion <$> ghcSet Nothing + currentHLS <- hlsSet + + case (currentGHC, currentHLS) of + (Just gv, Just hv) | gv `notElem` supportedGHC -> do + logWarn $ + "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <> + "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <> + "Haskell IDE support may not work until this is fixed." <> "\n" <> + "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <> + T.pack (prettyShow supportedGHC) + + _ -> return () diff --git a/lib/GHCup/Utils.hs-boot b/lib/GHCup/Utils.hs-boot deleted file mode 100644 index e534e82..0000000 --- a/lib/GHCup/Utils.hs-boot +++ /dev/null @@ -1,4 +0,0 @@ -module GHCup.Utils where - -getLinkTarget :: FilePath -> IO FilePath -pathIsLink :: FilePath -> IO Bool diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index b2fb7eb..c2c026a 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} {-| Module : GHCup.Utils.Dirs @@ -30,6 +31,74 @@ module GHCup.Utils.Dirs , getConfigFilePath , useXDG , cleanupTrash + + , GHCupPath + , appendGHCupPath + , fromGHCupPath + , createTempGHCupDirectory + , getGHCupTmpDirs + + , removeDirectory + , removeDirectoryRecursive + , removePathForcibly + + -- System.Directory re-exports + , createDirectory + , createDirectoryIfMissing + , renameDirectory + , listDirectory + , getDirectoryContents + , getCurrentDirectory + , setCurrentDirectory + , withCurrentDirectory + , getHomeDirectory + , XdgDirectory(..) + , getXdgDirectory + , XdgDirectoryList(..) + , getXdgDirectoryList + , getAppUserDataDirectory + , getUserDocumentsDirectory + , getTemporaryDirectory + , removeFile + , renameFile + , renamePath + , getFileSize + , canonicalizePath + , makeAbsolute + , makeRelativeToCurrentDirectory + , doesPathExist + , doesFileExist + , doesDirectoryExist + , findExecutable + , findExecutables + , findExecutablesInDirectories + , findFile + , findFileWith + , findFilesWith + , exeExtension + , createFileLink + , createDirectoryLink + , removeDirectoryLink + , pathIsSymbolicLink + , getSymbolicLinkTarget + , Permissions + , emptyPermissions + , readable + , writable + , executable + , searchable + , setOwnerReadable + , setOwnerWritable + , setOwnerExecutable + , setOwnerSearchable + , getPermissions + , setPermissions + , copyPermissions + , getAccessTime + , getModificationTime + , setAccessTime + , setModificationTime + , isSymbolicLink ) where @@ -38,35 +107,86 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics -import GHCup.Utils.MegaParsec -import GHCup.Utils.Logger -import GHCup.Utils.Prelude +import GHCup.Prelude.MegaParsec +import GHCup.Prelude.File.Search +import GHCup.Prelude.String.QQ +import GHCup.Prelude.Logger.Internal (logWarn, logDebug) +#if defined(IS_WINDOWS) +import GHCup.Prelude.Windows ( isWindows ) +#else +import GHCup.Prelude.Posix ( isWindows ) +#endif +import Control.DeepSeq (NFData, rnf) import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.Trans.Resource hiding (throwM) +import Data.List +import Data.ByteString ( ByteString ) import Data.Bifunctor import Data.Maybe import Data.Versions import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) import Haskus.Utils.Variant.Excepts import Optics -import System.Directory -import System.DiskSpace +import Safe +import System.Directory hiding ( removeDirectory + , removeDirectoryRecursive + , removePathForcibly + , findFiles + ) +import qualified System.Directory as SD + import System.Environment import System.FilePath import System.IO.Temp +import Text.Regex.Posix import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Yaml.Aeson as Y import qualified Text.Megaparsec as MP -import Control.Concurrent (threadDelay) +import System.IO.Error (ioeGetErrorType) + --------------------------- + --[ GHCupPath utilities ]-- + --------------------------- + +-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted. +-- +-- The constructor is not exported. +newtype GHCupPath = GHCupPath FilePath + deriving (Show, Eq, Ord) + +instance NFData GHCupPath where + rnf (GHCupPath fp) = rnf fp + +appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath +appendGHCupPath (GHCupPath gp) fp = GHCupPath (gp fp) + +fromGHCupPath :: GHCupPath -> FilePath +fromGHCupPath (GHCupPath gp) = gp + +createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath +createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp d + + +getGHCupTmpDirs :: IO [GHCupPath] +getGHCupTmpDirs = do + tmpdir <- fromGHCupPath <$> ghcupTMPDir + ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles + tmpdir + (makeRegexOpts compExtended + execBlank + ([s|^ghcup-.*$|] :: ByteString) + ) + pure (fmap (\p -> GHCupPath (tmpdir p)) $ filter (maybe False ("ghcup-" `isPrefixOf`) . lastMay . splitPath) ghcup_dirs) + + ------------------------------ --[ GHCup base directories ]-- ------------------------------ @@ -76,11 +196,11 @@ import Control.Concurrent (threadDelay) -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec. -ghcupBaseDir :: IO FilePath +ghcupBaseDir :: IO GHCupPath ghcupBaseDir | isWindows = do bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX" - pure (bdir "ghcup") + pure (GHCupPath (bdir "ghcup")) | otherwise = do xdg <- useXDG if xdg @@ -90,19 +210,19 @@ ghcupBaseDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".local" "share") - pure (bdir "ghcup") + pure (GHCupPath (bdir "ghcup")) else do bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case Just r -> pure r Nothing -> liftIO getHomeDirectory - pure (bdir ".ghcup") + pure (GHCupPath (bdir ".ghcup")) -- | ~/.ghcup by default -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec. -ghcupConfigDir :: IO FilePath +ghcupConfigDir :: IO GHCupPath ghcupConfigDir | isWindows = ghcupBaseDir | otherwise = do @@ -114,12 +234,12 @@ ghcupConfigDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".config") - pure (bdir "ghcup") + pure (GHCupPath (bdir "ghcup")) else do bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case Just r -> pure r Nothing -> liftIO getHomeDirectory - pure (bdir ".ghcup") + pure (GHCupPath (bdir ".ghcup")) -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything), @@ -127,7 +247,7 @@ ghcupConfigDir -- (which, sadly is not strictly xdg spec). ghcupBinDir :: IO FilePath ghcupBinDir - | isWindows = ghcupBaseDir <&> ( "bin") + | isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> ( "bin") | otherwise = do xdg <- useXDG if xdg @@ -137,16 +257,16 @@ ghcupBinDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".local" "bin") - else ghcupBaseDir <&> ( "bin") + else (fromGHCupPath <$> ghcupBaseDir) <&> ( "bin") -- | Defaults to '~/.ghcup/cache'. -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec. -ghcupCacheDir :: IO FilePath +ghcupCacheDir :: IO GHCupPath ghcupCacheDir - | isWindows = ghcupBaseDir <&> ( "cache") + | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "cache")) | otherwise = do xdg <- useXDG if xdg @@ -156,17 +276,17 @@ ghcupCacheDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".cache") - pure (bdir "ghcup") - else ghcupBaseDir <&> ( "cache") + pure (GHCupPath (bdir "ghcup")) + else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "cache")) -- | Defaults to '~/.ghcup/logs'. -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec. -ghcupLogsDir :: IO FilePath +ghcupLogsDir :: IO GHCupPath ghcupLogsDir - | isWindows = ghcupBaseDir <&> ( "logs") + | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "logs")) | otherwise = do xdg <- useXDG if xdg @@ -176,16 +296,55 @@ ghcupLogsDir Nothing -> do home <- liftIO getHomeDirectory pure (home ".cache") - pure (bdir "ghcup" "logs") - else ghcupBaseDir <&> ( "logs") + pure (GHCupPath (bdir "ghcup" "logs")) + else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "logs")) + + +-- | Defaults to '~/.ghcup/db. +-- +-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), +-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec. +ghcupDbDir :: IO GHCupPath +ghcupDbDir + | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "db")) + | otherwise = do + xdg <- useXDG + if xdg + then do + bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case + Just r -> pure r + Nothing -> do + home <- liftIO getHomeDirectory + pure (home ".cache") + pure (GHCupPath (bdir "ghcup" "db")) + else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "db")) -- | '~/.ghcup/trash'. -- Mainly used on windows to improve file removal operations -ghcupRecycleDir :: IO FilePath -ghcupRecycleDir = ghcupBaseDir <&> ( "trash") +ghcupRecycleDir :: IO GHCupPath +ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "trash")) +-- | Defaults to '~/.ghcup/tmp. +-- +-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), +-- then uses 'XDG_CACHE_HOME/ghcup/tmp as per xdg spec. +ghcupTMPDir :: IO GHCupPath +ghcupTMPDir + | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "tmp")) + | otherwise = do + xdg <- useXDG + if xdg + then do + bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case + Just r -> pure r + Nothing -> do + home <- liftIO getHomeDirectory + pure (home ".cache") + pure (GHCupPath (bdir "ghcup" "tmp")) + else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp "tmp")) + getAllDirs :: IO Dirs getAllDirs = do @@ -195,6 +354,8 @@ getAllDirs = do logsDir <- ghcupLogsDir confDir <- ghcupConfigDir recycleDir <- ghcupRecycleDir + tmpDir <- ghcupTMPDir + dbDir <- ghcupDbDir pure Dirs { .. } @@ -206,16 +367,21 @@ getAllDirs = do getConfigFilePath :: (MonadIO m) => m FilePath getConfigFilePath = do confDir <- liftIO ghcupConfigDir - pure $ confDir "config.yaml" + pure $ fromGHCupPath confDir "config.yaml" ghcupConfigFile :: (MonadIO m) => Excepts '[JSONError] m UserSettings ghcupConfigFile = do filepath <- getConfigFilePath - contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath + contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath case contents of Nothing -> pure defaultUserSettings - Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents' + Just contents' -> liftE + . veitherToExcepts @_ @'[JSONError] + . either (VLeft . V) VRight + . first (JSONDecodeError . displayException) + . Y.decodeEither' + $ contents' ------------------------- @@ -224,10 +390,10 @@ ghcupConfigFile = do -- | ~/.ghcup/ghc by default. -ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath +ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupGHCBaseDir = do Dirs {..} <- getDirs - pure (baseDir "ghc") + pure (baseDir `appendGHCupPath` "ghc") -- | Gets '~/.ghcup/ghc/'. @@ -236,11 +402,11 @@ ghcupGHCBaseDir = do -- * 8.8.4 ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion - -> m FilePath + -> m GHCupPath ghcupGHCDir ver = do ghcbasedir <- ghcupGHCBaseDir let verdir = T.unpack $ tVerToText ver - pure (ghcbasedir verdir) + pure (ghcbasedir `appendGHCupPath` verdir) -- | See 'ghcupToolParser'. @@ -252,20 +418,27 @@ parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version parseGHCupHLSDir (T.pack -> fp) = throwEither $ MP.parse version' "" fp +-- TODO: inlined from GHCup.Prelude +throwEither :: (Exception a, MonadThrow m) => Either a b -> m b +throwEither a = case a of + Left e -> throwM e + Right r -> pure r + -- | ~/.ghcup/hls by default, for new-style installs. -ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath +ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupHLSBaseDir = do Dirs {..} <- getDirs - pure (baseDir "hls") + pure (baseDir `appendGHCupPath` "hls") -- | Gets '~/.ghcup/hls/' for new-style installs. ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m) => Version - -> m FilePath + -> m GHCupPath ghcupHLSDir ver = do basedir <- ghcupHLSBaseDir let verdir = T.unpack $ prettyVer ver - pure (basedir verdir) + pure (basedir `appendGHCupPath` verdir) + mkGhcupTmpDir :: ( MonadReader env m , HasDirs env @@ -275,31 +448,10 @@ mkGhcupTmpDir :: ( MonadReader env m , MonadThrow m , MonadMask m , MonadIO m) - => m FilePath -mkGhcupTmpDir = do - tmpdir <- liftIO getCanonicalTemporaryDirectory - - let minSpace = 5000 -- a rough guess, aight? - space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir - when (maybe False (toBytes minSpace >) space) $ do - logWarn ("Possibly insufficient disk space on " - <> T.pack tmpdir - <> ". At least " - <> T.pack (show minSpace) - <> " MB are recommended, but only " - <> toMB (fromJust space) - <> " are free. Consider freeing up disk space or setting TMPDIR env variable.") - logWarn - "...waiting for 10 seconds before continuing anyway, you can still abort..." - liftIO $ threadDelay 10000000 -- give the user a sec to intervene - - liftIO $ createTempDirectory tmpdir "ghcup" - where - toBytes mb = mb * 1024 * 1024 - toMB b = T.pack $ show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2) - truncate' :: Double -> Int -> Double - truncate' x n = fromIntegral (floor (x * t) :: Integer) / t - where t = 10^n + => m GHCupPath +mkGhcupTmpDir = GHCupPath <$> do + Dirs { tmpDir } <- getDirs + liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup" withGHCupTmpDir :: ( MonadReader env m @@ -312,15 +464,15 @@ withGHCupTmpDir :: ( MonadReader env m , MonadThrow m , MonadMask m , MonadIO m) - => m FilePath + => m GHCupPath withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) (\fp -> handleIO (\e -> run - $ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))) - . rmPathForcibly + $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e))) + . removePathForcibly $ fp)) @@ -360,12 +512,28 @@ cleanupTrash :: ( MonadIO m => m () cleanupTrash = do Dirs { recycleDir } <- getDirs - contents <- liftIO $ listDirectory recycleDir + contents <- liftIO $ listDirectory (fromGHCupPath recycleDir) if null contents then pure () else do - logWarn ("Removing leftover files in " <> T.pack recycleDir) + logWarn ("Removing leftover files in " <> T.pack (fromGHCupPath recycleDir)) forM_ contents (\fp -> handleIO (\e -> logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)) - ) $ liftIO $ removePathForcibly (recycleDir fp)) + ) $ liftIO $ removePathForcibly (recycleDir `appendGHCupPath` fp)) + + + +-- System.Directory re-exports with GHCupPath + +removeDirectory :: GHCupPath -> IO () +removeDirectory (GHCupPath fp) = SD.removeDirectory fp + +removeDirectoryRecursive :: GHCupPath -> IO () +removeDirectoryRecursive (GHCupPath fp) = SD.removeDirectoryRecursive fp + +removePathForcibly :: GHCupPath -> IO () +removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp + + + diff --git a/lib/GHCup/Utils/Dirs.hs-boot b/lib/GHCup/Utils/Dirs.hs-boot new file mode 100644 index 0000000..bf19c91 --- /dev/null +++ b/lib/GHCup/Utils/Dirs.hs-boot @@ -0,0 +1,37 @@ +module GHCup.Utils.Dirs + ( GHCupPath + , appendGHCupPath + , fromGHCupPath + , createTempGHCupDirectory + , removeDirectory + , removeDirectoryRecursive + , removePathForcibly + ) + where + +import Control.DeepSeq (NFData) + + +-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted. +newtype GHCupPath = GHCupPath FilePath + +instance Show GHCupPath where + +instance Eq GHCupPath where + +instance Ord GHCupPath where + +instance NFData GHCupPath where + +appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath + +fromGHCupPath :: GHCupPath -> FilePath + +createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath + +removeDirectory :: GHCupPath -> IO () + +removeDirectoryRecursive :: GHCupPath -> IO () + +removePathForcibly :: GHCupPath -> IO () + diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs deleted file mode 100644 index 9f74867..0000000 --- a/lib/GHCup/Utils/File.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE CPP #-} - -module GHCup.Utils.File ( - module GHCup.Utils.File.Common, -#if IS_WINDOWS - module GHCup.Utils.File.Windows -#else - module GHCup.Utils.File.Posix -#endif -) where - -import GHCup.Utils.File.Common -#if IS_WINDOWS -import GHCup.Utils.File.Windows -#else -import GHCup.Utils.File.Posix -#endif diff --git a/lib/GHCup/Utils/File/Common.hs-boot b/lib/GHCup/Utils/File/Common.hs-boot deleted file mode 100644 index 5933883..0000000 --- a/lib/GHCup/Utils/File/Common.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module GHCup.Utils.File.Common where - -import Text.Regex.Posix - -findFiles :: FilePath -> Regex -> IO [FilePath] diff --git a/lib/GHCup/Utils/Logger.hs-boot b/lib/GHCup/Utils/Logger.hs-boot deleted file mode 100644 index 9e3b1b9..0000000 --- a/lib/GHCup/Utils/Logger.hs-boot +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} - -module GHCup.Utils.Logger where - -import GHCup.Types - -import Control.Monad.IO.Class -import Control.Monad.Reader -import Data.Text ( Text ) -import Optics - -logWarn :: ( MonadReader env m - , LabelOptic' "loggerConfig" A_Lens env LoggerConfig - , MonadIO m - ) - => Text - -> m () - diff --git a/lib/GHCup/Utils/Prelude/Posix.hs b/lib/GHCup/Utils/Prelude/Posix.hs deleted file mode 100644 index 22ae3cb..0000000 --- a/lib/GHCup/Utils/Prelude/Posix.hs +++ /dev/null @@ -1,20 +0,0 @@ -module GHCup.Utils.Prelude.Posix where - -import System.Directory -import System.Posix.Files - - -isWindows, isNotWindows :: Bool -isWindows = False -isNotWindows = not isWindows - - -moveFile :: FilePath -> FilePath -> IO () -moveFile = rename - - -moveFilePortable :: FilePath -> FilePath -> IO () -moveFilePortable from to = do - copyFile from to - removeFile from - diff --git a/lib/GHCup/Utils/Prelude/Windows.hs b/lib/GHCup/Utils/Prelude/Windows.hs deleted file mode 100644 index 914b374..0000000 --- a/lib/GHCup/Utils/Prelude/Windows.hs +++ /dev/null @@ -1,17 +0,0 @@ -module GHCup.Utils.Prelude.Windows where - -import qualified System.Win32.File as Win32 - - -isWindows, isNotWindows :: Bool -isWindows = True -isNotWindows = not isWindows - - -moveFile :: FilePath -> FilePath -> IO () -moveFile from to = Win32.moveFileEx from (Just to) 0 - - -moveFilePortable :: FilePath -> FilePath -> IO () -moveFilePortable = Win32.moveFile - diff --git a/lib/GHCup/Version.hs b/lib/GHCup/Version.hs index 37926cb..065a49b 100644 --- a/lib/GHCup/Version.hs +++ b/lib/GHCup/Version.hs @@ -16,12 +16,18 @@ import GHCup.Types import Paths_ghcup (version) import Data.Version (Version(versionBranch)) -import Data.Versions hiding (version) import URI.ByteString import URI.ByteString.QQ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T +import qualified Data.Versions as V +import Control.Exception.Safe (MonadThrow) +import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.List (intersperse) +import Control.Monad.Catch (throwM) +import GHCup.Errors (ParseError(..)) -- | This reflects the API version of the YAML. -- @@ -31,22 +37,72 @@ ghcupURL :: URI ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml|] -- | The current ghcup version. -ghcUpVer :: PVP -ghcUpVer = PVP . NE.fromList . fmap fromIntegral $ versionBranch version +ghcUpVer :: V.PVP +ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version -- | ghcup version as numeric string. numericVer :: String -numericVer = T.unpack . prettyPVP $ ghcUpVer +numericVer = T.unpack . V.prettyPVP $ ghcUpVer -versionCmp :: Versioning -> VersionCmp -> Bool +versionCmp :: V.Versioning -> VersionCmp -> Bool versionCmp ver1 (VR_gt ver2) = ver1 > ver2 versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2 versionCmp ver1 (VR_lt ver2) = ver1 < ver2 versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2 versionCmp ver1 (VR_eq ver2) = ver1 == ver2 -versionRange :: Versioning -> VersionRange -> Bool +versionRange :: V.Versioning -> VersionRange -> Bool versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps versionRange ver' (OrRange cmps range) = versionRange ver' (SimpleRange cmps) || versionRange ver' range +pvpToVersion :: MonadThrow m => V.PVP -> Text -> m V.Version +pvpToVersion pvp_ rest = + either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . V.version . (<> rest) . V.prettyPVP $ pvp_ + +-- | Convert a version to a PVP and unparsable rest. +-- +-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v +versionToPVP :: MonadThrow m => V.Version -> m (V.PVP, Text) +versionToPVP (V.Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch" +versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . V.pvp . V.prettyVer $ v + where + alternative :: MonadThrow m => V.Version -> m V.PVP + alternative v' = case NE.takeWhile isDigit (V._vChunks v') of + [] -> throwM $ ParseError "Couldn't convert Version to PVP" + xs -> pure $ pvpFromList (unsafeDigit <$> xs) + + rest :: V.Version -> Text + rest (V.Version _ cs pr me) = + let chunks = NE.dropWhile isDigit cs + ver = intersperse (T.pack ".") . chunksAsT $ chunks + me' = maybe [] (\m -> [T.pack "+",m]) me + pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr) + prefix = case (ver, pr', me') of + (_:_, _, _) -> T.pack "." + _ -> T.pack "" + in prefix <> mconcat (ver <> pr' <> me') + where + chunksAsT :: Functor t => t V.VChunk -> t Text + chunksAsT = fmap (foldMap f) + where + f :: V.VUnit -> Text + f (V.Digits i) = T.pack $ show i + f (V.Str s) = s + + foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b + foldable d g f | null f = d + | otherwise = g f + + + + isDigit :: V.VChunk -> Bool + isDigit (V.Digits _ :| []) = True + isDigit _ = False + + unsafeDigit :: V.VChunk -> Int + unsafeDigit (V.Digits x :| []) = fromIntegral x + unsafeDigit _ = error "unsafeDigit: wrong input" + +pvpFromList :: [Int] -> V.PVP +pvpFromList = V.PVP . NE.fromList . fmap fromIntegral diff --git a/stack.yaml b/stack.yaml index 14c8bbf..ae66e8d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -26,7 +26,7 @@ extra-deps: - hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179 - http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582 - libarchive-3.0.3.0 - - libyaml-streamly-0.2.0 + - libyaml-streamly-0.2.1 - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308 - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568 - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995 @@ -35,10 +35,11 @@ extra-deps: - os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716 - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728 - regex-posix-clib-2.7 - - streamly-0.8.0@sha256:9784c80ee1ada51477520cabc4e92a0c76a6bb265f968a188f2fce818e7398e0,19654 + - streamly-0.8.2@sha256:ec521b7c1c4db068501c35804af77f40b7d34232f5e29d9b99e722229040eb80,23500 + - unicode-data-0.3.0@sha256:0545e079705a5381d0893f8fe8daaa08fc9174baeab269b9cf651817d8eadbc6,5123 - strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248 - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243 - - yaml-streamly-0.12.0 + - yaml-streamly-0.12.1 flags: http-io-streams: @@ -56,6 +57,9 @@ flags: cabal-plan: exe: false + streamly: + use-unliftio: true + ghc-options: "$locals": -O2 streamly: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 diff --git a/test/GHCup/Utils/FileSpec.hs b/test/GHCup/Utils/FileSpec.hs new file mode 100644 index 0000000..aac4e3d --- /dev/null +++ b/test/GHCup/Utils/FileSpec.hs @@ -0,0 +1,58 @@ +module GHCup.Utils.FileSpec where + +import GHCup.Prelude.File + +import Data.List +import System.Directory +import System.FilePath +import System.IO.Unsafe +import qualified Streamly.Prelude as S + +import Test.Hspec + + + +spec :: Spec +spec = do + describe "GHCup.Utils.File" $ do + it "getDirectoryContentsRecursiveBFS" $ do + l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe "lib") + l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib" + not (null l1) `shouldBe` True + not (null l2) `shouldBe` True + l1 `shouldBe` l2 + it "getDirectoryContentsRecursiveDFS" $ do + l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe "lib") + l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib" + not (null l1) `shouldBe` True + not (null l2) `shouldBe` True + l1 `shouldBe` l2 + + +getDirectoryContentsRecursiveLazy :: FilePath -> IO [FilePath] +getDirectoryContentsRecursiveLazy topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + + where + collect files dirs' [] = return (reverse files + ,reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + + diff --git a/test/Main.hs b/test/Main.hs index ef4a513..dda9536 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,10 +1,9 @@ import Test.Hspec.Runner -import Test.Hspec.Formatters import qualified Spec main :: IO () main = hspecWith - defaultConfig { configFormatter = Just progress } + defaultConfig Spec.spec