Compare commits
1 Commits
windows-su
...
better-log
| Author | SHA1 | Date | |
|---|---|---|---|
|
8d3d3922f2
|
@@ -10,8 +10,8 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./gh
|
||||
chmod +x ghcup-bin
|
||||
|
||||
./ghcup-bin upgrade -i -f
|
||||
./ghcup-bin install ${GHC_VERSION}
|
||||
./ghcup-bin set ${GHC_VERSION}
|
||||
./ghcup-bin install-cabal ${CABAL_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
|
||||
|
||||
exit 0
|
||||
|
||||
@@ -12,8 +12,8 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > .
|
||||
chmod +x ghcup-bin
|
||||
|
||||
./ghcup-bin upgrade -i -f
|
||||
./ghcup-bin install ${GHC_VERSION}
|
||||
./ghcup-bin set ${GHC_VERSION}
|
||||
./ghcup-bin install-cabal ${CABAL_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
|
||||
|
||||
exit 0
|
||||
|
||||
@@ -28,8 +28,8 @@ else
|
||||
fi
|
||||
chmod +x ghcup-bin
|
||||
./ghcup-bin upgrade -i -f
|
||||
./ghcup-bin install ${GHC_VERSION}
|
||||
./ghcup-bin install-cabal ${CABAL_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
|
||||
|
||||
# utils
|
||||
apk add --no-cache \
|
||||
@@ -41,9 +41,6 @@ apk add --no-cache \
|
||||
zlib \
|
||||
zlib-dev \
|
||||
zlib-static \
|
||||
bzip2 \
|
||||
bzip2-dev \
|
||||
bzip2-static \
|
||||
gmp \
|
||||
gmp-dev \
|
||||
openssl-dev \
|
||||
|
||||
@@ -7,13 +7,13 @@ set -eux
|
||||
mkdir -p "${TMPDIR}"
|
||||
|
||||
sudo apt-get update -y
|
||||
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget
|
||||
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev git wget
|
||||
|
||||
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > ./ghcup-bin
|
||||
chmod +x ghcup-bin
|
||||
|
||||
./ghcup-bin upgrade -i -f
|
||||
./ghcup-bin install ${GHC_VERSION}
|
||||
./ghcup-bin set ${GHC_VERSION}
|
||||
./ghcup-bin install-cabal ${CABAL_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
|
||||
./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
|
||||
|
||||
|
||||
@@ -19,7 +19,7 @@ ednf() {
|
||||
}
|
||||
|
||||
ednf update
|
||||
ednf install gcc gcc-c++ gmp gmp-devel make ncurses ncurses-devel xz xz-devel perl zlib zlib-devel openssl-devel openssl-libs openssl libffi libffi-devel lbzip2 lbzip2-utils bzip2-devel
|
||||
ednf install gcc gcc-c++ gmp gmp-devel make ncurses ncurses-devel xz xz-devel perl zlib zlib-devel openssl-devel openssl-libs openssl libffi libffi-devel lbzip2 lbzip2-utils
|
||||
if [ "${ARCH}" = "ARM64" ] ; then
|
||||
ednf install numactl numactl-libs numactl-devel
|
||||
fi
|
||||
|
||||
@@ -7,4 +7,4 @@ set -eux
|
||||
mkdir -p "${TMPDIR}"
|
||||
|
||||
sudo apt-get update -y
|
||||
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget
|
||||
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev git wget
|
||||
|
||||
@@ -7,11 +7,11 @@ set -eux
|
||||
mkdir -p "$CI_PROJECT_DIR"/.local/bin
|
||||
|
||||
ecabal() {
|
||||
cabal --store-dir="$CI_PROJECT_DIR"/.store "$@"
|
||||
cabal --store-dir="$(pwd)"/.store "$@"
|
||||
}
|
||||
|
||||
eghcup() {
|
||||
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
|
||||
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
|
||||
}
|
||||
|
||||
git describe --always
|
||||
@@ -96,19 +96,14 @@ eghcup set ${GHC_VERSION}
|
||||
eghcup rm 8.10.3
|
||||
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
|
||||
|
||||
# install hls
|
||||
if [ "${OS}" = "DARWIN" ] ; then
|
||||
eghcup install hls
|
||||
haskell-language-server-wrapper --version
|
||||
|
||||
eghcup install stack
|
||||
stack --version
|
||||
elif [ "${OS}" = "LINUX" ] ; then
|
||||
if [ "${ARCH}" = "64" ] ; then
|
||||
eghcup install hls
|
||||
haskell-language-server-wrapper --version
|
||||
|
||||
eghcup install stack
|
||||
stack --version
|
||||
fi
|
||||
fi
|
||||
|
||||
@@ -116,12 +111,8 @@ fi
|
||||
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 rm cabal 3.4.0.0-rc4
|
||||
fi
|
||||
fi
|
||||
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 rm cabal 3.4.0.0-rc4
|
||||
|
||||
eghcup upgrade
|
||||
eghcup upgrade -f
|
||||
|
||||
@@ -5,11 +5,6 @@
|
||||
* Add date to GHC bindist names created by ghcup
|
||||
* Warn when /tmp doesn't have 5GB or more of disk space
|
||||
* Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126)
|
||||
* Add stack support
|
||||
|
||||
## 0.1.14.2 -- 2021-05-12
|
||||
|
||||
* Remove dead dependency on ascii-string
|
||||
|
||||
## 0.1.14.1 -- 2021-04-11
|
||||
|
||||
|
||||
@@ -6,6 +6,10 @@
|
||||
|
||||
This is an open variant, similar to [plucky](https://hackage.haskell.org/package/plucky) or [oops](https://github.com/i-am-tom/oops) and allows us to combine different error types. Maybe it is too much and it's a little bit [unergonomic](https://github.com/haskus/packages/issues/32) at times. If it really hurts maintenance, it will be removed. It was more of an experiment.
|
||||
|
||||
### No use of filepath or directory
|
||||
|
||||
Filepath and directory have two fundamental problems: 1. they use String as filepath (see [AFPP](https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/abstract-file-path) as to why this is wrong) and 2. they try very hard to be cross-platform at the expense of low-level correctness. Instead, we use the [hpath](https://github.com/hasufell/hpath) libraries for file and filepath related stuff, which also gives us stronger filepath types.
|
||||
|
||||
### No use of haskell-TLS
|
||||
|
||||
I consider haskell-TLS an interesting experiment, but not a battle-tested and peer-reviewed crypto implementation. There is little to no research about what the intricacies of using haskell for low-level crypto are and how vulnerable such binaries are. Instead, we use either curl the binary (for FreeBSD and mac) or http-io-streams, which works with OpenSSL bindings.
|
||||
|
||||
@@ -4,6 +4,8 @@ It follows the unix UNIX philosophy of [do one thing and do it well](https://en.
|
||||
|
||||
Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be).
|
||||
|
||||
*Ubuntu users may prefer [hvr's ppa](https://launchpad.net/~hvr/+archive/ubuntu/ghc).*
|
||||
|
||||
## Table of Contents
|
||||
|
||||
* [Installation](#installation)
|
||||
@@ -77,7 +79,7 @@ ghcup install cabal
|
||||
ghcup upgrade
|
||||
```
|
||||
|
||||
GHCup works very well with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
|
||||
Generally this is meant to be used with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
|
||||
handles your haskell packages and can demand that [a specific version](https://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-flag---with-compiler) of `ghc` is available, which `ghcup` can do.
|
||||
|
||||
### Configuration
|
||||
@@ -234,8 +236,8 @@ ghcup is not a reimplementation of stack. The only common part is automatic inst
|
||||
|
||||
2. Why not support windows?
|
||||
|
||||
We do.
|
||||
Consider using [Chocolatey](https://chocolatey.org/search?q=ghc) or [ghcups](https://github.com/kakkun61/ghcups).
|
||||
|
||||
3. Why the haskell reimplementation?
|
||||
|
||||
:-)
|
||||
Why not?
|
||||
|
||||
@@ -37,11 +37,12 @@ import Data.IORef
|
||||
import Data.List
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import HPath ( toFilePath, rel )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import System.FilePath
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.Posix.FilePath
|
||||
import Text.ParserCombinators.ReadP
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import Text.Regex.Posix
|
||||
@@ -105,10 +106,6 @@ validate dls = do
|
||||
addError
|
||||
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn)
|
||||
[i|FreeBSD missing for #{t} #{v'} #{arch'}|]
|
||||
when (notElem Windows pspecs && arch == A_64) $ do
|
||||
lift $ $(logError)
|
||||
[i|Windows missing for for #{t} #{v'} #{arch'}|]
|
||||
addError
|
||||
|
||||
-- alpine needs to be set explicitly, because
|
||||
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
|
||||
@@ -241,7 +238,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
|
||||
$ do
|
||||
case tool of
|
||||
Just GHCup -> do
|
||||
let fn = "ghcup"
|
||||
let fn = [rel|ghcup|]
|
||||
dir <- liftIO ghcupCacheDir
|
||||
p <- liftE $ download dli dir (Just fn)
|
||||
liftE $ checkDigest dli p
|
||||
@@ -255,7 +252,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
|
||||
case r of
|
||||
VRight (Just basePath) -> do
|
||||
case _dlSubdir dli of
|
||||
Just (RealDir prel) -> do
|
||||
Just (RealDir (toFilePath -> prel)) -> do
|
||||
lift $ $(logInfo)
|
||||
[i|verifying subdir: #{prel}|]
|
||||
when (basePath /= prel) $ do
|
||||
|
||||
@@ -14,7 +14,6 @@ import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Prelude ( decUTF8Safe )
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
|
||||
@@ -67,8 +66,7 @@ data BrickData = BrickData
|
||||
deriving Show
|
||||
|
||||
data BrickSettings = BrickSettings
|
||||
{ showAllVersions :: Bool
|
||||
, showAllTools :: Bool
|
||||
{ showAll :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
@@ -99,22 +97,17 @@ keyHandlers KeyBindings {..} =
|
||||
, (bUninstall, const "Uninstall", withIOAction del')
|
||||
, (bSet, const "Set" , withIOAction set')
|
||||
, (bChangelog, const "ChangeLog", withIOAction changelog')
|
||||
, ( bShowAllVersions
|
||||
, ( bShowAll
|
||||
, \BrickSettings {..} ->
|
||||
if showAllVersions then "Don't show all versions" else "Show all versions"
|
||||
, hideShowHandler (not . showAllVersions) showAllTools
|
||||
)
|
||||
, ( bShowAllTools
|
||||
, \BrickSettings {..} ->
|
||||
if showAllTools then "Don't show all tools" else "Show all tools"
|
||||
, hideShowHandler showAllVersions (not . showAllTools)
|
||||
if showAll then "Hide old versions" else "Show all versions"
|
||||
, hideShowHandler
|
||||
)
|
||||
, (bUp, const "Up", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Up, .. })
|
||||
, (bDown, const "Down", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Down, .. })
|
||||
]
|
||||
where
|
||||
hideShowHandler f p BrickState{..} =
|
||||
let newAppSettings = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
|
||||
hideShowHandler BrickState{..} =
|
||||
let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
|
||||
newInternalState = constructList appData newAppSettings (Just appState)
|
||||
in continue (BrickState appData newAppSettings newInternalState appKeys)
|
||||
|
||||
@@ -149,12 +142,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
|
||||
<+> minHSize 15 (str "Version")
|
||||
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
|
||||
<+> padLeft (Pad 5) (str "Notes")
|
||||
renderList' = withDefAttr listAttr . drawListElements renderItem True . filterStack
|
||||
filterStack appState'
|
||||
| showAllTools as = appState'
|
||||
| let v = clr appState'
|
||||
nv = V.filter (\ListResult{..} -> lTool /= Stack) v
|
||||
, otherwise = BrickInternalState { clr = nv, ix = ix appState' }
|
||||
renderList' = withDefAttr listAttr . drawListElements renderItem True
|
||||
renderItem _ b listResult@ListResult{..} =
|
||||
let marks = if
|
||||
| lSet -> (withAttr "set" $ str "✔✔")
|
||||
@@ -206,7 +194,6 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
|
||||
printTool GHC = str "GHC"
|
||||
printTool GHCup = str "GHCup"
|
||||
printTool HLS = str "HLS"
|
||||
printTool Stack = str "Stack"
|
||||
|
||||
printNotes ListResult {..} =
|
||||
(if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
|
||||
@@ -364,7 +351,7 @@ constructList :: BrickData
|
||||
-> Maybe BrickInternalState
|
||||
-> BrickInternalState
|
||||
constructList appD appSettings =
|
||||
replaceLR (filterVisible (showAllVersions appSettings)) (lr appD)
|
||||
replaceLR (filterVisible (showAll appSettings)) (lr appD)
|
||||
|
||||
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
|
||||
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
|
||||
@@ -398,9 +385,9 @@ replaceLR filterF lr s =
|
||||
|
||||
|
||||
filterVisible :: Bool -> ListResult -> Bool
|
||||
filterVisible showAllVersions e | lInstalled e = True
|
||||
| showAllVersions = True
|
||||
| otherwise = not (elem Old (lTag e))
|
||||
filterVisible showAll e | lInstalled e = True
|
||||
| showAll = True
|
||||
| otherwise = not (elem Old (lTag e))
|
||||
|
||||
|
||||
install' :: BrickState -> (Int, ListResult) -> IO (Either String ())
|
||||
@@ -445,9 +432,6 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
||||
HLS -> do
|
||||
let vi = getVersionInfo lVer HLS dls
|
||||
liftE $ installHLSBin dls lVer pfreq $> vi
|
||||
Stack -> do
|
||||
let vi = getVersionInfo lVer Stack dls
|
||||
liftE $ installStackBin dls lVer pfreq $> vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
@@ -476,7 +460,6 @@ set' _ (_, ListResult {..}) = do
|
||||
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
|
||||
Cabal -> liftE $ setCabal lVer $> ()
|
||||
HLS -> liftE $ setHLS lVer $> ()
|
||||
Stack -> liftE $ setStack lVer $> ()
|
||||
GHCup -> pure ()
|
||||
)
|
||||
>>= \case
|
||||
@@ -498,7 +481,6 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
||||
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
|
||||
Cabal -> liftE $ rmCabalVer lVer $> vi
|
||||
HLS -> liftE $ rmHLSVer lVer $> vi
|
||||
Stack -> liftE $ rmStackVer lVer $> vi
|
||||
GHCup -> pure Nothing
|
||||
)
|
||||
>>= \case
|
||||
@@ -519,8 +501,7 @@ changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
||||
Darwin -> "open"
|
||||
Linux _ -> "xdg-open"
|
||||
FreeBSD -> "xdg-open"
|
||||
Windows -> "start"
|
||||
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
|
||||
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
|
||||
Right _ -> pure $ Right ()
|
||||
Left e -> pure $ Left $ prettyShow e
|
||||
|
||||
@@ -583,7 +564,7 @@ brickMain s l av pfreq' = do
|
||||
|
||||
|
||||
defaultAppSettings :: BrickSettings
|
||||
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
|
||||
defaultAppSettings = BrickSettings { showAll = False }
|
||||
|
||||
|
||||
getDownloads' :: IO (Either String GHCupDownloads)
|
||||
|
||||
@@ -53,6 +53,8 @@ import Data.Versions hiding ( str )
|
||||
import Data.Void
|
||||
import GHC.IO.Encoding
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Language.Haskell.TH
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
@@ -62,7 +64,6 @@ import System.Console.Pretty hiding ( color )
|
||||
import qualified System.Console.Pretty as Pretty
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.IO hiding ( appendFile )
|
||||
import Text.Read hiding ( lift )
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
@@ -125,7 +126,6 @@ toSetToolVer Nothing = SetRecommended
|
||||
data InstallCommand = InstallGHC InstallOptions
|
||||
| InstallCabal InstallOptions
|
||||
| InstallHLS InstallOptions
|
||||
| InstallStack InstallOptions
|
||||
|
||||
data InstallOptions = InstallOptions
|
||||
{ instVer :: Maybe ToolVersion
|
||||
@@ -137,7 +137,6 @@ data InstallOptions = InstallOptions
|
||||
data SetCommand = SetGHC SetOptions
|
||||
| SetCabal SetOptions
|
||||
| SetHLS SetOptions
|
||||
| SetStack SetOptions
|
||||
|
||||
-- a superset of ToolVersion
|
||||
data SetToolVersion = SetToolVersion GHCTargetVersion
|
||||
@@ -158,7 +157,6 @@ data ListOptions = ListOptions
|
||||
data RmCommand = RmGHC RmOptions
|
||||
| RmCabal Version
|
||||
| RmHLS Version
|
||||
| RmStack Version
|
||||
|
||||
data RmOptions = RmOptions
|
||||
{ ghcVer :: GHCTargetVersion
|
||||
@@ -169,17 +167,17 @@ data CompileCommand = CompileGHC GHCCompileOptions
|
||||
|
||||
data GHCCompileOptions = GHCCompileOptions
|
||||
{ targetGhc :: Either Version GitBranch
|
||||
, bootstrapGhc :: Either Version FilePath
|
||||
, bootstrapGhc :: Either Version (Path Abs)
|
||||
, jobs :: Maybe Int
|
||||
, buildConfig :: Maybe FilePath
|
||||
, patchDir :: Maybe FilePath
|
||||
, buildConfig :: Maybe (Path Abs)
|
||||
, patchDir :: Maybe (Path Abs)
|
||||
, crossTarget :: Maybe Text
|
||||
, addConfArgs :: [Text]
|
||||
, setCompile :: Bool
|
||||
}
|
||||
|
||||
data UpgradeOpts = UpgradeInplace
|
||||
| UpgradeAt FilePath
|
||||
| UpgradeAt (Path Abs)
|
||||
| UpgradeGHCupDir
|
||||
deriving Show
|
||||
|
||||
@@ -434,15 +432,6 @@ installParser =
|
||||
<> footerDoc (Just $ text installHLSFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"stack"
|
||||
( InstallStack
|
||||
<$> info
|
||||
(installOpts (Just Stack) <**> helper)
|
||||
( progDesc "Install stack"
|
||||
<> footerDoc (Just $ text installStackFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> installOpts Nothing)
|
||||
@@ -453,17 +442,9 @@ installParser =
|
||||
into "~/.ghcup/bin"
|
||||
|
||||
Examples:
|
||||
# install recommended HLS
|
||||
# install recommended GHC
|
||||
ghcup install hls|]
|
||||
|
||||
installStackFooter :: String
|
||||
installStackFooter = [s|Discussion:
|
||||
Installs stack binaries into "~/.ghcup/bin"
|
||||
|
||||
Examples:
|
||||
# install recommended Stack
|
||||
ghcup install stack|]
|
||||
|
||||
installGHCFooter :: String
|
||||
installGHCFooter = [s|Discussion:
|
||||
Installs the specified GHC version (or a recommended default one) into
|
||||
@@ -547,15 +528,6 @@ setParser =
|
||||
<> footerDoc (Just $ text setHLSFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"stack"
|
||||
( SetStack
|
||||
<$> info
|
||||
(setOpts (Just Stack) <**> helper)
|
||||
( progDesc "Set stack version"
|
||||
<> footerDoc (Just $ text setStackFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> setOpts Nothing)
|
||||
@@ -570,10 +542,6 @@ setParser =
|
||||
setCabalFooter = [s|Discussion:
|
||||
Sets the the current Cabal version.|]
|
||||
|
||||
setStackFooter :: String
|
||||
setStackFooter = [s|Discussion:
|
||||
Sets the the current Stack version.|]
|
||||
|
||||
setHLSFooter :: String
|
||||
setHLSFooter = [s|Discussion:
|
||||
Sets the the current haskell-language-server version.|]
|
||||
@@ -626,12 +594,6 @@ rmParser =
|
||||
<$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
|
||||
(progDesc "Remove haskell-language-server version")
|
||||
)
|
||||
<> command
|
||||
"stack"
|
||||
( RmStack
|
||||
<$> info (versionParser' (Just ListInstalled) (Just Stack) <**> helper)
|
||||
(progDesc "Remove stack version")
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (Right <$> rmOpts Nothing)
|
||||
@@ -653,7 +615,6 @@ changelogP =
|
||||
"ghc" -> Right GHC
|
||||
"cabal" -> Right Cabal
|
||||
"ghcup" -> Right GHCup
|
||||
"stack" -> Right Stack
|
||||
e -> Left e
|
||||
)
|
||||
)
|
||||
@@ -720,7 +681,8 @@ ghcCompileOpts =
|
||||
<*> option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
(bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
|
||||
(bimap (const "Not a valid version") Left . version . T.pack $ x)
|
||||
<|> (bimap show Right . parseAbs . E.encodeUtf8 . T.pack $ x)
|
||||
)
|
||||
)
|
||||
( short 'b'
|
||||
@@ -738,14 +700,26 @@ ghcCompileOpts =
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
str
|
||||
(eitherReader
|
||||
(\x ->
|
||||
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
(short 'c' <> long "config" <> metavar "CONFIG" <> help
|
||||
"Absolute path to build config file"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
str
|
||||
(eitherReader
|
||||
(\x ->
|
||||
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
|
||||
"Absolute path to patch directory (applied in order, uses -p1)"
|
||||
)
|
||||
@@ -1012,8 +986,7 @@ toSettings options = do
|
||||
, bUninstall = fromMaybe bUninstall kUninstall
|
||||
, bSet = fromMaybe bSet kSet
|
||||
, bChangelog = fromMaybe bChangelog kChangelog
|
||||
, bShowAllVersions = fromMaybe bShowAllVersions kShowAll
|
||||
, bShowAllTools = fromMaybe bShowAllTools kShowAllTools
|
||||
, bShowAll = fromMaybe bShowAll kShowAll
|
||||
}
|
||||
|
||||
|
||||
@@ -1026,7 +999,13 @@ upgradeOptsP =
|
||||
)
|
||||
<|> ( UpgradeAt
|
||||
<$> option
|
||||
str
|
||||
(eitherReader
|
||||
(\x ->
|
||||
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
|
||||
"Absolute filepath to write ghcup into"
|
||||
)
|
||||
@@ -1038,9 +1017,9 @@ upgradeOptsP =
|
||||
describe_result :: String
|
||||
describe_result = $( LitE . StringL <$>
|
||||
runIO (do
|
||||
CapturedProcess{..} <- executeOut "git" ["describe"] Nothing
|
||||
CapturedProcess{..} <- executeOut [rel|git|] ["describe"] Nothing
|
||||
case _exitCode of
|
||||
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
|
||||
ExitSuccess -> pure . T.unpack . decUTF8Safe $ _stdOut
|
||||
ExitFailure _ -> pure numericVer
|
||||
)
|
||||
)
|
||||
@@ -1094,7 +1073,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = verbose settings
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = B.appendFile logfile
|
||||
, rawOutter = appendFile logfile
|
||||
}
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
|
||||
@@ -1346,36 +1325,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
||||
pure $ ExitFailure 4
|
||||
|
||||
let installStack InstallOptions{..} =
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool $ do
|
||||
(v, vi) <- liftE $ fromVersion dls instVer Stack
|
||||
liftE $ installStackBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
|
||||
pure vi
|
||||
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
|
||||
(v, vi) <- liftE $ fromVersion dls instVer Stack
|
||||
liftE $ installStackBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
(_tvVersion v)
|
||||
(fromMaybe pfreq instPlatform)
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ $(logInfo) "Stack installation successful"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
runLogger $ $(logWarn)
|
||||
[i|Stack ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack #{prettyVer v}' first|]
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
$(logError) $ T.pack $ prettyShow e
|
||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
||||
pure $ ExitFailure 4
|
||||
|
||||
|
||||
let setGHC' SetOptions{..} =
|
||||
runSetGHC (do
|
||||
@@ -1424,22 +1373,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let setStack' SetOptions{..} =
|
||||
runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' dls sToolVer Stack
|
||||
liftE $ setStack (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
$ $(logInfo)
|
||||
[i|Stack #{prettyVer _tvVersion} successfully set as default version|]
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let rmGHC' RmOptions{..} =
|
||||
runRm (do
|
||||
liftE $
|
||||
@@ -1485,20 +1418,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
let rmStack' tv =
|
||||
runRm (do
|
||||
liftE $
|
||||
rmStackVer tv
|
||||
pure (getVersionInfo tv Stack dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (_viPostRemove =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
res <- case optCommand of
|
||||
#if defined(BRICK)
|
||||
@@ -1510,7 +1429,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
Install (Left (InstallGHC iopts)) -> installGHC iopts
|
||||
Install (Left (InstallCabal iopts)) -> installCabal iopts
|
||||
Install (Left (InstallHLS iopts)) -> installHLS iopts
|
||||
Install (Left (InstallStack iopts)) -> installStack iopts
|
||||
InstallCabalLegacy iopts -> do
|
||||
runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
|
||||
installCabal iopts
|
||||
@@ -1521,7 +1439,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
Set (Left (SetGHC sopts)) -> setGHC' sopts
|
||||
Set (Left (SetCabal sopts)) -> setCabal' sopts
|
||||
Set (Left (SetHLS sopts)) -> setHLS' sopts
|
||||
Set (Left (SetStack sopts)) -> setStack' sopts
|
||||
|
||||
List ListOptions {..} ->
|
||||
runListGHC (do
|
||||
@@ -1536,7 +1453,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
|
||||
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
|
||||
Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
|
||||
Rm (Left (RmStack rmopts)) -> rmStack' rmopts
|
||||
|
||||
DInfo ->
|
||||
do runDebugInfo $ liftE getDebugInfo
|
||||
@@ -1596,9 +1512,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
|
||||
Upgrade uOpts force -> do
|
||||
target <- case uOpts of
|
||||
UpgradeInplace -> Just <$> liftIO getExecutablePath
|
||||
UpgradeInplace -> do
|
||||
efp <- liftIO getExecutablePath
|
||||
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
|
||||
pure $ Just p
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup"))
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
|
||||
|
||||
runUpgrade (liftE $ upgradeGHCup dls target force pfreq) >>= \case
|
||||
VRight v' -> do
|
||||
@@ -1654,12 +1573,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
Darwin -> "open"
|
||||
Linux _ -> "xdg-open"
|
||||
FreeBSD -> "xdg-open"
|
||||
Windows -> "start"
|
||||
|
||||
if clOpen
|
||||
then
|
||||
exec cmd
|
||||
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
|
||||
True
|
||||
[serializeURIRef' uri]
|
||||
Nothing
|
||||
Nothing
|
||||
>>= \case
|
||||
@@ -1735,16 +1654,6 @@ fromVersion' av SetNext tool = do
|
||||
. cycle
|
||||
. sort
|
||||
$ hlses) ?? NoToolVersionSet tool
|
||||
Stack -> do
|
||||
set <- stackSet !? NoToolVersionSet tool
|
||||
stacks <- rights <$> lift getInstalledStacks
|
||||
(fmap (GHCTargetVersion Nothing)
|
||||
. headMay
|
||||
. tail
|
||||
. dropWhile (/= set)
|
||||
. cycle
|
||||
. sort
|
||||
$ stacks) ?? NoToolVersionSet tool
|
||||
GHCup -> fail "GHCup cannot be set"
|
||||
let vi = getVersionInfo (_tvVersion next) tool av
|
||||
pure (next, vi)
|
||||
@@ -1943,21 +1852,14 @@ checkForUpdates dls pfreq = do
|
||||
$ $(logWarn)
|
||||
[i|New HLS version available: #{prettyVer l}. To upgrade, run 'ghcup install hls #{prettyVer l}'|]
|
||||
|
||||
forM_ (getLatest dls Stack) $ \(l, _) -> do
|
||||
let mstack_ver = latestInstalled Stack
|
||||
forM mstack_ver $ \stack_ver ->
|
||||
when (l > stack_ver)
|
||||
$ $(logWarn)
|
||||
[i|New Stack version available: #{prettyVer l}. To upgrade, run 'ghcup install stack #{prettyVer l}'|]
|
||||
|
||||
|
||||
prettyDebugInfo :: DebugInfo -> String
|
||||
prettyDebugInfo DebugInfo {..} = [i|Debug Info
|
||||
==========
|
||||
GHCup base dir: #{diBaseDir}
|
||||
GHCup bin dir: #{diBinDir}
|
||||
GHCup GHC directory: #{diGHCDir}
|
||||
GHCup cache directory: #{diCacheDir}
|
||||
GHCup base dir: #{toFilePath diBaseDir}
|
||||
GHCup bin dir: #{toFilePath diBinDir}
|
||||
GHCup GHC directory: #{toFilePath diGHCDir}
|
||||
GHCup cache directory: #{toFilePath diCacheDir}
|
||||
Architecture: #{prettyShow diArch}
|
||||
Platform: #{prettyShow diPlatform}
|
||||
Version: #{describe_result}|]
|
||||
|
||||
@@ -10,11 +10,6 @@ package ghcup
|
||||
tests: True
|
||||
flags: +tui
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/Bodigrim/tar
|
||||
tag: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
|
||||
|
||||
constraints: http-io-streams -brotli
|
||||
|
||||
package libarchive
|
||||
|
||||
@@ -29,8 +29,6 @@ key-bindings:
|
||||
KChar: 'c'
|
||||
show-all:
|
||||
KChar: 'a'
|
||||
show-all-tools:
|
||||
KChar: 't'
|
||||
|
||||
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
|
||||
# check the 'URLSource' type in the code.
|
||||
|
||||
192
ghcup-0.0.4.yaml
192
ghcup-0.0.4.yaml
@@ -170,11 +170,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-portbld-freebsd.tar.bz2
|
||||
dlSubdir: ghc-7.10.3
|
||||
dlHash: 2aa396edd2bb651f4bc7eef7a396913ea24923de5aafdc76df6295333e487e48
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-7.10.3
|
||||
dlHash: 63e1689fc9e2809ae4d7f422b4dc810052e54c9aa2afd08746e234180e711dde
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-7103-32-deb8
|
||||
@@ -241,11 +236,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.0.2
|
||||
dlHash: b36a20e5cae24d70bbb6116ae486f21811e9384f15d3892d260f02fba3e3bb8c
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.0.2
|
||||
dlHash: 8c42c1f4af995205b9816a1e97e2752fe758544c1f5fe77958cdcd319c9c2d53
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
'( >= 7 && < 8 )':
|
||||
@@ -310,11 +300,6 @@ ghcupDownloads:
|
||||
dlSubdir: ghc-8.2.2
|
||||
dlHash: cd351c704b92b9af23994024df07de8ca7090ea7675d5c8b14b2be857a46d804
|
||||
unknown_versioning: *ghc-822-64-fbsd11
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.2.2/ghc-8.2.2-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.2.2
|
||||
dlHash: 1e033df2092aa546e763e7be63167720b32df64f76673ea1ce7ae7c9f564b223
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
'( >= 7 && < 8 )':
|
||||
@@ -374,11 +359,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-x86_64-portbld11-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.4.1
|
||||
dlHash: e748daec098445c6190090fe32bb2817a1140553be5acd2188e1af05ad24e5aa
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.4.1
|
||||
dlHash: 328b013fc651d34e075019107e58bb6c8a578f0155cf3ad4557e6f2661b03131
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-841-32-deb8
|
||||
@@ -434,11 +414,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.4.2
|
||||
dlHash: e9ed417fdf94c2ff2c6e344ed16f332bf6b591511f6442c0d9ea94854882b66c
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.4.2
|
||||
dlHash: 797634aa9812fc6b2084a24ddb4fde44fa83a2f59daea82e0af81ca3dd323fde
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-842-32-deb8
|
||||
@@ -489,11 +464,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-x86_64-apple-darwin.tar.xz
|
||||
dlSubdir: ghc-8.4.3
|
||||
dlHash: af0b455f6c46b9802b4b48dad996619cfa27cc6e2bf2ce5532387b4a8c00aa64
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.4.3
|
||||
dlHash: 8a83cfbf9ae84de0443c39c93b931693bdf2a6d4bf163ffb41855f80f4bf883e
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-843-32-deb8
|
||||
@@ -562,11 +532,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-portbld-freebsd11.tar.xz
|
||||
dlSubdir: ghc-8.4.4
|
||||
dlHash: 44fbd142d1c355d6110595c59c760e2c73866ff9259ec85ebf814edb244d1940
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.4.4
|
||||
dlHash: da29dbb0f1199611c7d5bb7b0dd6a7426ca98f67dfd6da1526b033cd3830dc05
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-844-32-deb8
|
||||
@@ -627,11 +592,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.6.1/ghc-8.6.1-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.6.1
|
||||
dlHash: 51403b054a3a649039ac988e1d1112561f96750bfced63df864091a3fab36f08
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.6.1/ghc-8.6.1-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.6.1
|
||||
dlHash: 7316d9cb5e486460476754f872c7bac30ee2082e42f46da4342f872d10b88099
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-861-32-deb8
|
||||
@@ -678,11 +638,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-x86_64-apple-darwin.tar.xz
|
||||
dlSubdir: ghc-8.6.2
|
||||
dlHash: 8ec46a25872226dd7e5cf7271e3f3450c05f32144b96e6b9cb44cc4079db50dc
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.6.2
|
||||
dlHash: 9a398e133cab09ff2610834337355d4e26c35e0665403fb9ff8db79315f74d3d
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-862-32-deb8
|
||||
@@ -747,11 +702,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.6.3
|
||||
dlHash: bc2419fa180f8a7808c49775987866435995df9bdd9ce08bcd38352d63ba6031
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.6.3
|
||||
dlHash: 2fec383904e5fa79413e9afd328faf9bc700006c8c3d4bcdd8d4f2ccf0f7fa2a
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-863-32-deb8
|
||||
@@ -802,11 +752,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-x86_64-apple-darwin.tar.xz
|
||||
dlSubdir: ghc-8.6.4
|
||||
dlHash: cccb58f142fe41b601d73690809f6089f7715b6a50a09aa3d0104176ab4db09e
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.6.4
|
||||
dlHash: e8d021b7a90772fc559862079da20538498d991956d7557b468ca19ddda22a08
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-864-32-deb9
|
||||
@@ -875,11 +820,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.6.5/ghc-8.6.5-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.6.5
|
||||
dlHash: 83a3059a630d40a98e26cb5b520354e12094a96e36ba2f5ab002dad94cf2fb37
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.6.5
|
||||
dlHash: 457024c6ea43bdce340af428d86319931f267089398b859b00efdfe2fd4ce93f
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-865-32-deb9
|
||||
@@ -950,11 +890,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.8.1/ghc-8.8.1-x86_64-apple-darwin.tar.xz
|
||||
dlSubdir: ghc-8.8.1
|
||||
dlHash: 38c8917b47c31bedf58c9305dfca3abe198d8d35570366f0773c4e2948bd8abe
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.8.1/ghc-8.8.1-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.8.1
|
||||
dlHash: 29e56e6af38017a5a76b2b6995a39d3988fa58131e4b55b62dd317ba7186ac9b
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-881-32-deb9
|
||||
@@ -1014,11 +949,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.8.2/ghc-8.8.2-x86_64-apple-darwin.tar.xz
|
||||
dlSubdir: ghc-8.8.2
|
||||
dlHash: 25c5c1a70036abf3f22b2b19c10d26adfdb08e8f8574f89d4b2042de5947f990
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.8.2/ghc-8.8.2-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.8.2
|
||||
dlHash: e25d9b16ee62cafc7387af2cd021eea676a99cd2c32b83533b016162c63065d9
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-882-32-deb9
|
||||
@@ -1083,11 +1013,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.8.3/ghc-8.8.3-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.8.3
|
||||
dlHash: 569719075b4d14b3875a899df522090ae31e6fe085e6dffe518e875b09a2f0be
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.8.3/ghc-8.8.3-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.8.3
|
||||
dlHash: e22586762af0911c06e8140f1792e3ca381a3a482a20d67b9054883038b3a422
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-883-32-deb9
|
||||
@@ -1162,11 +1087,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.8.4/ghc-8.8.4-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.8.4
|
||||
dlHash: 8cebe5ccf454e82acd1ff52ca57590d1ab0f3f44a981b46257ec12158c8c447e
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.8.4
|
||||
dlHash: d185055d2c8dc3bfe5b88afd59d6877eb1e722b672d1c9649f18296e148ed71f
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
unknown_versioning: &ghc-884-32-deb9
|
||||
@@ -1244,11 +1164,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.10.1/ghc-8.10.1-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.10.1
|
||||
dlHash: e8646ec9b60fd40aa9505ee055f22f04601290ab7a1342c2cf37c34de9d3f142
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.10.1
|
||||
dlHash: 38a3166ea50cccd5bae7e1680eae3aae2b4ae31b61f82a1d8168fb821f43bd67
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
'( >= 9 && < 10 )': &ghc-8101-32-deb9
|
||||
@@ -1339,11 +1254,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-unknown-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.10.2
|
||||
dlHash: 9e5957f3497f4b58ecd3699568d9caaa11a47a6d7e902032c261e450fa0f6686
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.10.2
|
||||
dlHash: dcae4c173b9896e07ff048de5509aa0a4537233150e06e5ce8848303dfadc176
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
'( >= 9 && < 10 )': &ghc-8102-32-deb9
|
||||
@@ -1433,11 +1343,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.10.3/ghc-8.10.3-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.10.3
|
||||
dlHash: 749007e995104db05cf6e3ad5bc36238cab8afac8055145661e5730e8f8af040
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.10.3/ghc-8.10.3-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.10.3
|
||||
dlHash: 927a6c699533a115cd49772ef2c753d9af2c13bf9f0b2d3bd13645cc6a144ee3
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
'( >= 9 && < 10 )': &ghc-8103-32-deb9
|
||||
@@ -1529,11 +1434,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.10.4/ghc-8.10.4-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-8.10.4
|
||||
dlHash: c9776a2ccf9629b03e967206a507fcdcb6c5189800a626e9461ababf6733c357
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/8.10.4/ghc-8.10.4-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-8.10.4
|
||||
dlHash: e9175a276504c3390a5e0084954e6997d56078737dbe7158049518892cf6bfb2
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
'( >= 9 && < 10 )': &ghc-8104-32-deb9
|
||||
@@ -1624,11 +1524,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/9.0.1/ghc-9.0.1-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir: ghc-9.0.1
|
||||
dlHash: 9dbc06d8832cae5c9f86dd7b2db729b3748a47beb4fd4b1e62bb66119817c3c1
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/9.0.1/ghc-9.0.1-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-9.0.1-x86_64-unknown-mingw32
|
||||
dlHash: 4f4ab118df01cbc7e7c510096deca0cb25025339a97730de0466416296202493
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
'( >= 9 && < 10 )': &ghc-901-32-deb9
|
||||
@@ -1719,11 +1614,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~ghc/9.2.1-alpha2/ghc-9.2.0.20210422-x86_64-apple-darwin.tar.xz
|
||||
dlSubdir: ghc-9.2.0.20210422
|
||||
dlHash: 8884c059f2b76e4c4309ff6bd7a7dde37663f751fd26220e9a2bcabb4d69a401
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghc/9.2.1-alpha2/ghc-9.2.0.20210422-x86_64-unknown-mingw32.tar.xz
|
||||
dlSubdir: ghc-9.0.1-x86_64-unknown-mingw32
|
||||
dlHash: 33f173b754d18f26bb27f52bb77a92fd22a48675daa2b43a1879bf01dddd7e8f
|
||||
A_32:
|
||||
Linux_Debian:
|
||||
'( >= 9 && < 10 )': &ghc-921-alpha2-32-deb9
|
||||
@@ -1776,11 +1666,6 @@ ghcupDownloads:
|
||||
dlUri: https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/cabal-install-2.4.1.0-x86_64-portbld-freebsd.tar.xz
|
||||
dlSubdir:
|
||||
dlHash: 33b7d37ea0688c93436eac9ec139d9967687875aa1fa13f2bb73bf05a9a59a1d
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/cabal-install-2.4.1.0-x86_64-unknown-mingw32.zip
|
||||
dlSubdir:
|
||||
dlHash: 95f233efedb1ebf0e6db015fa2f55c1ed00b9938d207ec63c066f706fb4b6373
|
||||
A_32:
|
||||
Linux_UnknownLinux:
|
||||
unknown_versioning:
|
||||
@@ -1809,11 +1694,6 @@ ghcupDownloads:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-portbld-freebsd.tar.xz
|
||||
dlHash: 2240842ab2ae7b955feb8b526aba1c7991248c803383107adf39990441294d2a
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-mingw32.zip
|
||||
dlSubdir:
|
||||
dlHash: 8889963ebef5e829d86329fdb59832c107efd117cf7862a605f2fe2d2360de1f
|
||||
A_32:
|
||||
Linux_Alpine:
|
||||
unknown_versioning:
|
||||
@@ -1845,11 +1725,6 @@ ghcupDownloads:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz
|
||||
dlHash: f1e35151cca91541b0fb4bdb3ed18f3c348038eab751845ad19c11307d66c273
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-x86_64-unknown-mingw32.zip
|
||||
dlSubdir:
|
||||
dlHash: 17778c3ade0482bc37f451eec326f8fce8fbe1f12b1d6aacb2e2b9e34786c054
|
||||
A_32:
|
||||
Linux_Alpine:
|
||||
unknown_versioning:
|
||||
@@ -1884,11 +1759,6 @@ ghcupDownloads:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.4.0.0/cabal-install-3.4.0.0-x86_64-freebsd-12.1-release.tar.xz
|
||||
dlHash: a1e2db664ec00e42a1e071a4181f6476f6e0bad321f1ddc0cf27831119f4c6d4
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.4.0.0/cabal-install-3.4.0.0-x86_64-windows.zip
|
||||
dlSubdir:
|
||||
dlHash: 860fff2d39a82d1dc0ca924a77164d0988af49c2c5f45e15d615144122beb647
|
||||
A_32:
|
||||
Linux_UnknownLinux:
|
||||
unknown_versioning: &cabal-3400-32
|
||||
@@ -1927,10 +1797,6 @@ ghcupDownloads:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/~ghcup/0.1.14.1/x86_64-portbld-freebsd-ghcup-0.1.14.1
|
||||
dlHash: 89a70980d77888dae8b9fd0f05e7a7920f421bc3bb5192da8e73fd4e7b4cb86f
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://TODO
|
||||
dlHash: 89a70980d77888dae8b9fd0f05e7a7920f421bc3bb5192da8e73fd4e7b4cb86f
|
||||
Linux_Alpine:
|
||||
unknown_versioning: *ghcup-64
|
||||
A_32:
|
||||
@@ -1967,63 +1833,5 @@ ghcupDownloads:
|
||||
unknown_versioning:
|
||||
dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.1.0/haskell-language-server-macOS-1.1.0.tar.gz
|
||||
dlHash: 4e89b192e2f49637d772e974f2c17b16da067ecd5912575eaa542551de97681b
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/hls/1.1.0/haskell-language-server-Windows-1.1.0.tar.gz
|
||||
dlHash: a1d3f451e64a041aa527a25da29e4716a2de6ae347cef4ef9312fc7611e168cc
|
||||
Linux_Alpine:
|
||||
unknown_versioning: *hls-64
|
||||
Stack:
|
||||
2.5.1:
|
||||
viTags: []
|
||||
viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v251
|
||||
viArch:
|
||||
A_64:
|
||||
Linux_UnknownLinux:
|
||||
unknown_versioning: &stack-251-64
|
||||
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz
|
||||
dlHash: c83b6c93d6541c0bce2175085a04062020f4160a86116e20f3b343b562f2d1e8
|
||||
dlSubdir:
|
||||
RegexDir: "stack-.*"
|
||||
Darwin:
|
||||
unknown_versioning:
|
||||
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz
|
||||
dlHash: f4aedfa8fbe371f77286ee97ec5c3c553842e7ae15b2952a8b8442dccba04bf0
|
||||
dlSubdir:
|
||||
RegexDir: "stack-.*"
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-windows-x86_64.tar.gz
|
||||
dlHash: 57150b422cfd42249f5e629d0eb678df6d95dabe486ced57e8298d300b940d41
|
||||
dlSubdir:
|
||||
RegexDir: "stack-.*"
|
||||
Linux_Alpine:
|
||||
unknown_versioning: *stack-251-64
|
||||
2.7.1:
|
||||
viTags:
|
||||
- Recommended
|
||||
- Latest
|
||||
viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v271
|
||||
viArch:
|
||||
A_64:
|
||||
Linux_UnknownLinux:
|
||||
unknown_versioning: &stack-64
|
||||
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-linux-x86_64.tar.gz
|
||||
dlHash: 2bc47749ee4be5eccb52a2d4a6a00b0f3b28b92517742b40c675836d7db2777d
|
||||
dlSubdir:
|
||||
RegexDir: "stack-.*"
|
||||
Darwin:
|
||||
unknown_versioning:
|
||||
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-osx-x86_64.tar.gz
|
||||
dlHash: 4248c6fbc87e8a2c06f39e867eb5ef28eae0d99470137cb415356c631c0dcbf2
|
||||
dlSubdir:
|
||||
RegexDir: "stack-.*"
|
||||
Windows:
|
||||
unknown_versioning:
|
||||
dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-windows-x86_64.tar.gz
|
||||
dlHash: 8452f5fc9235620a84863f2f68e5f681c72d0d181cde50482f178a966ee0ceb9
|
||||
dlSubdir:
|
||||
RegexDir: "stack-.*"
|
||||
Linux_Alpine:
|
||||
unknown_versioning: *stack-64
|
||||
|
||||
|
||||
74
ghcup.cabal
74
ghcup.cabal
@@ -1,6 +1,6 @@
|
||||
cabal-version: 3.0
|
||||
name: ghcup
|
||||
version: 0.1.14.2
|
||||
version: 0.1.14.1
|
||||
license: LGPL-3.0-only
|
||||
license-file: LICENSE
|
||||
copyright: Julian Ospald 2020
|
||||
@@ -28,23 +28,19 @@ source-repository head
|
||||
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
|
||||
|
||||
flag tui
|
||||
description:
|
||||
Build the brick powered tui (ghcup tui). This is disabled on windows.
|
||||
|
||||
description: Build the brick powered tui (ghcup tui)
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
flag internal-downloader
|
||||
description:
|
||||
Compile the internal downloader, which links against OpenSSL. This is disabled on windows.
|
||||
Compile the internal downloader, which links against OpenSSL
|
||||
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
flag tar
|
||||
description:
|
||||
Use tar-bytestring instead of libarchive. This is always enabled on windows.
|
||||
|
||||
description: Use tar-bytestring instead of libarchive
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
@@ -62,7 +58,6 @@ library
|
||||
GHCup.Utils
|
||||
GHCup.Utils.Dirs
|
||||
GHCup.Utils.File
|
||||
GHCup.Utils.File.Common
|
||||
GHCup.Utils.Logger
|
||||
GHCup.Utils.MegaParsec
|
||||
GHCup.Utils.Prelude
|
||||
@@ -90,24 +85,27 @@ library
|
||||
|
||||
build-depends:
|
||||
, aeson >=1.4 && <1.6
|
||||
, ascii-string ^>=1.0
|
||||
, async >=0.8 && <2.3
|
||||
, base >=4.13 && <5
|
||||
, base16-bytestring >=0.1.1.6 && <1.1
|
||||
, binary ^>=0.8.6.0
|
||||
, bytestring ^>=0.10
|
||||
, bz2 >=0.5.0.5 && <1.1
|
||||
, case-insensitive ^>=1.2.1.0
|
||||
, casing ^>=0.1.4.1
|
||||
, concurrent-output ^>=1.10.11
|
||||
, containers ^>=0.6
|
||||
, cryptohash-sha256 ^>=0.11.101.0
|
||||
, deepseq ^>=1.4.4.0
|
||||
, directory ^>=1.3.6.0
|
||||
, disk-free-space ^>=0.1.0.1
|
||||
, extra ^>=1.7.9
|
||||
, filepath ^>=1.4.2.1
|
||||
, generics-sop ^>=0.5
|
||||
, haskus-utils-types ^>=1.5
|
||||
, haskus-utils-variant >=3.0 && <3.2
|
||||
, hpath >=0.11 && <0.13
|
||||
, hpath-directory ^>=0.14.1
|
||||
, hpath-filepath ^>=0.10.3
|
||||
, hpath-io ^>=0.14.1
|
||||
, hpath-posix ^>=0.13.2
|
||||
, lzma-static ^>=5.2.5.2
|
||||
, megaparsec >=8.0.0 && <9.1
|
||||
, monad-logger ^>=0.3.31
|
||||
@@ -118,7 +116,6 @@ library
|
||||
, parsec ^>=3.1
|
||||
, pretty ^>=1.1.3.1
|
||||
, pretty-terminal ^>=0.1.0.0
|
||||
, process ^>=1.6.9.0
|
||||
, regex-posix ^>=0.96
|
||||
, resourcet ^>=1.2.2
|
||||
, safe ^>=0.3.18
|
||||
@@ -126,25 +123,27 @@ library
|
||||
, split ^>=0.2.3.4
|
||||
, streamly ^>=0.7.3
|
||||
, streamly-bytestring ^>=0.1.2
|
||||
, streamly-posix ^>=0.1.0.0
|
||||
, strict-base ^>=0.4
|
||||
, string-interpolate >=0.2.0.0 && <0.4
|
||||
, template-haskell >=2.7 && <2.17
|
||||
, temporary ^>=1.3
|
||||
, text ^>=1.2.4.0
|
||||
, time ^>=1.9.3
|
||||
, transformers ^>=0.5
|
||||
, unix ^>=2.7
|
||||
, unix-bytestring ^>=0.3
|
||||
, unliftio-core ^>=0.2.0.1
|
||||
, unordered-containers ^>=0.2.10.0
|
||||
, uri-bytestring ^>=0.3.2.2
|
||||
, utf8-string ^>=1.0
|
||||
, vector ^>=0.12
|
||||
, versions ^>=4.0.1
|
||||
, vty >=5.28.2 && <5.34
|
||||
, word8 ^>=0.1.3
|
||||
, yaml ^>=0.11.4.0
|
||||
, zip ^>=1.7.0
|
||||
, zlib ^>=0.6.2.2
|
||||
|
||||
if (flag(internal-downloader) && !os(windows))
|
||||
if flag(internal-downloader)
|
||||
exposed-modules: GHCup.Download.IOStreams
|
||||
cpp-options: -DINTERNAL_DOWNLOADER
|
||||
build-depends:
|
||||
@@ -153,31 +152,13 @@ library
|
||||
, io-streams >=1.5
|
||||
, terminal-progress-bar >=0.4.1
|
||||
|
||||
if (flag(tar) || os(windows))
|
||||
if flag(tar)
|
||||
cpp-options: -DTAR
|
||||
build-depends: tar
|
||||
build-depends: tar-bytestring ^>=0.6.3.1
|
||||
|
||||
else
|
||||
build-depends: libarchive ^>=3.0.0.0
|
||||
|
||||
if os(windows)
|
||||
cpp-options: -DIS_WINDOWS
|
||||
other-modules: GHCup.Utils.File.Windows
|
||||
build-depends: bzlib
|
||||
|
||||
else
|
||||
other-modules: GHCup.Utils.File.Posix
|
||||
build-depends:
|
||||
bz2 >=0.5.0.5 && <1.1
|
||||
, hpath-posix ^>=0.13.3
|
||||
, streamly-posix ^>=0.1.0.0
|
||||
, unix ^>=2.7
|
||||
, unix-bytestring ^>=0.3.7.3
|
||||
|
||||
if (flag(tui) && !os(windows))
|
||||
cpp-options: -DBRICK
|
||||
build-depends: vty >=5.28.2 && <5.34
|
||||
|
||||
executable ghcup
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: app/ghcup
|
||||
@@ -201,9 +182,10 @@ executable ghcup
|
||||
, base >=4.13 && <5
|
||||
, bytestring ^>=0.10
|
||||
, containers ^>=0.6
|
||||
, filepath ^>=1.4.2.1
|
||||
, ghcup
|
||||
, haskus-utils-variant >=3.0 && <3.2
|
||||
, hpath >=0.11 && <0.13
|
||||
, hpath-io ^>=0.14.1
|
||||
, megaparsec >=8.0.0 && <9.1
|
||||
, monad-logger ^>=0.3.31
|
||||
, mtl ^>=2.2
|
||||
@@ -223,7 +205,7 @@ executable ghcup
|
||||
if flag(internal-downloader)
|
||||
cpp-options: -DINTERNAL_DOWNLOADER
|
||||
|
||||
if (flag(tui) && !os(windows))
|
||||
if flag(tui)
|
||||
cpp-options: -DBRICK
|
||||
other-modules: BrickMain
|
||||
build-depends:
|
||||
@@ -231,7 +213,7 @@ executable ghcup
|
||||
, vector ^>=0.12
|
||||
, vty >=5.28.2 && <5.34
|
||||
|
||||
if (flag(tar) || os(windows))
|
||||
if flag(tar)
|
||||
cpp-options: -DTAR
|
||||
|
||||
else
|
||||
@@ -260,9 +242,10 @@ executable ghcup-gen
|
||||
, base >=4.13 && <5
|
||||
, bytestring ^>=0.10
|
||||
, containers ^>=0.6
|
||||
, filepath ^>=1.4.2.1
|
||||
, ghcup
|
||||
, haskus-utils-variant >=3.0 && <3.2
|
||||
, hpath >=0.11 && <0.13
|
||||
, hpath-filepath ^>=0.10.3
|
||||
, monad-logger ^>=0.3.31
|
||||
, mtl ^>=2.2
|
||||
, optics >=0.2 && <0.5
|
||||
@@ -280,9 +263,9 @@ executable ghcup-gen
|
||||
, versions ^>=4.0.1
|
||||
, yaml ^>=0.11.4.0
|
||||
|
||||
if (flag(tar) || os(windows))
|
||||
if flag(tar)
|
||||
cpp-options: -DTAR
|
||||
build-depends: tar
|
||||
build-depends: tar-bytestring ^>=0.6.3.1
|
||||
|
||||
else
|
||||
build-depends: libarchive ^>=3.0.0.0
|
||||
@@ -315,8 +298,9 @@ test-suite ghcup-test
|
||||
, containers ^>=0.6
|
||||
, generic-arbitrary ^>=0.1.0
|
||||
, ghcup
|
||||
, hspec ^>=2.7.10
|
||||
, hspec-golden-aeson >=0.9 && <0.10
|
||||
, hpath >=0.11 && <0.13
|
||||
, hspec ^>=2.7.4
|
||||
, hspec-golden-aeson >=0.7 && <0.10
|
||||
, QuickCheck ^>=2.14.1
|
||||
, quickcheck-arbitrary-adt ^>=0.3.1.0
|
||||
, text ^>=1.2.4.0
|
||||
|
||||
37684
golden/GHCupInfo.json
37684
golden/GHCupInfo.json
File diff suppressed because it is too large
Load Diff
530
lib/GHCup.hs
530
lib/GHCup.hs
@@ -18,7 +18,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
|
||||
This module contains the main functions that correspond
|
||||
to the command line interface, like installation, listing versions
|
||||
@@ -58,7 +58,6 @@ import Control.Monad.Trans.Resource
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.List.Extra
|
||||
import Data.Maybe
|
||||
import Data.String ( fromString )
|
||||
import Data.String.Interpolate
|
||||
@@ -66,7 +65,10 @@ import Data.Text ( Text )
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Format.ISO8601
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO hiding ( hideError )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
@@ -74,10 +76,10 @@ import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
import Safe hiding ( at )
|
||||
import System.Directory hiding ( findFiles )
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import System.Posix.Env.ByteString ( getEnvironment, getEnv )
|
||||
import System.Posix.FilePath ( getSearchPath, takeExtension )
|
||||
import System.Posix.Files.ByteString
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import Text.Regex.Posix
|
||||
|
||||
@@ -147,7 +149,7 @@ installGHCBindist dlinfo ver pfreq = do
|
||||
|
||||
where
|
||||
toolchainSanityChecks = do
|
||||
r <- forM ["CC", "LD"] (liftIO . lookupEnv)
|
||||
r <- forM ["CC", "LD"] (liftIO . getEnv)
|
||||
case catMaybes r of
|
||||
[] -> pure ()
|
||||
_ -> do
|
||||
@@ -166,9 +168,9 @@ installPackedGHC :: ( MonadMask m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> FilePath -- ^ Path to the packed GHC bindist
|
||||
=> Path Abs -- ^ Path to the packed GHC bindist
|
||||
-> Maybe TarDir -- ^ Subdir of the archive
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Version -- ^ The GHC version
|
||||
-> PlatformRequest
|
||||
-> Excepts
|
||||
@@ -201,27 +203,22 @@ installUnpackedGHC :: ( MonadReader AppState m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Version -- ^ The GHC version
|
||||
-> PlatformRequest
|
||||
-> Excepts '[ProcessError] m ()
|
||||
#if defined(IS_WINDOWS)
|
||||
installUnpackedGHC path inst _ _ = do
|
||||
lift $ $(logInfo) "Installing GHC (this may take a while)"
|
||||
-- windows bindists are relocatable and don't need
|
||||
-- to run configure
|
||||
liftIO $ copyDirectoryRecursive path inst
|
||||
#else
|
||||
installUnpackedGHC path inst ver PlatformRequest{..} = do
|
||||
lift $ $(logInfo) "Installing GHC (this may take a while)"
|
||||
lEM $ execLogged "sh"
|
||||
("./configure" : ("--prefix=" <> inst) : alpineArgs)
|
||||
lEM $ withConsoleRegions $ execLogged "./configure"
|
||||
False
|
||||
(("--prefix=" <> toFilePath inst) : alpineArgs)
|
||||
[rel|ghc-configure|]
|
||||
(Just path)
|
||||
"ghc-configure"
|
||||
Nothing
|
||||
lEM $ make ["install"] (Just path)
|
||||
lEM $ withConsoleRegions $ make ["install"] (Just path)
|
||||
pure ()
|
||||
where
|
||||
alpineArgs
|
||||
@@ -229,7 +226,6 @@ installUnpackedGHC path inst ver PlatformRequest{..} = do
|
||||
= ["--disable-ld-override"]
|
||||
| otherwise
|
||||
= []
|
||||
#endif
|
||||
|
||||
|
||||
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
|
||||
@@ -306,9 +302,9 @@ installCabalBindist dlinfo ver PlatformRequest {..} = do
|
||||
whenM
|
||||
(lift (cabalInstalled ver) >>= \a -> liftIO $
|
||||
handleIO (\_ -> pure False)
|
||||
$ fmap (\x -> a && x)
|
||||
$ fmap (\x -> a && isSymbolicLink x)
|
||||
-- ignore when the installation is a legacy cabal (binary, not symlink)
|
||||
$ pathIsSymbolicLink (binDir </> "cabal" <> exeExt)
|
||||
$ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
|
||||
)
|
||||
(throwE $ AlreadyInstalled Cabal ver)
|
||||
|
||||
@@ -333,18 +329,19 @@ installCabalBindist dlinfo ver PlatformRequest {..} = do
|
||||
where
|
||||
-- | Install an unpacked cabal distribution.
|
||||
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
=> Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installCabal' path inst = do
|
||||
lift $ $(logInfo) "Installing cabal"
|
||||
let cabalFile = "cabal"
|
||||
let cabalFile = [rel|cabal|]
|
||||
liftIO $ createDirRecursive' inst
|
||||
let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
|
||||
let destPath = inst </> destFileName
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile <> exeExt)
|
||||
(path </> cabalFile)
|
||||
destPath
|
||||
Overwrite
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
|
||||
@@ -441,8 +438,8 @@ installHLSBindist dlinfo ver PlatformRequest{..} = do
|
||||
where
|
||||
-- | Install an unpacked hls distribution.
|
||||
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
=> Path Abs -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installHLS' path inst = do
|
||||
lift $ $(logInfo) "Installing HLS"
|
||||
@@ -456,19 +453,20 @@ installHLSBindist dlinfo ver PlatformRequest{..} = do
|
||||
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
|
||||
)
|
||||
forM_ bins $ \f -> do
|
||||
let toF = dropSuffix exeExt f
|
||||
<> "~" <> T.unpack (prettyVer ver) <> exeExt
|
||||
toF <- parseRel (toFilePath f <> "~" <> verToBS ver)
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> f)
|
||||
(inst </> toF)
|
||||
Overwrite
|
||||
lift $ chmod_755 (inst </> toF)
|
||||
|
||||
-- install haskell-language-server-wrapper
|
||||
let wrapper = "haskell-language-server-wrapper"
|
||||
toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let wrapper = [rel|haskell-language-server-wrapper|]
|
||||
toF <- parseRel (toFilePath wrapper <> "-" <> verToBS ver)
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> wrapper <> exeExt)
|
||||
(path </> wrapper)
|
||||
(inst </> toF)
|
||||
Overwrite
|
||||
lift $ chmod_755 (inst </> toF)
|
||||
|
||||
|
||||
@@ -506,114 +504,6 @@ installHLSBin bDls ver pfreq = do
|
||||
installHLSBindist dlinfo ver pfreq
|
||||
|
||||
|
||||
-- | 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 AppState m
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version
|
||||
-> PlatformRequest
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
]
|
||||
m
|
||||
()
|
||||
installStackBin bDls ver pfreq = do
|
||||
dlinfo <- lE $ getDownloadInfo Stack ver pfreq bDls
|
||||
installStackBindist dlinfo ver pfreq
|
||||
|
||||
|
||||
-- | Like 'installStackBin', except takes the 'DownloadInfo' as
|
||||
-- argument instead of looking it up from 'GHCupDownloads'.
|
||||
installStackBindist :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader AppState m
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Version
|
||||
-> PlatformRequest
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, CopyError
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
]
|
||||
m
|
||||
()
|
||||
installStackBindist dlinfo ver PlatformRequest {..} = do
|
||||
lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
|
||||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
whenM (lift (hlsInstalled ver))
|
||||
(throwE $ AlreadyInstalled Stack ver)
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||
|
||||
liftE $ installStack' workdir binDir
|
||||
|
||||
-- create symlink if this is the latest version
|
||||
sVers <- lift $ fmap rights getInstalledStacks
|
||||
let lInstStack = headMay . reverse . sort $ sVers
|
||||
when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
|
||||
|
||||
where
|
||||
-- | Install an unpacked stack distribution.
|
||||
installStack' :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installStack' path inst = do
|
||||
lift $ $(logInfo) "Installing stack"
|
||||
let stackFile = "stack"
|
||||
liftIO $ createDirRecursive' inst
|
||||
let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let destPath = inst </> destFileName
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> stackFile <> exeExt)
|
||||
destPath
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
@@ -642,7 +532,7 @@ setGHC :: ( MonadReader AppState m
|
||||
-> SetGHC
|
||||
-> Excepts '[NotInstalled] m GHCTargetVersion
|
||||
setGHC ver sghc = do
|
||||
let verS = T.unpack $ prettyVer (_tvVersion ver)
|
||||
let verBS = verToBS (_tvVersion ver)
|
||||
ghcdir <- lift $ ghcupGHCDir ver
|
||||
|
||||
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
|
||||
@@ -664,50 +554,49 @@ setGHC ver sghc = do
|
||||
mTargetFile <- case sghc of
|
||||
SetGHCOnly -> pure $ Just file
|
||||
SetGHC_XY -> do
|
||||
handle
|
||||
v' <-
|
||||
handle
|
||||
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
|
||||
$ do
|
||||
(mj, mi) <- getMajorMinorV (_tvVersion ver)
|
||||
let major' = intToText mj <> "." <> intToText mi
|
||||
pure $ Just (file <> "-" <> T.unpack major')
|
||||
$ fmap Just
|
||||
$ getMajorMinorV (_tvVersion ver)
|
||||
forM v' $ \(mj, mi) ->
|
||||
let major' = E.encodeUtf8 $ intToText mj <> "." <> intToText mi
|
||||
in parseRel (toFilePath file <> B.singleton _hyphen <> major')
|
||||
SetGHC_XYZ ->
|
||||
pure $ Just (file <> "-" <> verS)
|
||||
fmap Just $ parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
|
||||
-- create symlink
|
||||
forM mTargetFile $ \targetFile -> do
|
||||
let fullF = binDir </> targetFile <> exeExt
|
||||
fileWithExt = file <> exeExt
|
||||
destL <- lift $ ghcLinkDestination fileWithExt ver
|
||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{fullF}|]
|
||||
liftIO $ createFileLink destL fullF
|
||||
let fullF = binDir </> targetFile
|
||||
destL <- lift $ ghcLinkDestination (toFilePath file) ver
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
|
||||
liftIO $ createSymlink fullF destL
|
||||
|
||||
-- create symlink for share dir
|
||||
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
|
||||
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS
|
||||
|
||||
pure ver
|
||||
|
||||
where
|
||||
|
||||
symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m)
|
||||
=> FilePath
|
||||
-> String
|
||||
=> Path Abs
|
||||
-> ByteString
|
||||
-> m ()
|
||||
symlinkShareDir ghcdir ver' = do
|
||||
symlinkShareDir ghcdir verBS = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
let destdir = baseDir
|
||||
case sghc of
|
||||
SetGHCOnly -> do
|
||||
let sharedir = "share"
|
||||
let sharedir = [rel|share|]
|
||||
let fullsharedir = ghcdir </> sharedir
|
||||
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
|
||||
let fullF = destdir </> sharedir
|
||||
let targetF = "." </> "ghc" </> ver' </> sharedir
|
||||
let targetF = "./ghc/" <> verBS <> "/" <> toFilePath sharedir
|
||||
$(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
|
||||
liftIO $ createDirectoryLink targetF fullF
|
||||
liftIO $ createSymlink fullF targetF
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
@@ -717,7 +606,8 @@ setCabal :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, M
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setCabal ver = do
|
||||
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let verBS = verToBS ver
|
||||
targetFile <- parseRel ("cabal-" <> verBS)
|
||||
|
||||
-- symlink destination
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
@@ -727,17 +617,17 @@ setCabal ver = do
|
||||
$ throwE
|
||||
$ NotInstalled Cabal (GHCTargetVersion Nothing ver)
|
||||
|
||||
let cabalbin = binDir </> "cabal" <> exeExt
|
||||
let cabalbin = binDir </> [rel|cabal|]
|
||||
|
||||
-- delete old file (may be binary or symlink)
|
||||
lift $ $(logDebug) [i|rm -f #{cabalbin}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile
|
||||
cabalbin
|
||||
|
||||
-- create symlink
|
||||
let destL = targetFile
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{cabalbin}|]
|
||||
liftIO $ createFileLink destL cabalbin
|
||||
let destL = toFilePath targetFile
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath cabalbin}|]
|
||||
liftIO $ createSymlink cabalbin destL
|
||||
|
||||
pure ()
|
||||
|
||||
@@ -762,63 +652,36 @@ setHLS ver = do
|
||||
-- selected version, so we could end up with stray or incorrect symlinks.
|
||||
oldSyms <- lift hlsSymlinks
|
||||
forM_ oldSyms $ \f -> do
|
||||
lift $ $(logDebug) [i|rm #{binDir </> f}|]
|
||||
liftIO $ removeFile (binDir </> f)
|
||||
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
|
||||
liftIO $ deleteFile (binDir </> f)
|
||||
|
||||
-- set haskell-language-server-<ghcver> symlinks
|
||||
bins <- lift $ hlsServerBinaries ver
|
||||
when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
|
||||
|
||||
forM_ bins $ \f -> do
|
||||
let destL = f
|
||||
let target = (<> exeExt) . head . splitOn "~" $ f
|
||||
let destL = toFilePath f
|
||||
target <- parseRel . head . B.split _tilde . toFilePath $ f
|
||||
|
||||
lift $ $(logDebug) [i|rm -f #{binDir </> target}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> target)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath (binDir </> target)}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> target)
|
||||
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{binDir </> target}|]
|
||||
liftIO $ createFileLink destL (binDir </> target)
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath (binDir </> target)}|]
|
||||
liftIO $ createSymlink (binDir </> target) destL
|
||||
|
||||
-- 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
|
||||
let destL = "haskell-language-server-wrapper-" <> verToBS ver
|
||||
let wrapper = binDir </> [rel|haskell-language-server-wrapper|]
|
||||
|
||||
lift $ $(logDebug) [i|rm -f #{wrapper}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile wrapper
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath wrapper}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile wrapper
|
||||
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{wrapper}|]
|
||||
liftIO $ createFileLink destL wrapper
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath wrapper}|]
|
||||
liftIO $ createSymlink wrapper destL
|
||||
|
||||
pure ()
|
||||
|
||||
|
||||
-- | Set the @~\/.ghcup\/bin\/stack@ symlink.
|
||||
setStack :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setStack ver = do
|
||||
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
|
||||
-- symlink destination
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
liftIO $ createDirRecursive' binDir
|
||||
|
||||
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
|
||||
$ throwE
|
||||
$ NotInstalled Stack (GHCTargetVersion Nothing ver)
|
||||
|
||||
let stackbin = binDir </> "stack" <> exeExt
|
||||
|
||||
-- delete old file (may be binary or symlink)
|
||||
lift $ $(logDebug) [i|rm -f #{stackbin}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile
|
||||
stackbin
|
||||
|
||||
-- create symlink
|
||||
lift $ $(logDebug) [i|ln -s #{targetFile} #{stackbin}|]
|
||||
liftIO $ createFileLink targetFile stackbin
|
||||
|
||||
pure ()
|
||||
|
||||
|
||||
|
||||
@@ -876,17 +739,15 @@ listVersions av lt' criteria pfreq = do
|
||||
cabals <- getInstalledCabals' cSet
|
||||
hlsSet' <- hlsSet
|
||||
hlses <- getInstalledHLSs
|
||||
sSet <- stackSet
|
||||
stacks <- getInstalledStacks
|
||||
|
||||
go lt' cSet cabals hlsSet' hlses sSet stacks
|
||||
go lt' cSet cabals hlsSet' hlses
|
||||
where
|
||||
go lt cSet cabals hlsSet' hlses sSet stacks = do
|
||||
go lt cSet cabals hlsSet' hlses = do
|
||||
case lt of
|
||||
Just t -> do
|
||||
-- get versions from GHCupDownloads
|
||||
let avTools = availableToolVersions av t
|
||||
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
|
||||
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses)
|
||||
|
||||
case t of
|
||||
GHC -> do
|
||||
@@ -898,17 +759,13 @@ listVersions av lt' criteria pfreq = do
|
||||
HLS -> do
|
||||
slr <- strayHLS avTools
|
||||
pure (sort (slr ++ lr))
|
||||
Stack -> do
|
||||
slr <- strayStacks avTools
|
||||
pure (sort (slr ++ lr))
|
||||
GHCup -> pure 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)
|
||||
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses
|
||||
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses
|
||||
hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses
|
||||
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses
|
||||
pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
|
||||
strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
=> Map.Map Version [Tag]
|
||||
-> m [ListResult]
|
||||
@@ -948,13 +805,13 @@ listVersions av lt' criteria pfreq = do
|
||||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
[i|Could not parse version of stray directory #{toFilePath e}|]
|
||||
pure Nothing
|
||||
|
||||
strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
=> Map.Map Version [Tag]
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> [Either (Path Rel) Version]
|
||||
-> m [ListResult]
|
||||
strayCabals avTools cSet cabals = do
|
||||
fmap catMaybes $ forM cabals $ \case
|
||||
@@ -977,7 +834,7 @@ listVersions av lt' criteria pfreq = do
|
||||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
[i|Could not parse version of stray directory #{toFilePath e}|]
|
||||
pure Nothing
|
||||
|
||||
strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
@@ -1005,49 +862,19 @@ listVersions av lt' criteria pfreq = do
|
||||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
pure Nothing
|
||||
|
||||
strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
=> Map.Map Version [Tag]
|
||||
-> m [ListResult]
|
||||
strayStacks avTools = do
|
||||
stacks <- getInstalledStacks
|
||||
fmap catMaybes $ forM stacks $ \case
|
||||
Right ver ->
|
||||
case Map.lookup ver avTools of
|
||||
Just _ -> pure Nothing
|
||||
Nothing -> do
|
||||
lSet <- fmap (== Just ver) hlsSet
|
||||
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)
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
[i|Could not parse version of stray directory #{toFilePath e}|]
|
||||
pure Nothing
|
||||
|
||||
-- NOTE: this are not cross ones, because no bindists
|
||||
toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
=> Tool
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> [Either (Path Rel) Version]
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> Maybe Version
|
||||
-> [Either FilePath Version]
|
||||
-> [Either (Path Rel) Version]
|
||||
-> (Version, [Tag])
|
||||
-> m ListResult
|
||||
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = case t of
|
||||
toListResult t cSet cabals hlsSet' hlses (v, tags) = case t of
|
||||
GHC -> do
|
||||
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
|
||||
let tver = mkTVer v
|
||||
@@ -1095,19 +922,6 @@ listVersions av lt' criteria pfreq = do
|
||||
, hlsPowered = False
|
||||
, ..
|
||||
}
|
||||
Stack -> do
|
||||
let lNoBindist = isLeft $ getDownloadInfo Stack v pfreq av
|
||||
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]
|
||||
@@ -1156,8 +970,8 @@ rmGHCVer ver = do
|
||||
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
|
||||
-- then fix them (e.g. with an earlier version)
|
||||
|
||||
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
|
||||
liftIO $ removeDirectoryRecursive dir
|
||||
lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|]
|
||||
liftIO $ deleteDirRecursive dir
|
||||
|
||||
v' <-
|
||||
handle
|
||||
@@ -1171,7 +985,7 @@ rmGHCVer ver = do
|
||||
|
||||
liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
$ removeFile (baseDir </> "share")
|
||||
$ deleteFile (baseDir </> [rel|share|])
|
||||
|
||||
|
||||
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
||||
@@ -1186,15 +1000,15 @@ rmCabalVer ver = do
|
||||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> cabalFile)
|
||||
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
|
||||
|
||||
when (Just ver == cSet) $ do
|
||||
cVers <- lift $ fmap rights getInstalledCabals
|
||||
case headMay . reverse . sort $ cVers of
|
||||
Just latestver -> setCabal latestver
|
||||
Nothing -> liftIO $ hideError doesNotExistErrorType $ removeFile
|
||||
(binDir </> "cabal" <> exeExt)
|
||||
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
|
||||
(binDir </> [rel|cabal|])
|
||||
|
||||
|
||||
-- | Delete a hls version. Will try to fix the hls symlinks
|
||||
@@ -1210,15 +1024,14 @@ rmHLSVer ver = do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
bins <- lift $ hlsAllBinaries ver
|
||||
forM_ bins $ \f -> liftIO $ removeFile (binDir </> f)
|
||||
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
|
||||
|
||||
when (Just ver == isHlsSet) $ do
|
||||
-- delete all set symlinks
|
||||
oldSyms <- lift hlsSymlinks
|
||||
forM_ oldSyms $ \f -> do
|
||||
let fullF = binDir </> f <> exeExt
|
||||
lift $ $(logDebug) [i|rm #{fullF}|]
|
||||
liftIO $ removeFile fullF
|
||||
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
|
||||
liftIO $ deleteFile (binDir </> f)
|
||||
-- set latest hls
|
||||
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||
case headMay . reverse . sort $ hlsVers of
|
||||
@@ -1226,28 +1039,6 @@ rmHLSVer ver = do
|
||||
Nothing -> pure ()
|
||||
|
||||
|
||||
-- | Delete a stack version. Will try to fix the @stack@ symlink
|
||||
-- after removal (e.g. setting it to an older version).
|
||||
rmStackVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmStackVer ver = do
|
||||
whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver))
|
||||
|
||||
sSet <- lift stackSet
|
||||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> stackFile)
|
||||
|
||||
when (Just ver == sSet) $ do
|
||||
sVers <- lift $ fmap rights getInstalledStacks
|
||||
case headMay . reverse . sort $ sVers of
|
||||
Just latestver -> setStack latestver
|
||||
Nothing -> liftIO $ hideError doesNotExistErrorType $ removeFile
|
||||
(binDir </> "stack" <> exeExt)
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
@@ -1291,10 +1082,10 @@ compileGHC :: ( MonadMask m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Either GHCTargetVersion GitBranch -- ^ version to install
|
||||
-> Either Version FilePath -- ^ version to bootstrap with
|
||||
-> Either Version (Path Abs) -- ^ version to bootstrap with
|
||||
-> Maybe Int -- ^ jobs
|
||||
-> Maybe FilePath -- ^ build config
|
||||
-> Maybe FilePath -- ^ patch directory
|
||||
-> Maybe (Path Abs) -- ^ build config
|
||||
-> Maybe (Path Abs) -- ^ patch directory
|
||||
-> [Text] -- ^ additional args to ./configure
|
||||
-> PlatformRequest
|
||||
-> Excepts
|
||||
@@ -1340,9 +1131,10 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
|
||||
pure (workdir, tmpUnpack, tver)
|
||||
|
||||
-- clone from git
|
||||
Right GitBranch{..} -> do
|
||||
Right GitBranch{..} -> withConsoleRegions $ \pState rs -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
|
||||
let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing pState rs
|
||||
git_fetch = execLogged [s|sh|] True ["-c", [i|git --no-pager fetch --depth 1 origin #{ref} 2>&1 | cat|]] [rel|git|] (Just tmpUnpack) Nothing pState rs
|
||||
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
|
||||
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
|
||||
lift $ $(logInfo) [i|Fetching git repo #{rep} at ref #{ref} (this may take a while)|]
|
||||
@@ -1352,24 +1144,17 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
|
||||
, "origin"
|
||||
, fromString rep ]
|
||||
|
||||
let fetch_args =
|
||||
[ "fetch"
|
||||
, "--depth"
|
||||
, "1"
|
||||
, "--quiet"
|
||||
, "origin"
|
||||
, fromString ref ]
|
||||
lEM $ git fetch_args
|
||||
lEM $ git_fetch
|
||||
|
||||
lEM $ git [ "checkout", "FETCH_HEAD" ]
|
||||
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
|
||||
lEM $ execLogged "sh" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" Nothing
|
||||
lEM $ execLogged "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" Nothing
|
||||
lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing pState rs
|
||||
lEM $ execLogged "./configure" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing pState rs
|
||||
CapturedProcess {..} <- liftIO $ makeOut
|
||||
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
|
||||
case _exitCode of
|
||||
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
|
||||
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
|
||||
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe $ _stdOut
|
||||
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe _stdErr))
|
||||
|
||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||
lift $ $(logInfo) [i|Git version #{ref} corresponds to GHC version #{prettyVer tver}|]
|
||||
@@ -1388,14 +1173,14 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
|
||||
|
||||
bghc <- case bstrap of
|
||||
Right g -> pure $ Right g
|
||||
Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver))
|
||||
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
|
||||
|
||||
(bindist, bmk) <- liftE $ runBuildAction
|
||||
tmpUnpack
|
||||
Nothing
|
||||
(do
|
||||
b <- compileBindist bghc tver workdir
|
||||
bmk <- liftIO $ B.readFile (build_mk workdir)
|
||||
bmk <- liftIO $ readFileStrict (build_mk workdir)
|
||||
pure (b, bmk)
|
||||
)
|
||||
|
||||
@@ -1408,7 +1193,7 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
|
||||
(tver ^. tvVersion)
|
||||
pfreq
|
||||
|
||||
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
|
||||
liftIO $ writeFile (ghcdir </> ghcUpSrcBuiltFile) (Just newFilePerms) bmk
|
||||
|
||||
reThrowAll GHCupSetError $ postGHCInstall tver
|
||||
|
||||
@@ -1439,15 +1224,16 @@ HADDOCK_DOCS = YES|]
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
)
|
||||
=> Either FilePath FilePath
|
||||
=> Either (Path Rel) (Path Abs)
|
||||
-> GHCTargetVersion
|
||||
-> FilePath
|
||||
-> Path Abs
|
||||
-> Excepts
|
||||
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
|
||||
m
|
||||
FilePath -- ^ output path of bindist
|
||||
compileBindist bghc tver workdir = do
|
||||
(Path Abs) -- ^ output path of bindist
|
||||
compileBindist bghc tver workdir = withConsoleRegions $ \pState rs -> do
|
||||
lift $ $(logInfo) [i|configuring build|]
|
||||
liftE checkBuildConfig
|
||||
|
||||
@@ -1461,52 +1247,58 @@ HADDOCK_DOCS = YES|]
|
||||
bghcPath <- case bghc of
|
||||
Right ghc' -> pure ghc'
|
||||
Left bver -> do
|
||||
spaths <- liftIO getSearchPath
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
liftIO (searchPath spaths bver) !? NotFoundInPATH bver
|
||||
lEM $ execLogged
|
||||
"sh"
|
||||
("./configure" : maybe mempty
|
||||
(\x -> ["--target=" <> T.unpack x])
|
||||
"./configure"
|
||||
False
|
||||
( maybe mempty
|
||||
(\x -> ["--target=" <> E.encodeUtf8 x])
|
||||
(_tvTarget tver)
|
||||
++ fmap T.unpack aargs
|
||||
++ fmap E.encodeUtf8 aargs
|
||||
)
|
||||
[rel|ghc-conf|]
|
||||
(Just workdir)
|
||||
"ghc-conf"
|
||||
(Just (("GHC", bghcPath) : cEnv))
|
||||
(Just (("GHC", toFilePath bghcPath) : cEnv))
|
||||
pState
|
||||
rs
|
||||
| otherwise -> do
|
||||
lEM $ execLogged
|
||||
"sh"
|
||||
( [ "./configure", "--with-ghc=" <> either id id bghc
|
||||
"./configure"
|
||||
False
|
||||
( [ "--with-ghc=" <> either toFilePath toFilePath bghc
|
||||
]
|
||||
++ maybe mempty
|
||||
(\x -> ["--target=" <> T.unpack x])
|
||||
(\x -> ["--target=" <> E.encodeUtf8 x])
|
||||
(_tvTarget tver)
|
||||
++ fmap T.unpack aargs
|
||||
++ fmap E.encodeUtf8 aargs
|
||||
)
|
||||
[rel|ghc-conf|]
|
||||
(Just workdir)
|
||||
"ghc-conf"
|
||||
(Just cEnv)
|
||||
pState
|
||||
rs
|
||||
|
||||
case mbuildConfig of
|
||||
Just bc -> liftIOException
|
||||
doesNotExistErrorType
|
||||
(FileDoesNotExistError bc)
|
||||
(liftIO $ copyFile bc (build_mk workdir))
|
||||
(FileDoesNotExistError $ toFilePath bc)
|
||||
(liftIO $ copyFile bc (build_mk workdir) Overwrite)
|
||||
Nothing ->
|
||||
liftIO $ B.writeFile (build_mk workdir) defaultConf
|
||||
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
|
||||
|
||||
lift $ $(logInfo) [i|Building (this may take a while)...|]
|
||||
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
|
||||
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) pState rs
|
||||
|
||||
lift $ $(logInfo) [i|Creating bindist...|]
|
||||
lEM $ make ["binary-dist"] (Just workdir)
|
||||
lEM $ make ["binary-dist"] (Just workdir) pState rs
|
||||
[tar] <- liftIO $ findFiles
|
||||
workdir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^ghc-.*\.tar\..*$|] :: ByteString)
|
||||
)
|
||||
c <- liftIO $ BL.readFile (workdir </> tar)
|
||||
c <- liftIO $ readFile (workdir </> tar)
|
||||
cDigest <-
|
||||
fmap (T.take 8)
|
||||
. lift
|
||||
@@ -1516,14 +1308,17 @@ HADDOCK_DOCS = YES|]
|
||||
. SHA256.hashlazy
|
||||
$ c
|
||||
cTime <- liftIO getCurrentTime
|
||||
let tarName = [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
|
||||
tarName <-
|
||||
parseRel
|
||||
[i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension (toFilePath tar)}|]
|
||||
let tarPath = cacheDir </> tarName
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
|
||||
tarPath
|
||||
Strict
|
||||
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
|
||||
pure tarPath
|
||||
|
||||
build_mk workdir = workdir </> "mk" </> "build.mk"
|
||||
build_mk workdir = workdir </> [rel|mk/build.mk|]
|
||||
|
||||
checkBuildConfig :: (MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
@@ -1533,10 +1328,10 @@ HADDOCK_DOCS = YES|]
|
||||
checkBuildConfig = do
|
||||
c <- case mbuildConfig of
|
||||
Just bc -> do
|
||||
liftIOException
|
||||
BL.toStrict <$> liftIOException
|
||||
doesNotExistErrorType
|
||||
(FileDoesNotExistError bc)
|
||||
(liftIO $ B.readFile bc)
|
||||
(FileDoesNotExistError $ toFilePath bc)
|
||||
(liftIO $ readFile bc)
|
||||
Nothing -> pure defaultConf
|
||||
let lines' = fmap T.strip . T.lines $ decUTF8Safe c
|
||||
|
||||
@@ -1568,7 +1363,7 @@ upgradeGHCup :: ( MonadMask m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Maybe FilePath -- ^ full file destination to write ghcup into
|
||||
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
|
||||
-> Bool -- ^ whether to force update regardless
|
||||
-- of currently installed version
|
||||
-> PlatformRequest
|
||||
@@ -1588,24 +1383,25 @@ upgradeGHCup dls mtarget force pfreq = do
|
||||
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
|
||||
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
|
||||
tmp <- lift withGHCupTmpDir
|
||||
let fn = "ghcup" <> exeExt
|
||||
let fn = [rel|ghcup|]
|
||||
p <- liftE $ download dli tmp (Just fn)
|
||||
let destDir = takeDirectory destFile
|
||||
let destDir = dirname destFile
|
||||
destFile = fromMaybe (binDir </> fn) mtarget
|
||||
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
|
||||
lift $ $(logDebug) [i|mkdir -p #{toFilePath destDir}|]
|
||||
liftIO $ createDirRecursive' destDir
|
||||
lift $ $(logDebug) [i|rm -f #{destFile}|]
|
||||
liftIO $ hideError NoSuchThing $ removeFile destFile
|
||||
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath destFile}|]
|
||||
liftIO $ hideError NoSuchThing $ deleteFile destFile
|
||||
lift $ $(logDebug) [i|cp #{toFilePath p} #{toFilePath destFile}|]
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||
destFile
|
||||
Overwrite
|
||||
lift $ chmod_755 destFile
|
||||
|
||||
liftIO (isInPath destFile) >>= \b -> unless b $
|
||||
lift $ $(logWarn) [i|"#{takeFileName destFile}" is not in PATH! You have to add it in order to use ghcup.|]
|
||||
lift $ $(logWarn) [i|"#{toFilePath (dirname destFile)}" is not in PATH! You have to add it in order to use ghcup.|]
|
||||
liftIO (isShadowed destFile) >>= \case
|
||||
Nothing -> pure ()
|
||||
Just pa -> lift $ $(logWarn) [i|ghcup is shadowed by "#{pa}". The upgrade will not be in effect, unless you remove "#{pa}" or make sure "#{destDir}" comes before "#{takeFileName pa}" in PATH.|]
|
||||
Just pa -> lift $ $(logWarn) [i|ghcup is shadowed by "#{toFilePath pa}". The upgrade will not be in effect, unless you remove "#{toFilePath pa}" or make sure "#{toFilePath destDir}" comes before "#{toFilePath (dirname pa)}" in PATH.|]
|
||||
|
||||
pure latestVer
|
||||
|
||||
|
||||
@@ -16,7 +16,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
|
||||
Module for handling all download related functions.
|
||||
|
||||
@@ -53,11 +53,11 @@ import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import Data.ByteString ( ByteString )
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import Data.CaseInsensitive ( CI )
|
||||
#endif
|
||||
import Data.List.Extra
|
||||
import Data.List ( find )
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Time.Clock
|
||||
@@ -66,29 +66,34 @@ import Data.Time.Clock.POSIX
|
||||
import Data.Time.Format
|
||||
#endif
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO as HIO hiding ( hideError )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import System.Posix.Env.ByteString ( getEnv )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Crypto.Hash.SHA256 as SHA256
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Map.Strict as M
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
#endif
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Yaml as Y
|
||||
import qualified System.Posix.Files.ByteString as PF
|
||||
import qualified System.Posix.RawFilePath.Directory
|
||||
as RD
|
||||
|
||||
|
||||
|
||||
@@ -153,12 +158,12 @@ readFromCache = do
|
||||
lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
let path = view pathL' ghcupURL
|
||||
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
|
||||
yaml_file <- (cacheDir </>) <$> urlBaseName path
|
||||
bs <-
|
||||
handleIO' NoSuchThing
|
||||
(\_ -> throwE $ FileDoesNotExistError yaml_file)
|
||||
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
|
||||
$ liftIO
|
||||
$ L.readFile yaml_file
|
||||
$ readFile yaml_file
|
||||
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
|
||||
|
||||
|
||||
@@ -202,27 +207,29 @@ getBase =
|
||||
smartDl uri' = do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
let path = view pathL' uri'
|
||||
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
|
||||
json_file <- (cacheDir </>) <$> urlBaseName path
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
then do
|
||||
accessTime <- liftIO $ getAccessTime json_file
|
||||
currentTime <- liftIO getCurrentTime
|
||||
accessTime <-
|
||||
PF.accessTimeHiRes
|
||||
<$> liftIO (PF.getFileStatus (toFilePath json_file))
|
||||
currentTime <- liftIO getPOSIXTime
|
||||
|
||||
-- access time won't work on most linuxes, but we can try regardless
|
||||
if (utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300
|
||||
if (currentTime - accessTime) > 300
|
||||
then do -- no access in last 5 minutes, re-check upstream mod time
|
||||
getModTime >>= \case
|
||||
Just modTime -> do
|
||||
fileMod <- liftIO $ getModificationTime json_file
|
||||
if modTime > fileMod
|
||||
then dlWithMod modTime json_file
|
||||
else liftIO $ L.readFile json_file
|
||||
else liftIO $ readFile json_file
|
||||
Nothing -> do
|
||||
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
|
||||
dlWithoutMod json_file
|
||||
else -- access in less than 5 minutes, re-use file
|
||||
liftIO $ L.readFile json_file
|
||||
liftIO $ readFile json_file
|
||||
else do
|
||||
liftIO $ createDirRecursive' cacheDir
|
||||
getModTime >>= \case
|
||||
@@ -240,9 +247,9 @@ getBase =
|
||||
pure bs
|
||||
dlWithoutMod json_file = do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile json_file
|
||||
liftIO $ L.writeFile json_file bs
|
||||
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile json_file
|
||||
liftIO $ writeFileL json_file (Just newFilePerms) bs
|
||||
liftIO $ setModificationTime json_file (fromIntegral @Int 0)
|
||||
pure bs
|
||||
|
||||
|
||||
@@ -271,10 +278,11 @@ getBase =
|
||||
|
||||
#endif
|
||||
|
||||
writeFileWithModTime :: UTCTime -> FilePath -> L.ByteString -> IO ()
|
||||
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
|
||||
writeFileWithModTime utctime path content = do
|
||||
L.writeFile path content
|
||||
setModificationTime path utctime
|
||||
let mod_time = utcTimeToPOSIXSeconds utctime
|
||||
writeFileL path (Just newFilePerms) content
|
||||
setModificationTimeHiRes path mod_time
|
||||
|
||||
|
||||
getDownloadInfo :: Tool
|
||||
@@ -326,9 +334,9 @@ download :: ( MonadMask m
|
||||
, MonadIO m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> FilePath -- ^ destination dir
|
||||
-> Maybe FilePath -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m FilePath
|
||||
-> Path Abs -- ^ destination dir
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
|
||||
download dli dest mfn
|
||||
| scheme == "https" = dl
|
||||
| scheme == "http" = dl
|
||||
@@ -340,9 +348,9 @@ download dli dest mfn
|
||||
cp = do
|
||||
-- destination dir must exist
|
||||
liftIO $ createDirRecursive' dest
|
||||
let destFile = getDestFile
|
||||
let fromFile = T.unpack . decUTF8Safe $ path
|
||||
liftIO $ copyFile fromFile destFile
|
||||
destFile <- getDestFile
|
||||
fromFile <- parseAbs path
|
||||
liftIO $ copyFile fromFile destFile Strict
|
||||
pure destFile
|
||||
dl = do
|
||||
let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
|
||||
@@ -350,25 +358,25 @@ download dli dest mfn
|
||||
|
||||
-- destination dir must exist
|
||||
liftIO $ createDirRecursive' dest
|
||||
let destFile = getDestFile
|
||||
destFile <- getDestFile
|
||||
|
||||
-- download
|
||||
flip onException
|
||||
(liftIO $ hideError doesNotExistErrorType $ removeFile destFile)
|
||||
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
|
||||
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
|
||||
(\e ->
|
||||
liftIO (hideError doesNotExistErrorType $ removeFile destFile)
|
||||
liftIO (hideError doesNotExistErrorType $ deleteFile destFile)
|
||||
>> (throwE . DownloadFailed $ e)
|
||||
) $ do
|
||||
lift getDownloader >>= \case
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl"
|
||||
(o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
|
||||
(o' ++ ["-fL", "-o", toFilePath destFile, serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
Wget -> do
|
||||
o' <- liftIO getWgetOpts
|
||||
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget"
|
||||
(o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True
|
||||
(o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
Internal -> do
|
||||
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
|
||||
@@ -379,8 +387,8 @@ download dli dest mfn
|
||||
pure destFile
|
||||
|
||||
-- Manage to find a file we can write the body into.
|
||||
getDestFile :: FilePath
|
||||
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path))) (dest </>) mfn
|
||||
getDestFile :: MonadThrow m => m (Path Abs)
|
||||
getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
|
||||
|
||||
path = view (dlUri % pathL') dli
|
||||
|
||||
@@ -396,14 +404,14 @@ downloadCached :: ( MonadMask m
|
||||
, MonadReader AppState m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Maybe FilePath -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m FilePath
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
|
||||
downloadCached dli mfn = do
|
||||
cache <- lift getCache
|
||||
case cache of
|
||||
True -> do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
|
||||
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
|
||||
let cachfile = cacheDir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
@@ -445,8 +453,8 @@ downloadBS uri'
|
||||
| scheme == "http"
|
||||
= dl False
|
||||
| scheme == "file"
|
||||
= liftIOException doesNotExistErrorType (FileDoesNotExistError $ T.unpack $ decUTF8Safe path)
|
||||
(liftIO $ L.readFile (T.unpack $ decUTF8Safe path))
|
||||
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
|
||||
(liftIO $ RD.readFile path)
|
||||
| otherwise
|
||||
= throwE UnsupportedScheme
|
||||
|
||||
@@ -462,20 +470,20 @@ downloadBS uri'
|
||||
lift getDownloader >>= \case
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
let exe = "curl"
|
||||
args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
|
||||
let exe = [rel|curl|]
|
||||
args = o' ++ ["-sSfL", serializeURIRef' uri']
|
||||
liftIO (executeOut exe args Nothing) >>= \case
|
||||
CapturedProcess ExitSuccess stdout _ -> do
|
||||
pure stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
|
||||
pure $ L.fromStrict stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
|
||||
Wget -> do
|
||||
o' <- liftIO getWgetOpts
|
||||
let exe = "wget"
|
||||
args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
|
||||
let exe = [rel|wget|]
|
||||
args = o' ++ ["-qO-", serializeURIRef' uri']
|
||||
liftIO (executeOut exe args Nothing) >>= \case
|
||||
CapturedProcess ExitSuccess stdout _ -> do
|
||||
pure stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
|
||||
pure $ L.fromStrict stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
Internal -> do
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
@@ -485,31 +493,31 @@ downloadBS uri'
|
||||
|
||||
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
|
||||
=> DownloadInfo
|
||||
-> FilePath
|
||||
-> Path Abs
|
||||
-> Excepts '[DigestError] m ()
|
||||
checkDigest dli file = do
|
||||
verify <- lift ask <&> (not . noVerify . settings)
|
||||
when verify $ do
|
||||
let p' = takeFileName file
|
||||
p' <- toFilePath <$> basename file
|
||||
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
|
||||
c <- liftIO $ L.readFile file
|
||||
c <- liftIO $ readFile file
|
||||
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
|
||||
let eDigest = view dlHash dli
|
||||
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
|
||||
|
||||
|
||||
-- | Get additional curl args from env. This is an undocumented option.
|
||||
getCurlOpts :: IO [String]
|
||||
getCurlOpts :: IO [ByteString]
|
||||
getCurlOpts =
|
||||
lookupEnv "GHCUP_CURL_OPTS" >>= \case
|
||||
Just r -> pure $ splitOn " " r
|
||||
getEnv "GHCUP_CURL_OPTS" >>= \case
|
||||
Just r -> pure $ BS.split _space r
|
||||
Nothing -> pure []
|
||||
|
||||
|
||||
-- | Get additional wget args from env. This is an undocumented option.
|
||||
getWgetOpts :: IO [String]
|
||||
getWgetOpts :: IO [ByteString]
|
||||
getWgetOpts =
|
||||
lookupEnv "GHCUP_WGET_OPTS" >>= \case
|
||||
Just r -> pure $ splitOn " " r
|
||||
getEnv "GHCUP_WGET_OPTS" >>= \case
|
||||
Just r -> pure $ BS.split _space r
|
||||
Nothing -> pure []
|
||||
|
||||
|
||||
@@ -24,6 +24,8 @@ import Data.CaseInsensitive ( CI )
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.Text.Read
|
||||
import HPath
|
||||
import HPath.IO as HIO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Network.Http.Client hiding ( URL )
|
||||
import Optics
|
||||
@@ -31,8 +33,11 @@ import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( fdWrite )
|
||||
import "unix-bytestring" System.Posix.IO.ByteString
|
||||
( fdWrite )
|
||||
import System.ProgressBar
|
||||
import System.IO
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
@@ -76,12 +81,12 @@ downloadToFile :: (MonadMask m, MonadIO m)
|
||||
-> ByteString -- ^ host (e.g. "www.example.com")
|
||||
-> ByteString -- ^ path (e.g. "/my/file") including query
|
||||
-> Maybe Int -- ^ optional port (e.g. 3000)
|
||||
-> FilePath -- ^ destination file to create and write to
|
||||
-> Path Abs -- ^ destination file to create and write to
|
||||
-> Excepts '[DownloadFailed] m ()
|
||||
downloadToFile https host fullPath port destFile = do
|
||||
fd <- liftIO $ openFile destFile WriteMode
|
||||
let stepper = BS.hPut fd
|
||||
flip finally (liftIO $ hClose fd)
|
||||
fd <- liftIO $ createRegularFileFd newFilePerms destFile
|
||||
let stepper = fdWrite fd
|
||||
flip finally (liftIO $ closeFd fd)
|
||||
$ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
|
||||
|
||||
|
||||
|
||||
@@ -15,11 +15,12 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Errors where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
#if !defined(TAR)
|
||||
import Codec.Archive
|
||||
@@ -27,9 +28,11 @@ import Codec.Archive
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
#endif
|
||||
import Control.Exception.Safe
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import Haskus.Utils.Variant
|
||||
import Text.PrettyPrint
|
||||
import Text.PrettyPrint.HughesPJClass
|
||||
@@ -83,12 +86,12 @@ instance Pretty DistroNotFound where
|
||||
text "Unable to figure out the distribution of the host."
|
||||
|
||||
-- | The archive format is unknown. We don't know how to extract it.
|
||||
data UnknownArchive = UnknownArchive FilePath
|
||||
data UnknownArchive = UnknownArchive ByteString
|
||||
deriving Show
|
||||
|
||||
instance Pretty UnknownArchive where
|
||||
pPrint (UnknownArchive file) =
|
||||
text [i|The archive format is unknown. We don't know how to extract the file "#{file}"|]
|
||||
text [i|The archive format is unknown. We don't know how to extract the file "#{decUTF8Safe file}"|]
|
||||
|
||||
-- | The scheme is not supported (such as ftp).
|
||||
data UnsupportedScheme = UnsupportedScheme
|
||||
@@ -140,12 +143,12 @@ instance Pretty NotInstalled where
|
||||
text [i|The version "#{prettyShow ver}" of the tool "#{tool}" is not installed.|]
|
||||
|
||||
-- | An executable was expected to be in PATH, but was not found.
|
||||
data NotFoundInPATH = NotFoundInPATH FilePath
|
||||
data NotFoundInPATH = NotFoundInPATH (Path Rel)
|
||||
deriving Show
|
||||
|
||||
instance Pretty NotFoundInPATH where
|
||||
pPrint (NotFoundInPATH exe) =
|
||||
text [i|The exe "#{exe}" was not found in PATH.|]
|
||||
text [i|The exe "#{decUTF8Safe . toFilePath $ exe}" was not found in PATH.|]
|
||||
|
||||
-- | JSON decoding failed.
|
||||
data JSONError = JSONDecodeError String
|
||||
@@ -157,12 +160,12 @@ instance Pretty JSONError where
|
||||
|
||||
-- | A file that is supposed to exist does not exist
|
||||
-- (e.g. when we use file scheme to "download" something).
|
||||
data FileDoesNotExistError = FileDoesNotExistError FilePath
|
||||
data FileDoesNotExistError = FileDoesNotExistError ByteString
|
||||
deriving Show
|
||||
|
||||
instance Pretty FileDoesNotExistError where
|
||||
pPrint (FileDoesNotExistError file) =
|
||||
text [i|File "#{file}" does not exist.|]
|
||||
text [i|File "#{decUTF8Safe file}" does not exist.|]
|
||||
|
||||
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
|
||||
deriving Show
|
||||
@@ -249,11 +252,11 @@ deriving instance Show DownloadFailed
|
||||
|
||||
|
||||
-- | A build failed.
|
||||
data BuildFailed = forall es . Show (V es) => BuildFailed FilePath (V es)
|
||||
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
|
||||
|
||||
instance Pretty BuildFailed where
|
||||
pPrint (BuildFailed path reason) =
|
||||
text [i|BuildFailed failed in dir "#{path}": #{reason}|]
|
||||
text [i|BuildFailed failed in dir "#{decUTF8Safe . toFilePath $ path}": #{reason}|]
|
||||
|
||||
deriving instance Show BuildFailed
|
||||
|
||||
|
||||
@@ -13,7 +13,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Platform where
|
||||
|
||||
@@ -36,20 +36,18 @@ import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.Info
|
||||
import System.Directory
|
||||
import System.OsRelease
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
|
||||
|
||||
|
||||
--------------------------
|
||||
--[ Platform detection ]--
|
||||
@@ -98,23 +96,22 @@ getPlatform = do
|
||||
. versioning
|
||||
-- TODO: maybe do this somewhere else
|
||||
. getMajorVersion
|
||||
. decUTF8Safe'
|
||||
. decUTF8Safe
|
||||
<$> getDarwinVersion
|
||||
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
|
||||
"freebsd" -> do
|
||||
ver <-
|
||||
either (const Nothing) Just . versioning . decUTF8Safe'
|
||||
either (const Nothing) Just . versioning . decUTF8Safe
|
||||
<$> getFreeBSDVersion
|
||||
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
|
||||
what -> throwE $ NoCompatiblePlatform what
|
||||
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
|
||||
pure pfr
|
||||
where
|
||||
getMajorVersion = T.intercalate "." . take 2 . T.split (== '.')
|
||||
getFreeBSDVersion =
|
||||
liftIO $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
|
||||
getDarwinVersion = liftIO $ fmap _stdOut $ executeOut "sw_vers"
|
||||
liftIO $ fmap _stdOut $ executeOut [rel|freebsd-version|] [] Nothing
|
||||
getDarwinVersion = liftIO $ fmap _stdOut $ executeOut [rel|sw_vers|]
|
||||
["-productVersion"]
|
||||
Nothing
|
||||
|
||||
@@ -150,12 +147,12 @@ getLinuxDistro = do
|
||||
where
|
||||
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
|
||||
|
||||
lsb_release_cmd :: FilePath
|
||||
lsb_release_cmd = "lsb-release"
|
||||
redhat_release :: FilePath
|
||||
redhat_release = "/etc/redhat-release"
|
||||
debian_version :: FilePath
|
||||
debian_version = "/etc/debian_version"
|
||||
lsb_release_cmd :: Path Rel
|
||||
lsb_release_cmd = [rel|lsb-release|]
|
||||
redhat_release :: Path Abs
|
||||
redhat_release = [abs|/etc/redhat-release|]
|
||||
debian_version :: Path Abs
|
||||
debian_version = [abs|/etc/debian_version|]
|
||||
|
||||
try_os_release :: IO (Text, Maybe Text)
|
||||
try_os_release = do
|
||||
@@ -168,11 +165,11 @@ getLinuxDistro = do
|
||||
(Just _) <- findExecutable lsb_release_cmd
|
||||
name <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
|
||||
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
|
||||
pure (decUTF8Safe' name, Just $ decUTF8Safe' ver)
|
||||
pure (decUTF8Safe name, Just $ decUTF8Safe ver)
|
||||
|
||||
try_redhat_release :: IO (Text, Maybe Text)
|
||||
try_redhat_release = do
|
||||
t <- T.readFile redhat_release
|
||||
t <- fmap decUTF8Safe' $ readFile redhat_release
|
||||
let nameRegex n =
|
||||
makeRegexOpts compIgnoreCase
|
||||
execBlank
|
||||
@@ -194,5 +191,5 @@ getLinuxDistro = do
|
||||
|
||||
try_debian_version :: IO (Text, Maybe Text)
|
||||
try_debian_version = do
|
||||
ver <- T.readFile debian_version
|
||||
pure (T.pack "debian", Just ver)
|
||||
ver <- readFile debian_version
|
||||
pure (T.pack "debian", Just . decUTF8Safe' $ ver)
|
||||
|
||||
@@ -7,7 +7,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Requirements where
|
||||
|
||||
|
||||
@@ -2,6 +2,10 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types
|
||||
@@ -10,39 +14,28 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Types
|
||||
( module GHCup.Types
|
||||
#if defined(BRICK)
|
||||
, Key(..)
|
||||
#endif
|
||||
)
|
||||
where
|
||||
module GHCup.Types where
|
||||
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.List.NonEmpty ( NonEmpty (..) )
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
|
||||
import URI.ByteString
|
||||
#if defined(BRICK)
|
||||
import Graphics.Vty ( Key(..) )
|
||||
#endif
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.Encoding.Error as E
|
||||
import qualified GHC.Generics as GHC
|
||||
import qualified Graphics.Vty as Vty
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Control.Monad.Reader
|
||||
|
||||
|
||||
#if !defined(BRICK)
|
||||
data Key = KEsc | KChar Char | KBS | KEnter
|
||||
| KLeft | KRight | KUp | KDown
|
||||
| KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
|
||||
| KFun Int | KBackTab | KPrtScr | KPause | KIns
|
||||
| KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
|
||||
deriving (Eq,Show,Read,Ord,GHC.Generic)
|
||||
#endif
|
||||
|
||||
|
||||
--------------------
|
||||
--[ GHCInfo Tree ]--
|
||||
@@ -97,7 +90,6 @@ data Tool = GHC
|
||||
| Cabal
|
||||
| GHCup
|
||||
| HLS
|
||||
| Stack
|
||||
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
|
||||
|
||||
|
||||
@@ -169,15 +161,12 @@ data Platform = Linux LinuxDistro
|
||||
| Darwin
|
||||
-- ^ must exit
|
||||
| FreeBSD
|
||||
| Windows
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
platformToString :: Platform -> String
|
||||
platformToString (Linux distro) = "linux-" ++ distroToString distro
|
||||
platformToString Darwin = "darwin"
|
||||
platformToString FreeBSD = "freebsd"
|
||||
platformToString Windows = "windows"
|
||||
|
||||
instance Pretty Platform where
|
||||
pPrint = text . platformToString
|
||||
@@ -233,12 +222,12 @@ data DownloadInfo = DownloadInfo
|
||||
|
||||
|
||||
-- | How to descend into a tar archive.
|
||||
data TarDir = RealDir FilePath
|
||||
data TarDir = RealDir (Path Rel)
|
||||
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
|
||||
deriving (Eq, Ord, GHC.Generic, Show)
|
||||
|
||||
instance Pretty TarDir where
|
||||
pPrint (RealDir path) = text path
|
||||
pPrint (RealDir path) = text [i|#{E.decodeUtf8With E.lenientDecode . toFilePath $ path}|]
|
||||
pPrint (RegexDir regex) = text regex
|
||||
|
||||
|
||||
@@ -265,42 +254,39 @@ defaultUserSettings :: UserSettings
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
data UserKeyBindings = UserKeyBindings
|
||||
{ kUp :: Maybe Key
|
||||
, kDown :: Maybe Key
|
||||
, kQuit :: Maybe Key
|
||||
, kInstall :: Maybe Key
|
||||
, kUninstall :: Maybe Key
|
||||
, kSet :: Maybe Key
|
||||
, kChangelog :: Maybe Key
|
||||
, kShowAll :: Maybe Key
|
||||
, kShowAllTools :: Maybe Key
|
||||
{ kUp :: Maybe Vty.Key
|
||||
, kDown :: Maybe Vty.Key
|
||||
, kQuit :: Maybe Vty.Key
|
||||
, kInstall :: Maybe Vty.Key
|
||||
, kUninstall :: Maybe Vty.Key
|
||||
, kSet :: Maybe Vty.Key
|
||||
, kChangelog :: Maybe Vty.Key
|
||||
, kShowAll :: Maybe Vty.Key
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
data KeyBindings = KeyBindings
|
||||
{ bUp :: Key
|
||||
, bDown :: Key
|
||||
, bQuit :: Key
|
||||
, bInstall :: Key
|
||||
, bUninstall :: Key
|
||||
, bSet :: Key
|
||||
, bChangelog :: Key
|
||||
, bShowAllVersions :: Key
|
||||
, bShowAllTools :: Key
|
||||
{ bUp :: Vty.Key
|
||||
, bDown :: Vty.Key
|
||||
, bQuit :: Vty.Key
|
||||
, bInstall :: Vty.Key
|
||||
, bUninstall :: Vty.Key
|
||||
, bSet :: Vty.Key
|
||||
, bChangelog :: Vty.Key
|
||||
, bShowAll :: Vty.Key
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
defaultKeyBindings :: KeyBindings
|
||||
defaultKeyBindings = KeyBindings
|
||||
{ bUp = KUp
|
||||
, bDown = KDown
|
||||
, bQuit = KChar 'q'
|
||||
, bInstall = KChar 'i'
|
||||
, bUninstall = KChar 'u'
|
||||
, bSet = KChar 's'
|
||||
, bChangelog = KChar 'c'
|
||||
, bShowAllVersions = KChar 'a'
|
||||
, bShowAllTools = KChar 't'
|
||||
{ bUp = Vty.KUp
|
||||
, bDown = Vty.KDown
|
||||
, bQuit = Vty.KChar 'q'
|
||||
, bInstall = Vty.KChar 'i'
|
||||
, bUninstall = Vty.KChar 'u'
|
||||
, bSet = Vty.KChar 's'
|
||||
, bChangelog = Vty.KChar 'c'
|
||||
, bShowAll = Vty.KChar 'a'
|
||||
}
|
||||
|
||||
data AppState = AppState
|
||||
@@ -320,11 +306,11 @@ data Settings = Settings
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
data Dirs = Dirs
|
||||
{ baseDir :: FilePath
|
||||
, binDir :: FilePath
|
||||
, cacheDir :: FilePath
|
||||
, logsDir :: FilePath
|
||||
, confDir :: FilePath
|
||||
{ baseDir :: Path Abs
|
||||
, binDir :: Path Abs
|
||||
, cacheDir :: Path Abs
|
||||
, logsDir :: Path Abs
|
||||
, confDir :: Path Abs
|
||||
}
|
||||
deriving Show
|
||||
|
||||
@@ -341,10 +327,10 @@ data Downloader = Curl
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
data DebugInfo = DebugInfo
|
||||
{ diBaseDir :: FilePath
|
||||
, diBinDir :: FilePath
|
||||
, diGHCDir :: FilePath
|
||||
, diCacheDir :: FilePath
|
||||
{ diBaseDir :: Path Abs
|
||||
, diBinDir :: Path Abs
|
||||
, diGHCDir :: Path Abs
|
||||
, diCacheDir :: Path Abs
|
||||
, diArch :: Architecture
|
||||
, diPlatform :: PlatformResult
|
||||
}
|
||||
@@ -437,3 +423,13 @@ instance Pretty Versioning where
|
||||
|
||||
instance Pretty Version where
|
||||
pPrint = text . T.unpack . prettyVer
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Instances ]--
|
||||
-----------------
|
||||
|
||||
instance MonadReader r' m => MonadReader r' (Excepts es m) where
|
||||
ask = lift ask
|
||||
local = mapExcepts . local
|
||||
reader = lift . reader
|
||||
|
||||
@@ -17,7 +17,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Types.JSON where
|
||||
|
||||
@@ -33,11 +33,15 @@ import Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import Data.Text.Encoding as E
|
||||
import Data.Versions
|
||||
import Data.Void
|
||||
import Data.Word8
|
||||
import HPath
|
||||
import URI.ByteString
|
||||
import Text.Casing
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Text.Megaparsec.Char as MPC
|
||||
|
||||
@@ -60,7 +64,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downlo
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
|
||||
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
|
||||
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Vty.Key
|
||||
|
||||
instance ToJSON Tag where
|
||||
toJSON Latest = String "Latest"
|
||||
@@ -124,13 +128,11 @@ instance ToJSONKey Platform where
|
||||
Darwin -> T.pack "Darwin"
|
||||
FreeBSD -> T.pack "FreeBSD"
|
||||
Linux d -> T.pack ("Linux_" <> show d)
|
||||
Windows -> T.pack "Windows"
|
||||
|
||||
instance FromJSONKey Platform where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> if
|
||||
| T.pack "Darwin" == t -> pure Darwin
|
||||
| T.pack "FreeBSD" == t -> pure FreeBSD
|
||||
| T.pack "Windows" == t -> pure Windows
|
||||
| T.pack "Linux_" `T.isPrefixOf` t -> case
|
||||
T.stripPrefix (T.pack "Linux_") t
|
||||
of
|
||||
@@ -197,6 +199,20 @@ instance ToJSONKey Tool where
|
||||
instance FromJSONKey Tool where
|
||||
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance ToJSON (Path Rel) where
|
||||
toJSON p = case and . fmap isAscii . BS.unpack $ fp of
|
||||
True -> toJSON . decUTF8Safe $ fp
|
||||
False -> String "/not/a/valid/path"
|
||||
where fp = toFilePath p
|
||||
|
||||
instance FromJSON (Path Rel) where
|
||||
parseJSON = withText "HPath Rel" $ \t -> do
|
||||
let d = encodeUtf8 t
|
||||
case parseRel d of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
|
||||
|
||||
|
||||
instance ToJSON TarDir where
|
||||
toJSON (RealDir p) = toJSON p
|
||||
toJSON (RegexDir r) = object ["RegexDir" .= r]
|
||||
|
||||
@@ -7,7 +7,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Types.Optics where
|
||||
|
||||
|
||||
@@ -14,7 +14,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
|
||||
This module contains GHCup helpers specific to
|
||||
installation and introspection of files/versions etc.
|
||||
@@ -39,7 +39,6 @@ import GHCup.Utils.String.QQ
|
||||
#if !defined(TAR)
|
||||
import Codec.Archive hiding ( Directory )
|
||||
#endif
|
||||
import Codec.Archive.Zip
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
@@ -52,21 +51,28 @@ import Data.ByteString ( ByteString )
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import Data.List.Extra
|
||||
import Data.List.NonEmpty ( NonEmpty( (:|) ))
|
||||
import Data.List.Split
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO hiding ( hideError )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import Safe
|
||||
import System.Directory hiding ( findFiles )
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import System.IO.Unsafe ( unsafeInterleaveIO )
|
||||
import System.Posix.FilePath ( getSearchPath
|
||||
, takeFileName
|
||||
)
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import Text.Regex.Posix
|
||||
import URI.ByteString
|
||||
|
||||
@@ -79,9 +85,15 @@ import qualified Codec.Compression.Lzma as Lzma
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map.Strict as Map
|
||||
#if !defined(TAR)
|
||||
import qualified Data.Text as T
|
||||
#endif
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Text.Megaparsec as MP
|
||||
import System.Console.Regions
|
||||
import Data.Sequence (Seq)
|
||||
import qualified Data.Sequence as Sq
|
||||
import Control.Concurrent
|
||||
|
||||
|
||||
|
||||
@@ -94,13 +106,14 @@ import qualified Text.Megaparsec as MP
|
||||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
=> FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
=> ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> GHCTargetVersion
|
||||
-> m FilePath
|
||||
-> m ByteString
|
||||
ghcLinkDestination tool ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
t <- parseRel tool
|
||||
ghcd <- ghcupGHCDir ver
|
||||
pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
|
||||
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
|
||||
|
||||
|
||||
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
|
||||
@@ -118,10 +131,10 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
|
||||
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
|
||||
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion)
|
||||
let fullF = binDir </> f_xyz
|
||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
|
||||
-- | Removes the set ghc version for the given target, if any.
|
||||
@@ -139,13 +152,13 @@ rmPlain target = do
|
||||
forM_ mtv $ \tv -> do
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
let fullF = binDir </> f <> exeExt
|
||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
|
||||
let fullF = binDir </> f
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
-- old ghcup
|
||||
let hdc_file = binDir </> "haddock-ghc" <> exeExt
|
||||
lift $ $(logDebug) [i|rm -f #{hdc_file}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile hdc_file
|
||||
let hdc_file = binDir </> [rel|haddock-ghc|]
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
|
||||
|
||||
|
||||
-- | Remove the major GHC symlink, e.g. ghc-8.6.
|
||||
@@ -165,10 +178,10 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
|
||||
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
let f_xy = f <> "-" <> T.unpack v' <> exeExt
|
||||
let fullF = binDir </> f_xy
|
||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
|
||||
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> E.encodeUtf8 v')
|
||||
let fullF = binDir </> f_xyz
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
|
||||
|
||||
@@ -199,40 +212,42 @@ ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
-> m (Maybe GHCTargetVersion)
|
||||
ghcSet mtarget = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
|
||||
let ghcBin = binDir </> ghc <> exeExt
|
||||
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
|
||||
let ghcBin = binDir </> ghc
|
||||
|
||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
||||
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
link <- liftIO $ getSymbolicLinkTarget ghcBin
|
||||
link <- readSymbolicLink $ toFilePath ghcBin
|
||||
Just <$> ghcLinkVersion link
|
||||
|
||||
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
|
||||
ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
|
||||
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
|
||||
ghcLinkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "ghcLinkVersion" t
|
||||
where
|
||||
parser =
|
||||
(do
|
||||
_ <- parseUntil1 ghcSubPath
|
||||
_ <- ghcSubPath
|
||||
r <- parseUntil1 pathSep
|
||||
_ <- parseUntil1 (MP.chunk "/ghc/")
|
||||
_ <- MP.chunk "/ghc/"
|
||||
r <- parseUntil1 (MP.chunk "/")
|
||||
rest <- MP.getInput
|
||||
MP.setInput r
|
||||
x <- ghcTargetVerP
|
||||
MP.setInput rest
|
||||
pure x
|
||||
)
|
||||
<* pathSep
|
||||
<* MP.chunk "/"
|
||||
<* MP.takeRest
|
||||
<* MP.eof
|
||||
ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
|
||||
|
||||
|
||||
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
|
||||
-- If a dir cannot be parsed, returns left.
|
||||
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
|
||||
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
|
||||
getInstalledGHCs = do
|
||||
ghcdir <- ghcupGHCBaseDir
|
||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
|
||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
|
||||
forM fs $ \f -> case parseGHCupGHCDir f of
|
||||
Right r -> pure $ Right r
|
||||
Left _ -> pure $ Left f
|
||||
@@ -240,7 +255,7 @@ getInstalledGHCs = do
|
||||
|
||||
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
|
||||
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
=> m [Either FilePath Version]
|
||||
=> m [Either (Path Rel) Version]
|
||||
getInstalledCabals = do
|
||||
cs <- cabalSet -- for legacy cabal
|
||||
getInstalledCabals' cs
|
||||
@@ -248,13 +263,13 @@ getInstalledCabals = do
|
||||
|
||||
getInstalledCabals' :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
=> Maybe Version
|
||||
-> m [Either FilePath Version]
|
||||
-> m [Either (Path Rel) Version]
|
||||
getInstalledCabals' cs = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
|
||||
vs <- forM bins $ \f -> case fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "cabal-" $ f of
|
||||
vs <- forM bins $ \f -> case fmap (version . decUTF8Safe) . B.stripPrefix "cabal-" . toFilePath $ f of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
@@ -272,20 +287,22 @@ cabalInstalled ver = do
|
||||
cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
cabalSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
let cabalbin = binDir </> "cabal" <> exeExt
|
||||
b <- handleIO (\_ -> pure False) $ liftIO $ pathIsSymbolicLink cabalbin
|
||||
let cabalbin = binDir </> [rel|cabal|]
|
||||
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
|
||||
if
|
||||
| b -> do
|
||||
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
broken <- liftIO $ isBrokenSymlink cabalbin
|
||||
if broken
|
||||
then pure Nothing
|
||||
then do
|
||||
$(logWarn) [i|Symlink #{cabalbin} is broken.|]
|
||||
pure Nothing
|
||||
else do
|
||||
link <- liftIO $ getSymbolicLinkTarget cabalbin
|
||||
link <- liftIO $ readSymbolicLink $ toFilePath cabalbin
|
||||
case linkVersion link of
|
||||
Right v -> pure $ Just v
|
||||
Left err -> do
|
||||
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
|
||||
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{toFilePath cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
|
||||
pure Nothing
|
||||
| otherwise -> do -- legacy behavior
|
||||
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
|
||||
@@ -293,8 +310,8 @@ cabalSet = do
|
||||
["--numeric-version"]
|
||||
Nothing
|
||||
fmap join $ forM mc $ \c -> if
|
||||
| not (BL.null (_stdOut c)), _exitCode c == ExitSuccess -> do
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . BL.toStrict . _stdOut $ c
|
||||
| not (B.null (_stdOut c)), _exitCode c == ExitSuccess -> do
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
|
||||
case version $ decUTF8Safe reportedVer of
|
||||
Left e -> throwM e
|
||||
Right r -> pure $ Just r
|
||||
@@ -303,8 +320,10 @@ cabalSet = do
|
||||
-- We try to be extra permissive with link destination parsing,
|
||||
-- because of:
|
||||
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
|
||||
linkVersion :: MonadThrow m => FilePath -> m Version
|
||||
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
|
||||
linkVersion :: MonadThrow m => ByteString -> m Version
|
||||
linkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "" t
|
||||
|
||||
parser
|
||||
= MP.try (stripAbsolutePath *> cabalParse)
|
||||
@@ -314,10 +333,10 @@ cabalSet = do
|
||||
cabalParse = MP.chunk "cabal-" *> version'
|
||||
-- parses any path component ending with path separator,
|
||||
-- e.g. "foo/"
|
||||
stripPathComponet = parseUntil1 pathSep *> pathSep
|
||||
stripPathComponet = parseUntil1 "/" *> MP.chunk "/"
|
||||
-- parses an absolute path up until the last path separator,
|
||||
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
|
||||
stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
|
||||
stripAbsolutePath = MP.chunk "/" *> MP.many (MP.try stripPathComponet)
|
||||
-- parses a relative path up until the last path separator,
|
||||
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
|
||||
stripRelativePath = MP.many (MP.try stripPathComponet)
|
||||
@@ -327,7 +346,7 @@ cabalSet = do
|
||||
-- | Get all installed hls, by matching on
|
||||
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
|
||||
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
=> m [Either FilePath Version]
|
||||
=> m [Either (Path Rel) Version]
|
||||
getInstalledHLSs = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
@@ -338,58 +357,12 @@ getInstalledHLSs = do
|
||||
)
|
||||
forM bins $ \f ->
|
||||
case
|
||||
fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "haskell-language-server-wrapper-" $ f
|
||||
fmap (version . decUTF8Safe) . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f
|
||||
of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
|
||||
-- | Get all installed stacks, by matching on
|
||||
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
|
||||
getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledStacks = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^stack-.*$|] :: ByteString)
|
||||
)
|
||||
forM bins $ \f ->
|
||||
case
|
||||
fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "stack-" $ f
|
||||
of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
|
||||
-- Return the currently set stack version, if any.
|
||||
-- TODO: there's a lot of code duplication here :>
|
||||
stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
stackSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
let stackBin = binDir </> "stack" <> exeExt
|
||||
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
broken <- isBrokenSymlink stackBin
|
||||
if broken
|
||||
then pure Nothing
|
||||
else do
|
||||
link <- liftIO $ getSymbolicLinkTarget stackBin
|
||||
Just <$> linkVersion link
|
||||
where
|
||||
linkVersion :: MonadThrow m => FilePath -> m Version
|
||||
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
|
||||
where
|
||||
parser =
|
||||
MP.chunk "stack-" *> version'
|
||||
|
||||
-- | Whether the given Stack version is installed.
|
||||
stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
stackInstalled ver = do
|
||||
vers <- fmap rights getInstalledStacks
|
||||
pure $ elem ver vers
|
||||
|
||||
-- | Whether the given HLS version is installed.
|
||||
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
@@ -403,18 +376,20 @@ hlsInstalled ver = do
|
||||
hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
hlsSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
|
||||
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
|
||||
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
broken <- isBrokenSymlink hlsBin
|
||||
if broken
|
||||
then pure Nothing
|
||||
else do
|
||||
link <- liftIO $ getSymbolicLinkTarget hlsBin
|
||||
link <- readSymbolicLink $ toFilePath hlsBin
|
||||
Just <$> linkVersion link
|
||||
where
|
||||
linkVersion :: MonadThrow m => FilePath -> m Version
|
||||
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
|
||||
linkVersion :: MonadThrow m => ByteString -> m Version
|
||||
linkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "" t
|
||||
where
|
||||
parser =
|
||||
MP.chunk "haskell-language-server-wrapper-" *> version'
|
||||
@@ -433,12 +408,13 @@ hlsGHCVersions = do
|
||||
bins <- hlsServerBinaries h'
|
||||
pure $ fmap
|
||||
(version
|
||||
. T.pack
|
||||
. decUTF8Safe
|
||||
. fromJust
|
||||
. stripPrefix "haskell-language-server-"
|
||||
. B.stripPrefix "haskell-language-server-"
|
||||
. head
|
||||
. splitOn "~"
|
||||
)
|
||||
. B.split _tilde
|
||||
. toFilePath
|
||||
)
|
||||
bins
|
||||
pure . rights . concat . maybeToList $ vers
|
||||
|
||||
@@ -446,7 +422,7 @@ hlsGHCVersions = do
|
||||
-- | Get all server binaries for an hls version, if any.
|
||||
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
|
||||
=> Version
|
||||
-> m [FilePath]
|
||||
-> m [Path Rel]
|
||||
hlsServerBinaries ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
@@ -454,7 +430,7 @@ hlsServerBinaries ver = do
|
||||
(makeRegexOpts
|
||||
compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
|
||||
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
|
||||
)
|
||||
)
|
||||
|
||||
@@ -462,7 +438,7 @@ hlsServerBinaries ver = do
|
||||
-- | Get the wrapper binary for an hls version, if any.
|
||||
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
=> Version
|
||||
-> m (Maybe FilePath)
|
||||
-> m (Maybe (Path Rel))
|
||||
hlsWrapperBinary ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
@@ -470,7 +446,7 @@ hlsWrapperBinary ver = do
|
||||
(makeRegexOpts
|
||||
compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
|
||||
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [s|$|] :: ByteString
|
||||
)
|
||||
)
|
||||
case wrapper of
|
||||
@@ -481,7 +457,7 @@ hlsWrapperBinary ver = do
|
||||
|
||||
|
||||
-- | Get all binaries for an hls version, if any.
|
||||
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath]
|
||||
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
|
||||
hlsAllBinaries ver = do
|
||||
hls <- hlsServerBinaries ver
|
||||
wrapper <- hlsWrapperBinary ver
|
||||
@@ -489,7 +465,7 @@ hlsAllBinaries ver = do
|
||||
|
||||
|
||||
-- | Get the active symlinks for hls.
|
||||
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath]
|
||||
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Path Rel]
|
||||
hlsSymlinks = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
@@ -499,8 +475,9 @@ hlsSymlinks = do
|
||||
([s|^haskell-language-server-.*$|] :: ByteString)
|
||||
)
|
||||
filterM
|
||||
( liftIO
|
||||
. pathIsSymbolicLink
|
||||
( fmap (== SymbolicLink)
|
||||
. liftIO
|
||||
. getFileType
|
||||
. (binDir </>)
|
||||
)
|
||||
oldSyms
|
||||
@@ -564,61 +541,61 @@ getLatestGHCFor major' minor' dls =
|
||||
|
||||
-- | Unpack an archive to a temporary directory and return that path.
|
||||
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
=> FilePath -- ^ destination dir
|
||||
-> FilePath -- ^ archive path
|
||||
=> Path Abs -- ^ destination dir
|
||||
-> Path Abs -- ^ archive path
|
||||
-> Excepts '[UnknownArchive
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
] m ()
|
||||
unpackToDir dfp av = do
|
||||
let fn = takeFileName av
|
||||
lift $ $(logInfo) [i|Unpacking: #{fn} to #{dfp}|]
|
||||
unpackToDir dest av = do
|
||||
fp <- decUTF8Safe . toFilePath <$> basename av
|
||||
let dfp = decUTF8Safe . toFilePath $ dest
|
||||
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
|
||||
fn <- toFilePath <$> basename av
|
||||
|
||||
#if defined(TAR)
|
||||
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
|
||||
untar = liftIO . Tar.unpack dfp . Tar.read
|
||||
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
|
||||
|
||||
rf :: MonadIO m => FilePath -> Excepts '[] m BL.ByteString
|
||||
rf = liftIO . BL.readFile
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
#else
|
||||
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
|
||||
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
|
||||
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
|
||||
|
||||
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
|
||||
rf = liftIO . BL.readFile
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
#endif
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| ".tar.gz" `isSuffixOf` fn -> liftE
|
||||
| ".tar.gz" `B.isSuffixOf` fn -> liftE
|
||||
(untar . GZip.decompress =<< rf av)
|
||||
| ".tar.xz" `isSuffixOf` fn -> do
|
||||
| ".tar.xz" `B.isSuffixOf` fn -> do
|
||||
filecontents <- liftE $ rf av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftE $ untar decompressed
|
||||
| ".tar.bz2" `isSuffixOf` fn ->
|
||||
| ".tar.bz2" `B.isSuffixOf` fn ->
|
||||
liftE (untar . BZip.decompress =<< rf av)
|
||||
| ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av)
|
||||
| ".zip" `isSuffixOf` fn ->
|
||||
withArchive av (unpackInto dfp)
|
||||
| ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
=> FilePath -- ^ archive path
|
||||
=> Path Abs -- ^ archive path
|
||||
-> Excepts '[UnknownArchive
|
||||
#if defined(TAR)
|
||||
, Tar.FormatError
|
||||
#else
|
||||
, ArchiveResult
|
||||
#endif
|
||||
] m [FilePath]
|
||||
] m [ByteString]
|
||||
getArchiveFiles av = do
|
||||
let fn = takeFileName av
|
||||
fn <- toFilePath <$> basename av
|
||||
|
||||
#if defined(TAR)
|
||||
let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [FilePath]
|
||||
let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [ByteString]
|
||||
entries =
|
||||
lE @Tar.FormatError
|
||||
. Tar.foldEntries
|
||||
@@ -627,45 +604,41 @@ getArchiveFiles av = do
|
||||
(\e -> Left e)
|
||||
. Tar.read
|
||||
|
||||
rf :: MonadIO m => FilePath -> Excepts '[Tar.FormatError] m BL.ByteString
|
||||
rf = liftIO . BL.readFile
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[Tar.FormatError] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
#else
|
||||
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath]
|
||||
entries = (fmap . fmap) filepath . lE . readArchiveBSL
|
||||
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [ByteString]
|
||||
entries = (fmap . fmap) (E.encodeUtf8 . T.pack . filepath) . lE . readArchiveBSL
|
||||
|
||||
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
|
||||
rf = liftIO . BL.readFile
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
#endif
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| ".tar.gz" `isSuffixOf` fn -> liftE
|
||||
| ".tar.gz" `B.isSuffixOf` fn -> liftE
|
||||
(entries . GZip.decompress =<< rf av)
|
||||
| ".tar.xz" `isSuffixOf` fn -> do
|
||||
| ".tar.xz" `B.isSuffixOf` fn -> do
|
||||
filecontents <- liftE $ rf av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftE $ entries decompressed
|
||||
| ".tar.bz2" `isSuffixOf` fn ->
|
||||
| ".tar.bz2" `B.isSuffixOf` fn ->
|
||||
liftE (entries . BZip.decompress =<< rf av)
|
||||
| ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av)
|
||||
| ".zip" `isSuffixOf` fn ->
|
||||
withArchive av $ do
|
||||
entries' <- getEntries
|
||||
pure $ fmap unEntrySelector $ Map.keys entries'
|
||||
| ".tar" `B.isSuffixOf` fn -> liftE (entries =<< rf av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
|
||||
=> FilePath -- ^ unpacked tar dir
|
||||
=> Path Abs -- ^ unpacked tar dir
|
||||
-> TarDir -- ^ how to descend
|
||||
-> Excepts '[TarDirDoesNotExist] m FilePath
|
||||
-> Excepts '[TarDirDoesNotExist] m (Path Abs)
|
||||
intoSubdir bdir tardir = case tardir of
|
||||
RealDir pr -> do
|
||||
whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
|
||||
(throwE $ TarDirDoesNotExist tardir)
|
||||
pure (bdir </> pr)
|
||||
RegexDir r -> do
|
||||
let rs = split (`elem` pathSeparators) r
|
||||
let rs = splitOn "/" r
|
||||
foldlM
|
||||
(\y x ->
|
||||
(handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
|
||||
@@ -726,124 +699,119 @@ getDownloader = ask <&> downloader . settings
|
||||
-------------
|
||||
|
||||
|
||||
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
|
||||
-> ByteString
|
||||
urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
|
||||
urlBaseName :: MonadThrow m
|
||||
=> ByteString -- ^ the url path (without scheme and host)
|
||||
-> m (Path Rel)
|
||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
|
||||
|
||||
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
|
||||
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
|
||||
--
|
||||
-- Returns unversioned relative files without extension, e.g.:
|
||||
-- Returns unversioned relative files, e.g.:
|
||||
--
|
||||
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
|
||||
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m [FilePath]
|
||||
-> Excepts '[NotInstalled] m [Path Rel]
|
||||
ghcToolFiles ver = do
|
||||
ghcdir <- lift $ ghcupGHCDir ver
|
||||
let bindir = ghcdir </> "bin"
|
||||
let bindir = ghcdir </> [rel|bin|]
|
||||
|
||||
-- fail if ghc is not installed
|
||||
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
|
||||
(throwE (NotInstalled GHC ver))
|
||||
|
||||
files <- liftIO $ listDirectory bindir
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
-- figure out the <ver> suffix, because this might not be `Version` for
|
||||
-- alpha/rc releases, but x.y.a.somedate.
|
||||
|
||||
ghcIsHadrian <- liftIO $ isHadrian bindir
|
||||
onlyUnversioned <- case ghcIsHadrian of
|
||||
Right () -> pure id
|
||||
Left (fmap (dropSuffix exeExt) -> [ghc, ghc_ver])
|
||||
| (Just symver) <- stripPrefix (ghc <> "-") ghc_ver
|
||||
, not (null symver) -> pure $ filter (\x -> not $ symver `isInfixOf` x)
|
||||
_ -> fail "Fatal: Could not find internal GHC version"
|
||||
-- for cross, this won't be "ghc", but e.g.
|
||||
-- "armv7-unknown-linux-gnueabihf-ghc"
|
||||
[ghcbin] <- liftIO $ findFiles
|
||||
bindir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
|
||||
)
|
||||
|
||||
pure $ onlyUnversioned $ fmap (dropSuffix exeExt) files
|
||||
let ghcbinPath = bindir </> ghcbin
|
||||
ghcIsHadrian <- liftIO $ isHadrian ghcbinPath
|
||||
onlyUnversioned <- if ghcIsHadrian
|
||||
then pure id
|
||||
else do
|
||||
(Just symver) <-
|
||||
B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName
|
||||
<$> liftIO (readSymbolicLink $ toFilePath ghcbinPath)
|
||||
when (B.null symver)
|
||||
(throwIO $ userError "Fatal: ghc symlink target is broken")
|
||||
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
|
||||
|
||||
pure $ onlyUnversioned files
|
||||
where
|
||||
isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
|
||||
-- GHC is moving some builds to Hadrian for bindists,
|
||||
-- which doesn't create versioned binaries.
|
||||
-- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
|
||||
isHadrian :: FilePath -- ^ ghcbin path
|
||||
-> IO (Either [String] ()) -- ^ Right for Hadrian
|
||||
isHadrian dir = do
|
||||
-- Non-hadrian has e.g. ["ghc", "ghc-8.10.4"]
|
||||
-- which also requires us to discover the internal version
|
||||
-- to filter the correct tool files.
|
||||
-- We can't use the symlink on windows, so we fall back to some
|
||||
-- more complicated logic.
|
||||
fs <- fmap
|
||||
-- regex over-matches
|
||||
(filter (isNotAnyInfix ["haddock", "ghc-pkg", "ghci"]))
|
||||
$ liftIO $ findFiles
|
||||
dir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
-- for cross, this won't be "ghc", but e.g.
|
||||
-- "armv7-unknown-linux-gnueabihf-ghc"
|
||||
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc.*$|] :: ByteString)
|
||||
)
|
||||
if | length fs == 1 -> pure $ Right () -- hadrian
|
||||
| length fs == 2 -> pure $ Left
|
||||
(sortOn length fs) -- legacy make, result should
|
||||
-- be ["ghc", "ghc-8.10.4"]
|
||||
| otherwise -> fail "isHadrian failed!"
|
||||
|
||||
isHadrian :: Path Abs -- ^ ghcbin path
|
||||
-> IO Bool
|
||||
isHadrian = fmap (/= SymbolicLink) . getFileType
|
||||
|
||||
|
||||
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
|
||||
-- this GHC was built from source. It contains the build config.
|
||||
ghcUpSrcBuiltFile :: FilePath
|
||||
ghcUpSrcBuiltFile = ".ghcup_src_built"
|
||||
ghcUpSrcBuiltFile :: Path Rel
|
||||
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
|
||||
|
||||
|
||||
-- | Calls gmake if it exists in PATH, otherwise make.
|
||||
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
|
||||
=> [String]
|
||||
-> Maybe FilePath
|
||||
make :: (MonadThrow m, MonadIO m, MonadReader AppState m, MonadMask m)
|
||||
=> [ByteString]
|
||||
-> Maybe (Path Abs)
|
||||
-> MVar Bool
|
||||
-> Seq ConsoleRegion
|
||||
-> m (Either ProcessError ())
|
||||
make args workdir = do
|
||||
spaths <- liftIO getSearchPath
|
||||
has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
|
||||
make args workdir pState rs = do
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
|
||||
let mymake = if has_gmake then "gmake" else "make"
|
||||
execLogged mymake args workdir "ghc-make" Nothing
|
||||
execLogged mymake True args [rel|ghc-make|] workdir Nothing pState rs
|
||||
|
||||
makeOut :: [String]
|
||||
-> Maybe FilePath
|
||||
makeOut :: [ByteString]
|
||||
-> Maybe (Path Abs)
|
||||
-> IO CapturedProcess
|
||||
makeOut args workdir = do
|
||||
spaths <- liftIO getSearchPath
|
||||
has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
|
||||
let mymake = if has_gmake then "gmake" else "make"
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
|
||||
let mymake = if has_gmake then [rel|gmake|] else [rel|make|]
|
||||
liftIO $ executeOut mymake args workdir
|
||||
|
||||
|
||||
-- | Try to apply patches in order. Fails with 'PatchFailed'
|
||||
-- on first failure.
|
||||
applyPatches :: (MonadLogger m, MonadIO m)
|
||||
=> FilePath -- ^ dir containing patches
|
||||
-> FilePath -- ^ dir to apply patches in
|
||||
=> Path Abs -- ^ dir containing patches
|
||||
-> Path Abs -- ^ dir to apply patches in
|
||||
-> Excepts '[PatchFailed] m ()
|
||||
applyPatches pdir ddir = do
|
||||
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
|
||||
patches <- liftIO $ getDirsFiles pdir
|
||||
forM_ (sort patches) $ \patch' -> do
|
||||
lift $ $(logInfo) [i|Applying patch #{patch'}|]
|
||||
fmap (either (const Nothing) Just)
|
||||
(liftIO $ exec
|
||||
"patch"
|
||||
["-p1", "-i", patch']
|
||||
True
|
||||
["-p1", "-i", toFilePath patch']
|
||||
(Just ddir)
|
||||
Nothing)
|
||||
!? PatchFailed
|
||||
|
||||
|
||||
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
|
||||
darwinNotarization :: Platform -> FilePath -> IO (Either ProcessError ())
|
||||
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
|
||||
darwinNotarization Darwin path = exec
|
||||
"xattr"
|
||||
["-r", "-d", "com.apple.quarantine", path]
|
||||
True
|
||||
["-r", "-d", "com.apple.quarantine", toFilePath path]
|
||||
Nothing
|
||||
Nothing
|
||||
darwinNotarization _ _ = pure $ Right ()
|
||||
@@ -861,19 +829,19 @@ getChangeLog dls tool (Right tag) =
|
||||
-- 1. the build directory, depending on the KeepDirs setting
|
||||
-- 2. the install destination, depending on whether the build failed
|
||||
runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
|
||||
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
||||
-> Maybe FilePath -- ^ dir to *always* clean up on exception
|
||||
=> Path Abs -- ^ build directory (cleaned up depending on Settings)
|
||||
-> Maybe (Path Abs) -- ^ dir to *always* clean up on exception
|
||||
-> Excepts e m a
|
||||
-> Excepts '[BuildFailed] m a
|
||||
runBuildAction bdir instdir action = do
|
||||
AppState { settings = Settings {..} } <- lift ask
|
||||
let exAction = do
|
||||
forM_ instdir $ \dir ->
|
||||
liftIO $ hideError doesNotExistErrorType $ removeDirectoryRecursive dir
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
|
||||
when (keepDirs == Never)
|
||||
$ liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
$ removeDirectoryRecursive bdir
|
||||
$ deleteDirRecursive bdir
|
||||
v <-
|
||||
flip onException exAction
|
||||
$ catchAllE
|
||||
@@ -882,90 +850,32 @@ runBuildAction bdir instdir action = do
|
||||
throwE (BuildFailed bdir es)
|
||||
) action
|
||||
|
||||
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ removeDirectoryRecursive
|
||||
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
|
||||
bdir
|
||||
pure v
|
||||
|
||||
|
||||
-- | More permissive version of 'createDirRecursive'. This doesn't
|
||||
-- error when the destination is a symlink to a directory.
|
||||
createDirRecursive' :: FilePath -> IO ()
|
||||
createDirRecursive' :: Path b -> IO ()
|
||||
createDirRecursive' p =
|
||||
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
|
||||
. createDirectoryIfMissing True
|
||||
. createDirRecursive newDirPerms
|
||||
$ p
|
||||
|
||||
where
|
||||
isSymlinkDir e = do
|
||||
ft <- pathIsSymbolicLink p
|
||||
ft <- getFileType p
|
||||
case ft of
|
||||
True -> do
|
||||
SymbolicLink -> do
|
||||
rp <- canonicalizePath p
|
||||
rft <- doesDirectoryExist rp
|
||||
rft <- getFileType rp
|
||||
case rft of
|
||||
True -> pure ()
|
||||
Directory -> 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 -> IO ()
|
||||
copyDirectoryRecursive srcDir destDir = do
|
||||
srcFiles <- getDirectoryContentsRecursive srcDir
|
||||
copyFilesWith copyFile destDir [ (srcDir, f)
|
||||
| f <- srcFiles ]
|
||||
where
|
||||
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
|
||||
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
|
||||
copyFilesWith :: (FilePath -> FilePath -> IO ())
|
||||
-> FilePath -> [(FilePath, FilePath)] -> IO ()
|
||||
copyFilesWith doCopy targetDir srcFiles = do
|
||||
|
||||
-- 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
|
||||
|
||||
|
||||
getVersionInfo :: Version
|
||||
-> Tool
|
||||
-> GHCupDownloads
|
||||
@@ -988,11 +898,25 @@ forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
|
||||
forFold = \t -> (`traverseFold` t)
|
||||
|
||||
|
||||
-- | The file extension for executables.
|
||||
exeExt :: String
|
||||
#if defined(IS_WINDOWS)
|
||||
exeExt = ".exe"
|
||||
#else
|
||||
exeExt = ""
|
||||
#endif
|
||||
withConsoleRegions :: (MonadReader AppState m, MonadIO m, MonadMask m) => (MVar Bool -> Seq ConsoleRegion -> m a) -> m a
|
||||
withConsoleRegions = withConsoleRegions' Linear 6
|
||||
|
||||
|
||||
withConsoleRegions' :: (MonadReader AppState m, MonadIO m, MonadMask m) => RegionLayout -> Int -> (MVar Bool -> Seq ConsoleRegion -> m a) -> m a
|
||||
withConsoleRegions' ly size action = do
|
||||
AppState { settings = Settings {..} } <- ask
|
||||
pState <- liftIO newEmptyMVar
|
||||
if (not verbose)
|
||||
then displayConsoleRegions $
|
||||
bracketIO
|
||||
(fmap Sq.fromList . sequence . replicate size . openConsoleRegion $ ly)
|
||||
(\rs -> uninterruptibleMask_ $ do
|
||||
ps <- takeMVar pState
|
||||
when ps (forM_ rs closeConsoleRegion))
|
||||
(action pState)
|
||||
else
|
||||
action pState mempty
|
||||
|
||||
where
|
||||
bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a
|
||||
bracketIO setup cleanup' = bracket (liftIO setup) (liftIO . cleanup')
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@@ -13,7 +12,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Utils.Dirs
|
||||
( getDirs
|
||||
@@ -35,6 +34,7 @@ import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.MegaParsec
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Unlift
|
||||
@@ -42,20 +42,32 @@ import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource hiding (throwM)
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Optics
|
||||
import System.Directory
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.DiskSpace
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO.Temp
|
||||
import System.Posix.Env.ByteString ( getEnv
|
||||
, getEnvDefault
|
||||
)
|
||||
import System.Posix.FilePath hiding ( (</>) )
|
||||
import System.Posix.Temp.ByteString ( mkdtemp )
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Yaml as Y
|
||||
import qualified System.Posix.FilePath as FP
|
||||
import qualified System.Posix.User as PU
|
||||
import qualified Text.Megaparsec as MP
|
||||
import Control.Concurrent (threadDelay)
|
||||
|
||||
@@ -70,96 +82,96 @@ 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 (Path Abs)
|
||||
ghcupBaseDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
bdir <- getEnv "XDG_DATA_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ".local" </> "share")
|
||||
pure (bdir </> "ghcup")
|
||||
pure (home </> [rel|.local/share|])
|
||||
pure (bdir </> [rel|ghcup|])
|
||||
else do
|
||||
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> pure r
|
||||
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> liftIO getHomeDirectory
|
||||
pure (bdir </> ".ghcup")
|
||||
pure (bdir </> [rel|.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 (Path Abs)
|
||||
ghcupConfigDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
bdir <- getEnv "XDG_CONFIG_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ".config")
|
||||
pure (bdir </> "ghcup")
|
||||
pure (home </> [rel|.config|])
|
||||
pure (bdir </> [rel|ghcup|])
|
||||
else do
|
||||
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> pure r
|
||||
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> liftIO getHomeDirectory
|
||||
pure (bdir </> ".ghcup")
|
||||
pure (bdir </> [rel|.ghcup|])
|
||||
|
||||
|
||||
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
|
||||
-- (which, sadly is not strictly xdg spec).
|
||||
ghcupBinDir :: IO FilePath
|
||||
ghcupBinDir :: IO (Path Abs)
|
||||
ghcupBinDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
lookupEnv "XDG_BIN_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
getEnv "XDG_BIN_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ".local" </> "bin")
|
||||
else ghcupBaseDir <&> (</> "bin")
|
||||
pure (home </> [rel|.local/bin|])
|
||||
else ghcupBaseDir <&> (</> [rel|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 (Path Abs)
|
||||
ghcupCacheDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ".cache")
|
||||
pure (bdir </> "ghcup")
|
||||
else ghcupBaseDir <&> (</> "cache")
|
||||
pure (home </> [rel|.cache|])
|
||||
pure (bdir </> [rel|ghcup|])
|
||||
else ghcupBaseDir <&> (</> [rel|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 (Path Abs)
|
||||
ghcupLogsDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ".cache")
|
||||
pure (bdir </> "ghcup" </> "logs")
|
||||
else ghcupBaseDir <&> (</> "logs")
|
||||
pure (home </> [rel|.cache|])
|
||||
pure (bdir </> [rel|ghcup/logs|])
|
||||
else ghcupBaseDir <&> (</> [rel|logs|])
|
||||
|
||||
|
||||
getDirs :: IO Dirs
|
||||
@@ -182,11 +194,11 @@ ghcupConfigFile :: (MonadIO m)
|
||||
=> Excepts '[JSONError] m UserSettings
|
||||
ghcupConfigFile = do
|
||||
confDir <- liftIO ghcupConfigDir
|
||||
let file = confDir </> "config.yaml"
|
||||
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile file
|
||||
case contents of
|
||||
let file = confDir </> [rel|config.yaml|]
|
||||
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
|
||||
case bs of
|
||||
Nothing -> pure defaultUserSettings
|
||||
Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
|
||||
Just bs' -> lE' JSONDecodeError . first show . Y.decodeEither' . L.toStrict $ bs'
|
||||
|
||||
|
||||
-------------------------
|
||||
@@ -195,10 +207,10 @@ ghcupConfigFile = do
|
||||
|
||||
|
||||
-- | ~/.ghcup/ghc by default.
|
||||
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
|
||||
ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
|
||||
ghcupGHCBaseDir = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
pure (baseDir </> "ghc")
|
||||
pure (baseDir </> [rel|ghc|])
|
||||
|
||||
|
||||
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
|
||||
@@ -207,32 +219,35 @@ ghcupGHCBaseDir = do
|
||||
-- * 8.8.4
|
||||
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
|
||||
=> GHCTargetVersion
|
||||
-> m FilePath
|
||||
-> m (Path Abs)
|
||||
ghcupGHCDir ver = do
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
let verdir = T.unpack $ tVerToText ver
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel $ E.encodeUtf8 (tVerToText ver)
|
||||
pure (ghcbasedir </> verdir)
|
||||
|
||||
|
||||
-- | See 'ghcupToolParser'.
|
||||
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
|
||||
parseGHCupGHCDir (T.pack -> fp) =
|
||||
parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
|
||||
parseGHCupGHCDir (toFilePath -> f) = do
|
||||
fp <- throwEither $ E.decodeUtf8' f
|
||||
throwEither $ MP.parse ghcTargetVerP "" fp
|
||||
|
||||
|
||||
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
|
||||
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
mkGhcupTmpDir = do
|
||||
tmpdir <- liftIO getCanonicalTemporaryDirectory
|
||||
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
|
||||
let fp = T.unpack $ decUTF8Safe tmpdir
|
||||
|
||||
let minSpace = 5000 -- a rough guess, aight?
|
||||
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
|
||||
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace fp
|
||||
when (maybe False (toBytes minSpace >) space) $ do
|
||||
$(logWarn) [i|Possibly insufficient disk space on #{tmpdir}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
|
||||
$(logWarn) [i|Possibly insufficient disk space on #{fp}. At least #{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"
|
||||
tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
|
||||
parseAbs tmp
|
||||
where
|
||||
toBytes mb = mb * 1024 * 1024
|
||||
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
|
||||
@@ -241,8 +256,8 @@ mkGhcupTmpDir = do
|
||||
where t = 10^n
|
||||
|
||||
|
||||
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
|
||||
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) removeDirectoryRecursive)
|
||||
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) deleteDirRecursive)
|
||||
|
||||
|
||||
|
||||
@@ -252,19 +267,29 @@ withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir
|
||||
--------------
|
||||
|
||||
|
||||
getHomeDirectory :: IO (Path Abs)
|
||||
getHomeDirectory = do
|
||||
e <- getEnv "HOME"
|
||||
case e of
|
||||
Just fp -> parseAbs fp
|
||||
Nothing -> do
|
||||
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
|
||||
parseAbs $ UTF8.fromString h -- this is a guess
|
||||
|
||||
|
||||
useXDG :: IO Bool
|
||||
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
|
||||
useXDG = isJust <$> getEnv "GHCUP_USE_XDG_DIRS"
|
||||
|
||||
|
||||
relativeSymlink :: FilePath -- ^ the path in which to create the symlink
|
||||
-> FilePath -- ^ the symlink destination
|
||||
-> FilePath
|
||||
relativeSymlink p1 p2 =
|
||||
relativeSymlink :: Path Abs -- ^ the path in which to create the symlink
|
||||
-> Path Abs -- ^ the symlink destination
|
||||
-> ByteString
|
||||
relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
|
||||
let d1 = splitDirectories p1
|
||||
d2 = splitDirectories p2
|
||||
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
|
||||
cPrefix = drop (length common) d1
|
||||
in joinPath (replicate (length cPrefix) "..")
|
||||
<> joinPath ([pathSeparator] : drop (length common) d2)
|
||||
<> joinPath ("/" : drop (length common) d2)
|
||||
|
||||
|
||||
|
||||
@@ -1,17 +1,482 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
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
|
||||
{-|
|
||||
Module : GHCup.Utils.File
|
||||
Description : File and unix APIs
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
|
||||
import GHCup.Utils.File.Common
|
||||
#if IS_WINDOWS
|
||||
import GHCup.Utils.File.Windows
|
||||
#else
|
||||
import GHCup.Utils.File.Posix
|
||||
#endif
|
||||
This module handles file and executable handling.
|
||||
Some of these functions use sophisticated logging.
|
||||
-}
|
||||
module GHCup.Utils.File where
|
||||
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
import Control.Exception ( evaluate )
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.State.Strict
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.Sequence ( Seq, (|>) )
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Void
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO hiding ( hideError )
|
||||
import Optics hiding ((<|), (|>))
|
||||
import System.Console.Pretty hiding ( Pretty )
|
||||
import System.Console.Regions
|
||||
import System.IO.Error
|
||||
import System.Posix.Directory.ByteString
|
||||
import System.Posix.FD as FD
|
||||
import System.Posix.FilePath hiding ( (</>) )
|
||||
import System.Posix.Files.ByteString
|
||||
import System.Posix.Foreign ( oExcl, oAppend )
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( openFd )
|
||||
import System.Posix.Process ( ProcessStatus(..) )
|
||||
import System.Posix.Types
|
||||
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
|
||||
import Text.Regex.Posix
|
||||
|
||||
|
||||
import qualified Control.Exception as EX
|
||||
import qualified Data.Sequence as Sq
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
import Streamly.External.Posix.DirStream
|
||||
import qualified Streamly.Prelude as S
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
||||
as SPIB
|
||||
|
||||
|
||||
|
||||
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
||||
| PTerminated ByteString [ByteString]
|
||||
| PStopped ByteString [ByteString]
|
||||
| NoSuchPid ByteString [ByteString]
|
||||
deriving Show
|
||||
|
||||
instance Pretty ProcessError where
|
||||
pPrint (NonZeroExit e exe args) =
|
||||
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} failed with exit code #{e}.|]
|
||||
pPrint (PTerminated exe args) =
|
||||
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} terminated.|]
|
||||
pPrint (PStopped exe args) =
|
||||
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} stopped.|]
|
||||
pPrint (NoSuchPid exe args) =
|
||||
text [i|Could not find PID for process running "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args}.|]
|
||||
|
||||
data CapturedProcess = CapturedProcess
|
||||
{ _exitCode :: ExitCode
|
||||
, _stdOut :: ByteString
|
||||
, _stdErr :: ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
makeLenses ''CapturedProcess
|
||||
|
||||
|
||||
-- | Find the given executable by searching all *absolute* PATH components.
|
||||
-- Relative paths in PATH are ignored.
|
||||
--
|
||||
-- This shouldn't throw IO exceptions, unless getting the environment variable
|
||||
-- PATH does.
|
||||
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
|
||||
findExecutable ex = do
|
||||
sPaths <- fmap (catMaybes . fmap parseAbs) getSearchPath
|
||||
-- We don't want exceptions to mess up our result. If we can't
|
||||
-- figure out if a file exists, then treat it as a negative result.
|
||||
asum $ fmap
|
||||
(handleIO (\_ -> pure Nothing)
|
||||
-- asum for short-circuiting behavior
|
||||
. (\s' -> (isExecutable (s' </> ex) >>= guard) $> Just (s' </> ex))
|
||||
)
|
||||
sPaths
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
|
||||
-> [ByteString] -- ^ arguments to the command
|
||||
-> Maybe (Path Abs) -- ^ chdir to this path
|
||||
-> IO CapturedProcess
|
||||
executeOut path args chdir = captureOutStreams $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile (toFilePath path) True args Nothing
|
||||
|
||||
|
||||
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
=> ByteString -- ^ thing to execute
|
||||
-> Bool -- ^ whether to search PATH for the thing
|
||||
-> [ByteString] -- ^ args for the thing
|
||||
-> Path Rel -- ^ log filename (opened in append mode)
|
||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> MVar Bool
|
||||
-> Seq ConsoleRegion
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe spath args lfile chdir env pState rs = do
|
||||
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
|
||||
logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
|
||||
liftIO $ bracket (openFd (toFilePath logfile) WriteOnly [oAppend] (Just newFilePerms))
|
||||
closeFd
|
||||
(action verbose)
|
||||
where
|
||||
action verbose fd = do
|
||||
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
||||
-- start the thread that logs to stdout
|
||||
void $ tryTakeMVar pState
|
||||
done <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ EX.finally
|
||||
(if verbose
|
||||
then tee fd stdoutRead
|
||||
else printToRegion fd stdoutRead 6
|
||||
)
|
||||
(putMVar done ())
|
||||
|
||||
-- fork the subprocess
|
||||
pid <- SPPB.forkProcess $ do
|
||||
void $ dupTo stdoutWrite stdOutput
|
||||
void $ dupTo stdoutWrite stdError
|
||||
closeFd stdoutRead
|
||||
closeFd stdoutWrite
|
||||
|
||||
-- execute the action
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
void $ SPPB.executeFile exe spath args env
|
||||
|
||||
closeFd stdoutWrite
|
||||
|
||||
-- wait for the subprocess to finish
|
||||
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
|
||||
putMVar pState (either (const False) (const True) e)
|
||||
|
||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
||||
closeFd stdoutRead
|
||||
|
||||
pure e
|
||||
|
||||
tee :: Fd -> Fd -> IO ()
|
||||
tee fileFd fdIn = readTilEOF lineAction fdIn
|
||||
|
||||
where
|
||||
lineAction :: ByteString -> IO ()
|
||||
lineAction bs' = do
|
||||
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
|
||||
|
||||
-- Reads fdIn and logs the output in a continous scrolling area
|
||||
-- of 'size' terminal lines. Also writes to a log file.
|
||||
printToRegion :: Fd -> Fd -> Int -> IO ()
|
||||
printToRegion fileFd fdIn size = do
|
||||
void $
|
||||
flip runStateT mempty $ readTilEOF (lineAction rs) fdIn
|
||||
|
||||
where
|
||||
-- action to perform line by line
|
||||
-- TODO: do this with vty for efficiency
|
||||
lineAction :: (MonadMask m, MonadIO m)
|
||||
=> Seq ConsoleRegion
|
||||
-> ByteString
|
||||
-> StateT (Seq ByteString) m ()
|
||||
lineAction rs' = \bs' -> do
|
||||
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
modify (swapRegs bs')
|
||||
regs <- get
|
||||
liftIO $ forM_ (Sq.zip regs rs') $ \(bs, r) -> setConsoleRegion r $ do
|
||||
w <- consoleWidth
|
||||
return
|
||||
. T.pack
|
||||
. color Blue
|
||||
. T.unpack
|
||||
. decUTF8Safe
|
||||
. trim w
|
||||
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
|
||||
$ bs
|
||||
|
||||
swapRegs :: a -> Seq a -> Seq a
|
||||
swapRegs bs = \regs -> if
|
||||
| Sq.length regs < size -> regs |> bs
|
||||
| otherwise -> Sq.drop 1 regs |> bs
|
||||
|
||||
-- trim output line to terminal width
|
||||
trim :: Int -> ByteString -> ByteString
|
||||
trim w = \bs -> if
|
||||
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
|
||||
| otherwise -> bs
|
||||
|
||||
-- Consecutively read from Fd in 512 chunks until we hit
|
||||
-- newline or EOF.
|
||||
readLine :: MonadIO m
|
||||
=> Fd -- ^ input file descriptor
|
||||
-> ByteString -- ^ rest buffer (read across newline)
|
||||
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
|
||||
readLine fd = go
|
||||
where
|
||||
go inBs = do
|
||||
-- if buffer is not empty, process it first
|
||||
mbs <- if BS.length inBs == 0
|
||||
-- otherwise attempt read
|
||||
then liftIO
|
||||
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
|
||||
$ fmap Just
|
||||
$ SPIB.fdRead fd 512
|
||||
else pure $ Just inBs
|
||||
case mbs of
|
||||
Nothing -> pure ("", "", True)
|
||||
Just bs -> do
|
||||
-- split on newline
|
||||
let (line, rest) = BS.span (/= _lf) bs
|
||||
if
|
||||
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
|
||||
-- if rest is empty, then there was no newline, process further
|
||||
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
|
||||
|
||||
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
|
||||
readTilEOF ~action' fd' = go mempty
|
||||
where
|
||||
go bs' = do
|
||||
(bs, rest, eof) <- readLine fd' bs'
|
||||
if eof
|
||||
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
|
||||
else void (action' bs) >> go rest
|
||||
|
||||
|
||||
-- | Capture the stdout and stderr of the given action, which
|
||||
-- is run in a subprocess. Stdin is closed. You might want to
|
||||
-- 'race' this to make sure it terminates.
|
||||
captureOutStreams :: IO a
|
||||
-- ^ the action to execute in a subprocess
|
||||
-> IO CapturedProcess
|
||||
captureOutStreams action = do
|
||||
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
|
||||
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
-- dup stdout
|
||||
void $ dupTo childStdoutWrite stdOutput
|
||||
closeFd childStdoutWrite
|
||||
closeFd parentStdoutRead
|
||||
|
||||
-- dup stderr
|
||||
void $ dupTo childStderrWrite stdError
|
||||
closeFd childStderrWrite
|
||||
closeFd parentStderrRead
|
||||
|
||||
-- execute the action
|
||||
a <- action
|
||||
void $ evaluate a
|
||||
|
||||
-- close everything we don't need
|
||||
closeFd childStdoutWrite
|
||||
closeFd childStderrWrite
|
||||
|
||||
-- start thread that writes the output
|
||||
refOut <- newIORef BS.empty
|
||||
refErr <- newIORef BS.empty
|
||||
done <- newEmptyMVar
|
||||
_ <-
|
||||
forkIO
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ flip EX.finally (putMVar done ())
|
||||
$ writeStds parentStdoutRead parentStderrRead refOut refErr
|
||||
|
||||
status <- SPPB.getProcessStatus True True pid
|
||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
||||
|
||||
case status of
|
||||
-- readFd will take care of closing the fd
|
||||
Just (SPPB.Exited es) -> do
|
||||
stdout' <- readIORef refOut
|
||||
stderr' <- readIORef refErr
|
||||
pure $ CapturedProcess { _exitCode = es
|
||||
, _stdOut = stdout'
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
|
||||
_ -> throwIO $ userError ("No such PID " ++ show pid)
|
||||
|
||||
where
|
||||
writeStds pout perr rout rerr = do
|
||||
doneOut <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip EX.finally (putMVar doneOut ())
|
||||
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
|
||||
doneErr <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip EX.finally (putMVar doneErr ())
|
||||
$ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
|
||||
takeMVar doneOut
|
||||
takeMVar doneErr
|
||||
|
||||
readTilEOF ~action' fd' = do
|
||||
bs <- SPIB.fdRead fd' 512
|
||||
void $ action' bs
|
||||
readTilEOF action' fd'
|
||||
|
||||
|
||||
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
|
||||
actionWithPipes a =
|
||||
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
|
||||
|
||||
cleanup :: [Fd] -> IO ()
|
||||
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
|
||||
|
||||
|
||||
|
||||
-- | Create a new regular file in write-only mode. The file must not exist.
|
||||
createRegularFileFd :: FileMode -> Path b -> IO Fd
|
||||
createRegularFileFd fm dest =
|
||||
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: ByteString -- ^ thing to execute
|
||||
-> Bool -- ^ whether to search PATH for the thing
|
||||
-> [ByteString] -- ^ args for the thing
|
||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
exec exe spath args chdir env = do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile exe spath args env
|
||||
|
||||
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
|
||||
|
||||
|
||||
toProcessError :: ByteString
|
||||
-> [ByteString]
|
||||
-> Maybe ProcessStatus
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args mps = case mps of
|
||||
Just (SPPB.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
|
||||
Just (SPPB.Exited ExitSuccess ) -> Right ()
|
||||
Just (Terminated _ _ ) -> Left $ PTerminated exe args
|
||||
Just (Stopped _ ) -> Left $ PStopped exe args
|
||||
Nothing -> Left $ NoSuchPid exe args
|
||||
|
||||
|
||||
-- | Search for a file in the search paths.
|
||||
--
|
||||
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
|
||||
searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
|
||||
searchPath paths needle = go paths
|
||||
where
|
||||
go [] = pure Nothing
|
||||
go (x : xs) =
|
||||
hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
|
||||
$ do
|
||||
dirStream <- openDirStream (toFilePath x)
|
||||
S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
|
||||
>>= \case
|
||||
Just _ -> pure $ Just (x </> needle)
|
||||
Nothing -> go xs
|
||||
isMatch basedir p = do
|
||||
if p == toFilePath needle
|
||||
then isExecutable (basedir </> needle)
|
||||
else pure False
|
||||
|
||||
|
||||
-- | Check wether a binary is shadowed by another one that comes before
|
||||
-- it in PATH. Returns the path to said binary, if any.
|
||||
isShadowed :: Path Abs -> IO (Maybe (Path Abs))
|
||||
isShadowed p = do
|
||||
let dir = dirname p
|
||||
fn <- basename p
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
if dir `elem` spaths
|
||||
then do
|
||||
let shadowPaths = takeWhile (/= dir) spaths
|
||||
searchPath shadowPaths fn
|
||||
else pure Nothing
|
||||
|
||||
|
||||
-- | Check whether the binary is in PATH. This returns only `True`
|
||||
-- if the directory containing the binary is part of PATH.
|
||||
isInPath :: Path Abs -> IO Bool
|
||||
isInPath p = do
|
||||
let dir = dirname p
|
||||
fn <- basename p
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
if dir `elem` spaths
|
||||
then isJust <$> searchPath [dir] fn
|
||||
else pure False
|
||||
|
||||
|
||||
findFiles :: Path Abs -> Regex -> IO [Path Rel]
|
||||
findFiles path regex = do
|
||||
dirStream <- openDirStream (toFilePath path)
|
||||
f <-
|
||||
(fmap . fmap) snd
|
||||
. S.toList
|
||||
. S.filter (\(_, p) -> match regex p)
|
||||
$ dirContentsStream dirStream
|
||||
pure $ parseRel =<< f
|
||||
|
||||
|
||||
findFiles' :: Path Abs -> MP.Parsec Void Text () -> IO [Path Rel]
|
||||
findFiles' path parser = do
|
||||
dirStream <- openDirStream (toFilePath path)
|
||||
f <-
|
||||
(fmap . fmap) snd
|
||||
. S.toList
|
||||
. S.filter (\(_, p) -> case E.decodeUtf8' p of
|
||||
Left _ -> False
|
||||
Right p' -> isJust $ MP.parseMaybe parser p')
|
||||
$ dirContentsStream dirStream
|
||||
pure $ parseRel =<< f
|
||||
|
||||
|
||||
isBrokenSymlink :: Path Abs -> IO Bool
|
||||
isBrokenSymlink p =
|
||||
handleIO
|
||||
(\e -> if ioeGetErrorType e == NoSuchThing then pure True else throwIO e)
|
||||
$ do
|
||||
_ <- canonicalizePath p
|
||||
pure False
|
||||
|
||||
|
||||
chmod_755 :: (MonadLogger m, MonadIO m) => Path a -> m ()
|
||||
chmod_755 (toFilePath -> fp) = do
|
||||
let exe_mode =
|
||||
nullFileMode
|
||||
`unionFileModes` ownerExecuteMode
|
||||
`unionFileModes` ownerReadMode
|
||||
`unionFileModes` ownerWriteMode
|
||||
`unionFileModes` groupExecuteMode
|
||||
`unionFileModes` groupReadMode
|
||||
`unionFileModes` otherExecuteMode
|
||||
`unionFileModes` otherReadMode
|
||||
$(logDebug) [i|chmod 755 #{fp}|]
|
||||
liftIO $ setFileMode fp exe_mode
|
||||
|
||||
@@ -1,122 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module GHCup.Utils.File.Common where
|
||||
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad.Extra
|
||||
import Control.Monad.Reader
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import GHC.IO.Exception
|
||||
import Optics hiding ((<|), (|>))
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
|
||||
|
||||
|
||||
data ProcessError = NonZeroExit Int FilePath [String]
|
||||
| PTerminated FilePath [String]
|
||||
| PStopped FilePath [String]
|
||||
| NoSuchPid FilePath [String]
|
||||
deriving Show
|
||||
|
||||
instance Pretty ProcessError where
|
||||
pPrint (NonZeroExit e exe args) =
|
||||
text [i|Process "#{exe}" with arguments #{args} failed with exit code #{e}.|]
|
||||
pPrint (PTerminated exe args) =
|
||||
text [i|Process "#{exe}" with arguments #{args} terminated.|]
|
||||
pPrint (PStopped exe args) =
|
||||
text [i|Process "#{exe}" with arguments #{args} stopped.|]
|
||||
pPrint (NoSuchPid exe args) =
|
||||
text [i|Could not find PID for process running "#{exe}" with arguments #{args}.|]
|
||||
|
||||
data CapturedProcess = CapturedProcess
|
||||
{ _exitCode :: ExitCode
|
||||
, _stdOut :: BL.ByteString
|
||||
, _stdErr :: BL.ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
makeLenses ''CapturedProcess
|
||||
|
||||
|
||||
|
||||
-- | Search for a file in the search paths.
|
||||
--
|
||||
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
|
||||
searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
|
||||
searchPath paths needle = go paths
|
||||
where
|
||||
go [] = pure Nothing
|
||||
go (x : xs) =
|
||||
hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
|
||||
$ do
|
||||
contents <- listDirectory x
|
||||
findM (isMatch x) contents >>= \case
|
||||
Just _ -> pure $ Just (x </> needle)
|
||||
Nothing -> go xs
|
||||
isMatch basedir p = do
|
||||
if p == needle
|
||||
then isExecutable (basedir </> needle)
|
||||
else pure False
|
||||
|
||||
isExecutable :: FilePath -> IO Bool
|
||||
isExecutable file = executable <$> getPermissions file
|
||||
|
||||
|
||||
-- | Check wether a binary is shadowed by another one that comes before
|
||||
-- it in PATH. Returns the path to said binary, if any.
|
||||
isShadowed :: FilePath -> IO (Maybe FilePath)
|
||||
isShadowed p = do
|
||||
let dir = takeDirectory p
|
||||
let fn = takeFileName p
|
||||
spaths <- liftIO getSearchPath
|
||||
if dir `elem` spaths
|
||||
then do
|
||||
let shadowPaths = takeWhile (/= dir) spaths
|
||||
searchPath shadowPaths fn
|
||||
else pure Nothing
|
||||
|
||||
|
||||
-- | Check whether the binary is in PATH. This returns only `True`
|
||||
-- if the directory containing the binary is part of PATH.
|
||||
isInPath :: FilePath -> IO Bool
|
||||
isInPath p = do
|
||||
let dir = takeDirectory p
|
||||
let fn = takeFileName p
|
||||
spaths <- liftIO getSearchPath
|
||||
if dir `elem` spaths
|
||||
then isJust <$> searchPath [dir] fn
|
||||
else pure False
|
||||
|
||||
|
||||
findFiles :: FilePath -> Regex -> IO [FilePath]
|
||||
findFiles path regex = do
|
||||
contents <- listDirectory path
|
||||
pure $ filter (match regex) contents
|
||||
|
||||
|
||||
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,368 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.File.Posix
|
||||
Description : File and unix APIs
|
||||
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
|
||||
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async
|
||||
import Control.Exception ( evaluate )
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.State.Strict
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Foldable
|
||||
import Data.IORef
|
||||
import Data.Sequence ( Seq, (|>) )
|
||||
import Data.String.Interpolate
|
||||
import Data.List
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import System.Console.Pretty hiding ( Pretty )
|
||||
import System.Console.Regions
|
||||
import System.IO.Error
|
||||
import System.FilePath
|
||||
import System.Posix.Directory
|
||||
import System.Posix.Files
|
||||
import System.Posix.IO
|
||||
import System.Posix.Process ( ProcessStatus(..) )
|
||||
import System.Posix.Types
|
||||
|
||||
|
||||
import qualified Control.Exception as EX
|
||||
import qualified Data.Sequence as Sq
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.Posix.Process as SPP
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
||||
as SPIB
|
||||
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: FilePath -- ^ command as filename, e.g. 'ls'
|
||||
-> [String] -- ^ arguments to the command
|
||||
-> Maybe FilePath -- ^ chdir to this path
|
||||
-> IO CapturedProcess
|
||||
executeOut path args chdir = captureOutStreams $ do
|
||||
maybe (pure ()) changeWorkingDirectory chdir
|
||||
SPP.executeFile path True args Nothing
|
||||
|
||||
|
||||
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> FilePath -- ^ log filename (opened in append mode)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
|
||||
let logfile = logsDir </> lfile <> ".log"
|
||||
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
|
||||
closeFd
|
||||
(action verbose)
|
||||
where
|
||||
action verbose fd = do
|
||||
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
||||
-- start the thread that logs to stdout
|
||||
pState <- newEmptyMVar
|
||||
done <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ EX.finally
|
||||
(if verbose
|
||||
then tee fd stdoutRead
|
||||
else printToRegion fd stdoutRead 6 pState
|
||||
)
|
||||
(putMVar done ())
|
||||
|
||||
-- fork the subprocess
|
||||
pid <- SPP.forkProcess $ do
|
||||
void $ dupTo stdoutWrite stdOutput
|
||||
void $ dupTo stdoutWrite stdError
|
||||
closeFd stdoutRead
|
||||
closeFd stdoutWrite
|
||||
|
||||
-- execute the action
|
||||
maybe (pure ()) changeWorkingDirectory chdir
|
||||
void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
|
||||
|
||||
closeFd stdoutWrite
|
||||
|
||||
-- wait for the subprocess to finish
|
||||
e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid
|
||||
putMVar pState (either (const False) (const True) e)
|
||||
|
||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
||||
closeFd stdoutRead
|
||||
|
||||
pure e
|
||||
|
||||
tee :: Fd -> Fd -> IO ()
|
||||
tee fileFd fdIn = readTilEOF lineAction fdIn
|
||||
|
||||
where
|
||||
lineAction :: ByteString -> IO ()
|
||||
lineAction bs' = do
|
||||
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
|
||||
|
||||
-- Reads fdIn and logs the output in a continous scrolling area
|
||||
-- of 'size' terminal lines. Also writes to a log file.
|
||||
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
|
||||
printToRegion fileFd fdIn size pState = do
|
||||
void $ displayConsoleRegions $ do
|
||||
rs <-
|
||||
liftIO
|
||||
. fmap Sq.fromList
|
||||
. sequence
|
||||
. replicate size
|
||||
. openConsoleRegion
|
||||
$ Linear
|
||||
flip runStateT mempty
|
||||
$ handle
|
||||
(\(ex :: SomeException) -> do
|
||||
ps <- liftIO $ takeMVar pState
|
||||
when ps (forM_ rs (liftIO . closeConsoleRegion))
|
||||
throw ex
|
||||
)
|
||||
$ readTilEOF (lineAction rs) fdIn
|
||||
|
||||
where
|
||||
-- action to perform line by line
|
||||
-- TODO: do this with vty for efficiency
|
||||
lineAction :: (MonadMask m, MonadIO m)
|
||||
=> Seq ConsoleRegion
|
||||
-> ByteString
|
||||
-> StateT (Seq ByteString) m ()
|
||||
lineAction rs = \bs' -> do
|
||||
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||
modify (swapRegs bs')
|
||||
regs <- get
|
||||
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
|
||||
w <- consoleWidth
|
||||
return
|
||||
. T.pack
|
||||
. color Blue
|
||||
. T.unpack
|
||||
. decUTF8Safe
|
||||
. trim w
|
||||
. (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
|
||||
$ bs
|
||||
|
||||
swapRegs :: a -> Seq a -> Seq a
|
||||
swapRegs bs = \regs -> if
|
||||
| Sq.length regs < size -> regs |> bs
|
||||
| otherwise -> Sq.drop 1 regs |> bs
|
||||
|
||||
-- trim output line to terminal width
|
||||
trim :: Int -> ByteString -> ByteString
|
||||
trim w = \bs -> if
|
||||
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
|
||||
| otherwise -> bs
|
||||
|
||||
-- Consecutively read from Fd in 512 chunks until we hit
|
||||
-- newline or EOF.
|
||||
readLine :: MonadIO m
|
||||
=> Fd -- ^ input file descriptor
|
||||
-> ByteString -- ^ rest buffer (read across newline)
|
||||
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
|
||||
readLine fd = go
|
||||
where
|
||||
go inBs = do
|
||||
-- if buffer is not empty, process it first
|
||||
mbs <- if BS.length inBs == 0
|
||||
-- otherwise attempt read
|
||||
then liftIO
|
||||
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
|
||||
$ fmap Just
|
||||
$ SPIB.fdRead fd 512
|
||||
else pure $ Just inBs
|
||||
case mbs of
|
||||
Nothing -> pure ("", "", True)
|
||||
Just bs -> do
|
||||
-- split on newline
|
||||
let (line, rest) = BS.span (/= _lf) bs
|
||||
if
|
||||
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
|
||||
-- if rest is empty, then there was no newline, process further
|
||||
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
|
||||
|
||||
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
|
||||
readTilEOF ~action' fd' = go mempty
|
||||
where
|
||||
go bs' = do
|
||||
(bs, rest, eof) <- readLine fd' bs'
|
||||
if eof
|
||||
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
|
||||
else void (action' bs) >> go rest
|
||||
|
||||
|
||||
-- | Capture the stdout and stderr of the given action, which
|
||||
-- is run in a subprocess. Stdin is closed. You might want to
|
||||
-- 'race' this to make sure it terminates.
|
||||
captureOutStreams :: IO a
|
||||
-- ^ the action to execute in a subprocess
|
||||
-> IO CapturedProcess
|
||||
captureOutStreams action = do
|
||||
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
|
||||
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
|
||||
pid <- SPP.forkProcess $ do
|
||||
-- dup stdout
|
||||
void $ dupTo childStdoutWrite stdOutput
|
||||
closeFd childStdoutWrite
|
||||
closeFd parentStdoutRead
|
||||
|
||||
-- dup stderr
|
||||
void $ dupTo childStderrWrite stdError
|
||||
closeFd childStderrWrite
|
||||
closeFd parentStderrRead
|
||||
|
||||
-- execute the action
|
||||
a <- action
|
||||
void $ evaluate a
|
||||
|
||||
-- close everything we don't need
|
||||
closeFd childStdoutWrite
|
||||
closeFd childStderrWrite
|
||||
|
||||
-- start thread that writes the output
|
||||
refOut <- newIORef BL.empty
|
||||
refErr <- newIORef BL.empty
|
||||
done <- newEmptyMVar
|
||||
_ <-
|
||||
forkIO
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ flip EX.finally (putMVar done ())
|
||||
$ writeStds parentStdoutRead parentStderrRead refOut refErr
|
||||
|
||||
status <- SPP.getProcessStatus True True pid
|
||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
||||
|
||||
case status of
|
||||
-- readFd will take care of closing the fd
|
||||
Just (SPP.Exited es) -> do
|
||||
stdout' <- readIORef refOut
|
||||
stderr' <- readIORef refErr
|
||||
pure $ CapturedProcess { _exitCode = es
|
||||
, _stdOut = stdout'
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
|
||||
_ -> throwIO $ userError ("No such PID " ++ show pid)
|
||||
|
||||
where
|
||||
writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
|
||||
writeStds pout perr rout rerr = do
|
||||
doneOut <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip EX.finally (putMVar doneOut ())
|
||||
$ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout
|
||||
doneErr <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip EX.finally (putMVar doneErr ())
|
||||
$ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr
|
||||
takeMVar doneOut
|
||||
takeMVar doneErr
|
||||
|
||||
readTilEOF ~action' fd' = do
|
||||
bs <- SPIB.fdRead fd' 512
|
||||
void $ action' bs
|
||||
readTilEOF action' fd'
|
||||
|
||||
|
||||
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
|
||||
actionWithPipes a =
|
||||
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
|
||||
|
||||
cleanup :: [Fd] -> IO ()
|
||||
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
|
||||
|
||||
|
||||
|
||||
-- | Create a new regular file in write-only mode. The file must not exist.
|
||||
createRegularFileFd :: FileMode -> FilePath -> IO Fd
|
||||
createRegularFileFd fm dest =
|
||||
openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: String -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
exec exe args chdir env = do
|
||||
pid <- SPP.forkProcess $ do
|
||||
maybe (pure ()) changeWorkingDirectory chdir
|
||||
SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
|
||||
|
||||
fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid
|
||||
|
||||
|
||||
toProcessError :: FilePath
|
||||
-> [String]
|
||||
-> Maybe ProcessStatus
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args mps = case mps of
|
||||
Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
|
||||
Just (SPP.Exited ExitSuccess ) -> Right ()
|
||||
Just (Terminated _ _ ) -> Left $ PTerminated exe args
|
||||
Just (Stopped _ ) -> Left $ PStopped exe args
|
||||
Nothing -> Left $ NoSuchPid exe args
|
||||
|
||||
|
||||
|
||||
chmod_755 :: (MonadLogger m, 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) [i|chmod 755 #{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
|
||||
@@ -1,202 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Utils.File.Windows
|
||||
Description : File and windows APIs
|
||||
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
|
||||
|
||||
import GHCup.Utils.File.Common
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.DeepSeq
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Foreign.C.Error
|
||||
import GHC.IO.Exception
|
||||
import GHC.IO.Handle
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
import System.Process
|
||||
|
||||
import qualified Control.Exception as EX
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
|
||||
|
||||
|
||||
toProcessError :: FilePath
|
||||
-> [FilePath]
|
||||
-> ExitCode
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args exitcode = case exitcode of
|
||||
(ExitFailure xi) -> Left $ NonZeroExit xi exe args
|
||||
ExitSuccess -> Right ()
|
||||
|
||||
|
||||
-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it
|
||||
-- lets you pass 'CreateProcess' giving better flexibility.
|
||||
--
|
||||
-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
|
||||
-- record will be ignored.
|
||||
--
|
||||
-- @since 1.2.3.0
|
||||
readCreateProcessWithExitCodeBS
|
||||
:: CreateProcess
|
||||
-> BL.ByteString
|
||||
-> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr
|
||||
readCreateProcessWithExitCodeBS cp input = do
|
||||
let cp_opts = cp {
|
||||
std_in = CreatePipe,
|
||||
std_out = CreatePipe,
|
||||
std_err = CreatePipe
|
||||
}
|
||||
withCreateProcess_ "readCreateProcessWithExitCode" cp_opts $
|
||||
\mb_inh mb_outh mb_errh ph ->
|
||||
case (mb_inh, mb_outh, mb_errh) of
|
||||
(Just inh, Just outh, Just errh) -> do
|
||||
|
||||
out <- BS.hGetContents outh
|
||||
err <- BS.hGetContents errh
|
||||
|
||||
-- fork off threads to start consuming stdout & stderr
|
||||
withForkWait (EX.evaluate $ rnf out) $ \waitOut ->
|
||||
withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do
|
||||
|
||||
-- now write any input
|
||||
unless (BL.null input) $
|
||||
ignoreSigPipe $ BL.hPut inh input
|
||||
-- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
|
||||
ignoreSigPipe $ hClose inh
|
||||
|
||||
-- wait on the output
|
||||
waitOut
|
||||
waitErr
|
||||
|
||||
hClose outh
|
||||
hClose errh
|
||||
|
||||
-- wait on the process
|
||||
ex <- waitForProcess ph
|
||||
return (ex, BL.fromStrict out, BL.fromStrict err)
|
||||
|
||||
(Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."
|
||||
(_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."
|
||||
(_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."
|
||||
where
|
||||
ignoreSigPipe :: IO () -> IO ()
|
||||
ignoreSigPipe = EX.handle $ \e -> case e of
|
||||
IOError { ioe_type = ResourceVanished
|
||||
, ioe_errno = Just ioe }
|
||||
| Errno ioe == ePIPE -> return ()
|
||||
_ -> throwIO e
|
||||
-- wrapper so we can get exceptions with the appropriate function name.
|
||||
withCreateProcess_
|
||||
:: String
|
||||
-> CreateProcess
|
||||
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
|
||||
-> IO a
|
||||
withCreateProcess_ fun c action =
|
||||
EX.bracketOnError (createProcess_ fun c) cleanupProcess
|
||||
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
|
||||
|
||||
-- | Fork a thread while doing something else, but kill it if there's an
|
||||
-- exception.
|
||||
--
|
||||
-- This is important in the cases above because we want to kill the thread
|
||||
-- that is holding the Handle lock, because when we clean up the process we
|
||||
-- try to close that handle, which could otherwise deadlock.
|
||||
--
|
||||
withForkWait :: IO () -> (IO () -> IO a) -> IO a
|
||||
withForkWait async' body = do
|
||||
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
|
||||
mask $ \restore -> do
|
||||
tid <- forkIO $ try (restore async') >>= putMVar waitVar
|
||||
let wait' = takeMVar waitVar >>= either throwIO return
|
||||
restore (body wait') `EX.onException` killThread tid
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: FilePath -- ^ command as filename, e.g. 'ls'
|
||||
-> [String] -- ^ arguments to the command
|
||||
-> Maybe FilePath -- ^ chdir to this path
|
||||
-> IO CapturedProcess
|
||||
executeOut path args chdir = do
|
||||
(exit, out, err) <- readCreateProcessWithExitCodeBS (proc path args){ cwd = chdir } ""
|
||||
pure $ CapturedProcess exit out err
|
||||
|
||||
|
||||
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
|
||||
=> FilePath -- ^ thing to execute
|
||||
-> [String] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> FilePath -- ^ log filename (opened in append mode)
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe args chdir lfile env = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
|
||||
stderrLogfile = logsDir </> lfile <> ".stderr.log"
|
||||
fmap (toProcessError exe args)
|
||||
$ liftIO
|
||||
$ withCreateProcess
|
||||
(proc exe args){ cwd = chdir
|
||||
, env = env
|
||||
, std_in = CreatePipe
|
||||
, std_out = CreatePipe
|
||||
, std_err = CreatePipe
|
||||
}
|
||||
$ \_ mout merr ph ->
|
||||
case (mout, merr) of
|
||||
(Just cStdout, Just cStderr) -> do
|
||||
withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
|
||||
withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
|
||||
waitOut
|
||||
waitErr
|
||||
waitForProcess ph
|
||||
_ -> fail "Could not acquire out/err handle"
|
||||
|
||||
where
|
||||
tee :: FilePath -> Handle -> IO ()
|
||||
tee logFile handle' = go
|
||||
where
|
||||
go = do
|
||||
some <- BS.hGetSome handle' 512
|
||||
if BS.null some
|
||||
then pure ()
|
||||
else do
|
||||
void $ BS.appendFile logFile some
|
||||
void $ BS.hPut stdout some
|
||||
go
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: FilePath -- ^ thing to execute
|
||||
-> [FilePath] -- ^ args for the thing
|
||||
-> Maybe FilePath -- ^ optionally chdir into this
|
||||
-> Maybe [(String, String)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
exec exe args chdir env = do
|
||||
exit_code <- withCreateProcess
|
||||
(proc exe args) { cwd = chdir, env = env } $ \_ _ _ p ->
|
||||
waitForProcess p
|
||||
pure $ toProcessError exe args exit_code
|
||||
|
||||
|
||||
chmod_755 :: MonadIO m => FilePath -> m ()
|
||||
chmod_755 fp =
|
||||
let perm = setOwnerWritable True emptyPermissions
|
||||
in liftIO $ setPermissions fp perm
|
||||
@@ -8,13 +8,14 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
|
||||
Here we define our main logger.
|
||||
-}
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
@@ -22,15 +23,14 @@ import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Logger
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Console.Pretty
|
||||
import System.Directory hiding ( findFiles )
|
||||
import System.FilePath
|
||||
import System.IO.Error
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
|
||||
data LoggerConfig = LoggerConfig
|
||||
@@ -68,19 +68,20 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
|
||||
rawOutter outr
|
||||
|
||||
|
||||
initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m FilePath
|
||||
initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m (Path Abs)
|
||||
initGHCupFileLogging = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
let logfile = logsDir </> "ghcup.log"
|
||||
let logfile = logsDir </> [rel|ghcup.log|]
|
||||
liftIO $ do
|
||||
createDirectoryIfMissing True logsDir
|
||||
createDirRecursive' logsDir
|
||||
logFiles <- findFiles
|
||||
logsDir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^.*\.log$|] :: B.ByteString)
|
||||
)
|
||||
forM_ logFiles $ hideError doesNotExistErrorType . removeFile . (logsDir </>)
|
||||
forM_ logFiles $ hideError doesNotExistErrorType . deleteFile . (logsDir </>)
|
||||
|
||||
writeFile logfile ""
|
||||
createRegularFile newFilePerms logfile
|
||||
pure logfile
|
||||
|
||||
|
||||
@@ -8,7 +8,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Utils.MegaParsec where
|
||||
|
||||
@@ -23,7 +23,6 @@ import Data.Maybe
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Data.Void
|
||||
import System.FilePath
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
@@ -118,7 +117,3 @@ verP suffix = do
|
||||
v <- versioning'
|
||||
MP.setInput rest
|
||||
pure v
|
||||
|
||||
|
||||
pathSep :: MP.Parsec Void Text Char
|
||||
pathSep = MP.oneOf pathSeparators
|
||||
|
||||
@@ -12,7 +12,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
|
||||
GHCup specific prelude. Lots of Excepts functionality.
|
||||
-}
|
||||
@@ -32,6 +32,8 @@ import Data.Word8
|
||||
import Haskus.Utils.Types.List
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import System.IO.Error
|
||||
import System.Posix.Env.ByteString ( getEnvironment )
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Strict.Maybe as S
|
||||
@@ -240,8 +242,6 @@ throwEither' e eth = case eth of
|
||||
verToBS :: Version -> ByteString
|
||||
verToBS = E.encodeUtf8 . prettyVer
|
||||
|
||||
verToS :: Version -> String
|
||||
verToS = T.unpack . prettyVer
|
||||
|
||||
intToText :: Integral a => a -> T.Text
|
||||
intToText = TL.toStrict . B.toLazyText . B.decimal
|
||||
@@ -252,6 +252,14 @@ removeLensFieldLabel str' =
|
||||
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
|
||||
|
||||
|
||||
addToCurrentEnv :: MonadIO m
|
||||
=> [(ByteString, ByteString)]
|
||||
-> m [(ByteString, ByteString)]
|
||||
addToCurrentEnv adds = do
|
||||
cEnv <- liftIO getEnvironment
|
||||
pure (adds ++ cEnv)
|
||||
|
||||
|
||||
pvpToVersion :: PVP -> Version
|
||||
pvpToVersion =
|
||||
either (\_ -> error "Couldn't convert PVP to Version") id
|
||||
|
||||
@@ -7,7 +7,7 @@ Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufel
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
|
||||
QuasiQuoter for non-interpolated strings, texts and bytestrings.
|
||||
|
||||
|
||||
@@ -14,7 +14,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Utils.Version.QQ where
|
||||
|
||||
|
||||
@@ -8,7 +8,7 @@ Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
Portability : POSIX
|
||||
-}
|
||||
module GHCup.Version where
|
||||
|
||||
|
||||
26
stack.yaml
26
stack.yaml
@@ -1,4 +1,4 @@
|
||||
resolver: lts-17.11
|
||||
resolver: lts-17.4
|
||||
|
||||
packages:
|
||||
- .
|
||||
@@ -7,9 +7,6 @@ extra-deps:
|
||||
- git: https://github.com/hasufell/text-conversions.git
|
||||
commit: 9abf0e5e5664a3178367597c32db19880477a53c
|
||||
|
||||
- git: https://github.com/Bodigrim/tar
|
||||
commit: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
|
||||
|
||||
- IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
|
||||
- ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
|
||||
- brotli-0.0.0.0@sha256:2bf383a4cd308745740986be0b18381c5a0784393fe69b91456aacb2d603de46,2964
|
||||
@@ -20,18 +17,16 @@ extra-deps:
|
||||
- haskus-utils-data-1.3@sha256:f62c4e49021b463185d043f7b69c727b63af641a71d7edd582d9f4f98e80e500,1466
|
||||
- haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
|
||||
- haskus-utils-variant-3.0@sha256:8d51e45d3b664e61ccc25a58b37c0ccc4ee7537138b9fee21cd15c356906dd34,2159
|
||||
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
|
||||
- hpath-0.11.0@sha256:12b8405bee13d0007d644a888ef8407069ce7bbbd76970f8746b801447124ade,1440
|
||||
- hpath-directory-0.14.1@sha256:548ac1321222c34caa843a41a2379a77d961141082a4695bb37cc4731e91b2c7,5312
|
||||
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
|
||||
- hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
|
||||
- hspec-2.7.10@sha256:c9e82c90086acebac576552a06f3cabd249bba048edd1667c7fae0b1313d5bce,1712
|
||||
- hspec-core-2.7.10@sha256:2aba6ea126442b29e8183ab27f1c811706b19b1d83b02f193a896f6fc1589d13,4621
|
||||
- hspec-discover-2.7.10@sha256:d08bf5dd785629f589571477d9beb7cd91529471bd89f39517c1cb4b9b38160f,2184
|
||||
- hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
|
||||
- hpath-io-0.14.1@sha256:d91373cd81483eb370a1c683e4add6182250dccce32f9b682bb1104f7765c750,1522
|
||||
- hpath-posix-0.13.2@sha256:eec4ff2b00dc86be847aca0f409fc8f6212ffd2170ec36a17dc9a52b46562392,1615
|
||||
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
|
||||
- lzma-static-5.2.5.2@sha256:ac38dcad9ab423342a72ba48415bd75f62234e9c9e11831495b75603b5a060f6,7184
|
||||
- libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990
|
||||
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
|
||||
- primitive-0.7.0.1@sha256:a381571c36edc7dca28b77fe8159b43c14c640087ec5946adacf949feec64231,3433
|
||||
- regex-posix-clib-2.7
|
||||
- streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421
|
||||
- streamly-bytestring-0.1.2@sha256:cc828f41d1c714c711d38fb213b4ed186febabba598ab080e13255f69c20b13c,2469
|
||||
- streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138
|
||||
@@ -45,8 +40,13 @@ flags:
|
||||
libarchive:
|
||||
system-libarchive: false
|
||||
|
||||
regex-posix:
|
||||
_regex-posix-clib: true
|
||||
ghcup:
|
||||
tui: true
|
||||
internal-downloader: true
|
||||
|
||||
system-ghc: true
|
||||
compiler: ghc-8.10.4
|
||||
compiler-check: match-exact
|
||||
|
||||
ghc-options:
|
||||
"$locals": -O2
|
||||
|
||||
@@ -11,6 +11,7 @@ import GHCup.Types
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Versions
|
||||
import Data.List.NonEmpty
|
||||
import HPath
|
||||
import Test.QuickCheck
|
||||
import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary )
|
||||
import Test.QuickCheck.Arbitrary.Generic
|
||||
@@ -163,6 +164,11 @@ instance Arbitrary VersionCmp where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary (Path Rel) where
|
||||
arbitrary =
|
||||
either (error . show) id . parseRel . E.encodeUtf8 . T.pack
|
||||
<$> listOf1 (elements ['a' .. 'z'])
|
||||
|
||||
instance Arbitrary TarDir where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
Reference in New Issue
Block a user