Merge branch 'issue-364'
This commit is contained in:
commit
e1d86c77d0
GPG Key ID:
3786C5262ECB4A3F
112
.gitlab-ci.yml
112
.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"
|
||||
|
||||
@ -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
|
||||
|
||||
19
.gitlab/script/brew.sh
Executable file
19
.gitlab/script/brew.sh
Executable file
@ -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+"$@"}
|
||||
70
.gitlab/script/ci.sh
Executable file
70
.gitlab/script/ci.sh
Executable file
@ -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
|
||||
@ -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 ]
|
||||
|
||||
|
||||
|
||||
@ -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"}
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
|
||||
@ -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 )
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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 )
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 )
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 )
|
||||
|
||||
@ -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 )
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
7
cbits/dirutils.c
Normal file
7
cbits/dirutils.c
Normal file
@ -0,0 +1,7 @@
|
||||
#include "dirutils.h"
|
||||
|
||||
unsigned int
|
||||
__posixdir_d_type(struct dirent* d)
|
||||
{
|
||||
return(d -> d_type);
|
||||
}
|
||||
15
cbits/dirutils.h
Normal file
15
cbits/dirutils.h
Normal file
@ -0,0 +1,15 @@
|
||||
#ifndef POSIXPATHS_CBITS_DIRUTILS_H
|
||||
#define POSIXPATHS_CBITS_DIRUTILS_H
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <dirent.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
#include <fcntl.h>
|
||||
|
||||
|
||||
extern unsigned int
|
||||
__posixdir_d_type(struct dirent* d)
|
||||
;
|
||||
|
||||
#endif
|
||||
@ -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
|
||||
|
||||
46
ghcup.cabal
46
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
|
||||
@ -51,24 +51,32 @@ flag no-exe
|
||||
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
|
||||
|
||||
2569
lib/GHCup.hs
2569
lib/GHCup.hs
File diff suppressed because it is too large
Load Diff
279
lib/GHCup/Cabal.hs
Normal file
279
lib/GHCup/Cabal.hs
Normal file
@ -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-\<ver\>@ 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)
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
1078
lib/GHCup/GHC.hs
Normal file
1078
lib/GHCup/GHC.hs
Normal file
File diff suppressed because it is too large
Load Diff
620
lib/GHCup/HLS.hs
Normal file
620
lib/GHCup/HLS.hs
Normal file
@ -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-<ghcver>
|
||||
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-\<ghcver\>@
|
||||
-- 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-<ghcver> 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 ()
|
||||
410
lib/GHCup/List.hs
Normal file
410
lib/GHCup/List.hs
Normal file
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
54
lib/GHCup/Prelude.hs
Normal file
54
lib/GHCup/Prelude.hs
Normal file
@ -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))
|
||||
|
||||
426
lib/GHCup/Prelude/File.hs
Normal file
426
lib/GHCup/Prelude/File.hs
Normal file
@ -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
|
||||
324
lib/GHCup/Prelude/File/Posix.hs
Normal file
324
lib/GHCup/Prelude/File/Posix.hs
Normal file
@ -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
|
||||
|
||||
|
||||
58
lib/GHCup/Prelude/File/Posix/Foreign.hsc
Normal file
58
lib/GHCup/Prelude/File/Posix/Foreign.hsc
Normal file
@ -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 <limits.h>
|
||||
#include <stdlib.h>
|
||||
#include <dirent.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
#include <fcntl.h>
|
||||
|
||||
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
|
||||
|
||||
92
lib/GHCup/Prelude/File/Posix/Traversals.hs
Normal file
92
lib/GHCup/Prelude/File/Posix/Traversals.hs
Normal file
@ -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"
|
||||
|
||||
@ -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
|
||||
311
lib/GHCup/Prelude/File/Windows.hs
Normal file
311
lib/GHCup/Prelude/File/Windows.hs
Normal file
@ -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)
|
||||
@ -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
|
||||
|
||||
61
lib/GHCup/Prelude/Logger.hs
Normal file
61
lib/GHCup/Prelude/Logger.hs
Normal file
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
25
lib/GHCup/Prelude/Process.hs
Normal file
25
lib/GHCup/Prelude/Process.hs
Normal file
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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,7 +28,6 @@ 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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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 )
|
||||
@ -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
|
||||
|
||||
278
lib/GHCup/Stack.hs
Normal file
278
lib/GHCup/Stack.hs
Normal file
@ -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-\<ver\>@ 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)
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -1,4 +0,0 @@
|
||||
module GHCup.Utils where
|
||||
|
||||
getLinkTarget :: FilePath -> IO FilePath
|
||||
pathIsLink :: FilePath -> IO Bool
|
||||
@ -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/<ghcupGHCDir>'.
|
||||
@ -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/<hls-ver>' 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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
37
lib/GHCup/Utils/Dirs.hs-boot
Normal file
37
lib/GHCup/Utils/Dirs.hs-boot
Normal file
@ -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 ()
|
||||
|
||||
@ -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
|
||||
@ -1,5 +0,0 @@
|
||||
module GHCup.Utils.File.Common where
|
||||
|
||||
import Text.Regex.Posix
|
||||
|
||||
findFiles :: FilePath -> Regex -> IO [FilePath]
|
||||
@ -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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
10
stack.yaml
10
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
|
||||
|
||||
58
test/GHCup/Utils/FileSpec.hs
Normal file
58
test/GHCup/Utils/FileSpec.hs
Normal file
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user