Windows support
This commit is contained in:
parent
b94a4123eb
commit
2c3ebe706d
GPG Key ID:
3786C5262ECB4A3F
|
|
@ -41,6 +41,9 @@ apk add --no-cache \
|
|||
zlib \
|
||||
zlib-dev \
|
||||
zlib-static \
|
||||
bzip2 \
|
||||
bzip2-dev \
|
||||
bzip2-static \
|
||||
gmp \
|
||||
gmp-dev \
|
||||
openssl-dev \
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ 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 git wget
|
||||
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget
|
||||
|
||||
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > ./ghcup-bin
|
||||
chmod +x ghcup-bin
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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
|
||||
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 git wget
|
||||
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget
|
||||
|
|
|
|||
|
|
@ -7,11 +7,11 @@ set -eux
|
|||
mkdir -p "$CI_PROJECT_DIR"/.local/bin
|
||||
|
||||
ecabal() {
|
||||
cabal --store-dir="$(pwd)"/.store "$@"
|
||||
cabal --store-dir="$CI_PROJECT_DIR"/.store "$@"
|
||||
}
|
||||
|
||||
eghcup() {
|
||||
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
|
||||
ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
|
||||
}
|
||||
|
||||
git describe --always
|
||||
|
|
@ -116,8 +116,12 @@ fi
|
|||
eghcup rm $(ghc --numeric-version)
|
||||
|
||||
# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116
|
||||
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
|
||||
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 upgrade
|
||||
eghcup upgrade -f
|
||||
|
|
|
|||
|
|
@ -6,10 +6,6 @@
|
|||
|
||||
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.
|
||||
|
|
|
|||
|
|
@ -234,7 +234,7 @@ ghcup is not a reimplementation of stack. The only common part is automatic inst
|
|||
|
||||
2. Why not support windows?
|
||||
|
||||
Windows support is [WIP](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/130).
|
||||
We do.
|
||||
|
||||
3. Why the haskell reimplementation?
|
||||
|
||||
|
|
|
|||
|
|
@ -37,12 +37,11 @@ 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
|
||||
|
|
@ -106,6 +105,10 @@ 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
|
||||
|
|
@ -238,7 +241,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
|
|||
$ do
|
||||
case tool of
|
||||
Just GHCup -> do
|
||||
let fn = [rel|ghcup|]
|
||||
let fn = "ghcup"
|
||||
dir <- liftIO ghcupCacheDir
|
||||
p <- liftE $ download dli dir (Just fn)
|
||||
liftE $ checkDigest dli p
|
||||
|
|
@ -252,7 +255,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
|
|||
case r of
|
||||
VRight (Just basePath) -> do
|
||||
case _dlSubdir dli of
|
||||
Just (RealDir (toFilePath -> prel)) -> do
|
||||
Just (RealDir prel) -> do
|
||||
lift $ $(logInfo)
|
||||
[i|verifying subdir: #{prel}|]
|
||||
when (basePath /= prel) $ do
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ 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
|
||||
|
||||
|
|
@ -518,7 +519,8 @@ changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
|||
Darwin -> "open"
|
||||
Linux _ -> "xdg-open"
|
||||
FreeBSD -> "xdg-open"
|
||||
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
|
||||
Windows -> "start"
|
||||
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
|
||||
Right _ -> pure $ Right ()
|
||||
Left e -> pure $ Left $ prettyShow e
|
||||
|
||||
|
|
|
|||
|
|
@ -53,8 +53,6 @@ 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 )
|
||||
|
|
@ -64,6 +62,7 @@ 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 )
|
||||
|
|
@ -170,17 +169,17 @@ data CompileCommand = CompileGHC GHCCompileOptions
|
|||
|
||||
data GHCCompileOptions = GHCCompileOptions
|
||||
{ targetGhc :: Either Version GitBranch
|
||||
, bootstrapGhc :: Either Version (Path Abs)
|
||||
, bootstrapGhc :: Either Version FilePath
|
||||
, jobs :: Maybe Int
|
||||
, buildConfig :: Maybe (Path Abs)
|
||||
, patchDir :: Maybe (Path Abs)
|
||||
, buildConfig :: Maybe FilePath
|
||||
, patchDir :: Maybe FilePath
|
||||
, crossTarget :: Maybe Text
|
||||
, addConfArgs :: [Text]
|
||||
, setCompile :: Bool
|
||||
}
|
||||
|
||||
data UpgradeOpts = UpgradeInplace
|
||||
| UpgradeAt (Path Abs)
|
||||
| UpgradeAt FilePath
|
||||
| UpgradeGHCupDir
|
||||
deriving Show
|
||||
|
||||
|
|
@ -721,8 +720,7 @@ ghcCompileOpts =
|
|||
<*> option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
(bimap (const "Not a valid version") Left . version . T.pack $ x)
|
||||
<|> (bimap show Right . parseAbs . E.encodeUtf8 . T.pack $ 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")
|
||||
)
|
||||
)
|
||||
( short 'b'
|
||||
|
|
@ -740,26 +738,14 @@ ghcCompileOpts =
|
|||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
str
|
||||
(short 'c' <> long "config" <> metavar "CONFIG" <> help
|
||||
"Absolute path to build config file"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
str
|
||||
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
|
||||
"Absolute path to patch directory (applied in order, uses -p1)"
|
||||
)
|
||||
|
|
@ -1040,13 +1026,7 @@ upgradeOptsP =
|
|||
)
|
||||
<|> ( UpgradeAt
|
||||
<$> option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
str
|
||||
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
|
||||
"Absolute filepath to write ghcup into"
|
||||
)
|
||||
|
|
@ -1058,9 +1038,9 @@ upgradeOptsP =
|
|||
describe_result :: String
|
||||
describe_result = $( LitE . StringL <$>
|
||||
runIO (do
|
||||
CapturedProcess{..} <- executeOut [rel|git|] ["describe"] Nothing
|
||||
CapturedProcess{..} <- executeOut "git" ["describe"] Nothing
|
||||
case _exitCode of
|
||||
ExitSuccess -> pure . T.unpack . decUTF8Safe $ _stdOut
|
||||
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
|
||||
ExitFailure _ -> pure numericVer
|
||||
)
|
||||
)
|
||||
|
|
@ -1114,7 +1094,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = verbose settings
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = appendFile logfile
|
||||
, rawOutter = B.appendFile logfile
|
||||
}
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
|
||||
|
|
@ -1616,12 +1596,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||
|
||||
Upgrade uOpts force -> do
|
||||
target <- case uOpts of
|
||||
UpgradeInplace -> do
|
||||
efp <- liftIO getExecutablePath
|
||||
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
|
||||
pure $ Just p
|
||||
UpgradeInplace -> Just <$> liftIO getExecutablePath
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup"))
|
||||
|
||||
runUpgrade (liftE $ upgradeGHCup dls target force pfreq) >>= \case
|
||||
VRight v' -> do
|
||||
|
|
@ -1677,12 +1654,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||
Darwin -> "open"
|
||||
Linux _ -> "xdg-open"
|
||||
FreeBSD -> "xdg-open"
|
||||
Windows -> "start"
|
||||
|
||||
if clOpen
|
||||
then
|
||||
exec cmd
|
||||
True
|
||||
[serializeURIRef' uri]
|
||||
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
|
||||
Nothing
|
||||
Nothing
|
||||
>>= \case
|
||||
|
|
@ -1977,10 +1954,10 @@ checkForUpdates dls pfreq = do
|
|||
prettyDebugInfo :: DebugInfo -> String
|
||||
prettyDebugInfo DebugInfo {..} = [i|Debug Info
|
||||
==========
|
||||
GHCup base dir: #{toFilePath diBaseDir}
|
||||
GHCup bin dir: #{toFilePath diBinDir}
|
||||
GHCup GHC directory: #{toFilePath diGHCDir}
|
||||
GHCup cache directory: #{toFilePath diCacheDir}
|
||||
GHCup base dir: #{diBaseDir}
|
||||
GHCup bin dir: #{diBinDir}
|
||||
GHCup GHC directory: #{diGHCDir}
|
||||
GHCup cache directory: #{diCacheDir}
|
||||
Architecture: #{prettyShow diArch}
|
||||
Platform: #{prettyShow diPlatform}
|
||||
Version: #{describe_result}|]
|
||||
|
|
|
|||
|
|
@ -10,6 +10,11 @@ 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
|
||||
|
|
|
|||
150
ghcup-0.0.4.yaml
150
ghcup-0.0.4.yaml
|
|
@ -170,6 +170,11 @@ 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
|
||||
|
|
@ -236,6 +241,11 @@ 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 )':
|
||||
|
|
@ -300,6 +310,11 @@ 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 )':
|
||||
|
|
@ -359,6 +374,11 @@ 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
|
||||
|
|
@ -414,6 +434,11 @@ 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
|
||||
|
|
@ -464,6 +489,11 @@ 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
|
||||
|
|
@ -532,6 +562,11 @@ 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
|
||||
|
|
@ -592,6 +627,11 @@ 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
|
||||
|
|
@ -638,6 +678,11 @@ 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
|
||||
|
|
@ -702,6 +747,11 @@ 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
|
||||
|
|
@ -752,6 +802,11 @@ 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
|
||||
|
|
@ -820,6 +875,11 @@ 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
|
||||
|
|
@ -890,6 +950,11 @@ 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
|
||||
|
|
@ -949,6 +1014,11 @@ 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
|
||||
|
|
@ -1013,6 +1083,11 @@ 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
|
||||
|
|
@ -1087,6 +1162,11 @@ 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
|
||||
|
|
@ -1164,6 +1244,11 @@ 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
|
||||
|
|
@ -1254,6 +1339,11 @@ 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
|
||||
|
|
@ -1343,6 +1433,11 @@ 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
|
||||
|
|
@ -1434,6 +1529,11 @@ 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
|
||||
|
|
@ -1524,6 +1624,11 @@ 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
|
||||
|
|
@ -1614,6 +1719,11 @@ 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
|
||||
|
|
@ -1666,6 +1776,11 @@ 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:
|
||||
|
|
@ -1694,6 +1809,11 @@ 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:
|
||||
|
|
@ -1725,6 +1845,11 @@ 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:
|
||||
|
|
@ -1759,6 +1884,11 @@ 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
|
||||
|
|
@ -1797,6 +1927,10 @@ 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:
|
||||
|
|
@ -1833,6 +1967,10 @@ 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:
|
||||
|
|
@ -1853,6 +1991,12 @@ ghcupDownloads:
|
|||
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:
|
||||
|
|
@ -1874,6 +2018,12 @@ ghcupDownloads:
|
|||
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
|
||||
|
||||
|
|
|
|||
71
ghcup.cabal
71
ghcup.cabal
|
|
@ -28,19 +28,23 @@ source-repository head
|
|||
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
|
||||
|
||||
flag tui
|
||||
description: Build the brick powered tui (ghcup tui)
|
||||
description:
|
||||
Build the brick powered tui (ghcup tui). This is disabled on windows.
|
||||
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
flag internal-downloader
|
||||
description:
|
||||
Compile the internal downloader, which links against OpenSSL
|
||||
Compile the internal downloader, which links against OpenSSL. This is disabled on windows.
|
||||
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
flag tar
|
||||
description: Use tar-bytestring instead of libarchive
|
||||
description:
|
||||
Use tar-bytestring instead of libarchive. This is always enabled on windows.
|
||||
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
|
|
@ -58,6 +62,7 @@ library
|
|||
GHCup.Utils
|
||||
GHCup.Utils.Dirs
|
||||
GHCup.Utils.File
|
||||
GHCup.Utils.File.Common
|
||||
GHCup.Utils.Logger
|
||||
GHCup.Utils.MegaParsec
|
||||
GHCup.Utils.Prelude
|
||||
|
|
@ -90,21 +95,19 @@ library
|
|||
, 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
|
||||
|
|
@ -115,6 +118,7 @@ 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
|
||||
|
|
@ -122,27 +126,25 @@ 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)
|
||||
if (flag(internal-downloader) && !os(windows))
|
||||
exposed-modules: GHCup.Download.IOStreams
|
||||
cpp-options: -DINTERNAL_DOWNLOADER
|
||||
build-depends:
|
||||
|
|
@ -151,13 +153,31 @@ library
|
|||
, io-streams >=1.5
|
||||
, terminal-progress-bar >=0.4.1
|
||||
|
||||
if flag(tar)
|
||||
if (flag(tar) || os(windows))
|
||||
cpp-options: -DTAR
|
||||
build-depends: tar-bytestring ^>=0.6.3.1
|
||||
build-depends: tar
|
||||
|
||||
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
|
||||
|
|
@ -181,10 +201,9 @@ 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
|
||||
|
|
@ -204,7 +223,7 @@ executable ghcup
|
|||
if flag(internal-downloader)
|
||||
cpp-options: -DINTERNAL_DOWNLOADER
|
||||
|
||||
if flag(tui)
|
||||
if (flag(tui) && !os(windows))
|
||||
cpp-options: -DBRICK
|
||||
other-modules: BrickMain
|
||||
build-depends:
|
||||
|
|
@ -212,7 +231,7 @@ executable ghcup
|
|||
, vector ^>=0.12
|
||||
, vty >=5.28.2 && <5.34
|
||||
|
||||
if flag(tar)
|
||||
if (flag(tar) || os(windows))
|
||||
cpp-options: -DTAR
|
||||
|
||||
else
|
||||
|
|
@ -241,10 +260,9 @@ 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
|
||||
|
|
@ -262,9 +280,9 @@ executable ghcup-gen
|
|||
, versions ^>=4.0.1
|
||||
, yaml ^>=0.11.4.0
|
||||
|
||||
if flag(tar)
|
||||
if (flag(tar) || os(windows))
|
||||
cpp-options: -DTAR
|
||||
build-depends: tar-bytestring ^>=0.6.3.1
|
||||
build-depends: tar
|
||||
|
||||
else
|
||||
build-depends: libarchive ^>=3.0.0.0
|
||||
|
|
@ -297,9 +315,8 @@ test-suite ghcup-test
|
|||
, containers ^>=0.6
|
||||
, generic-arbitrary ^>=0.1.0
|
||||
, ghcup
|
||||
, hpath >=0.11 && <0.13
|
||||
, hspec ^>=2.7.4
|
||||
, hspec-golden-aeson >=0.7 && <0.10
|
||||
, hspec ^>=2.7.10
|
||||
, hspec-golden-aeson >=0.9 && <0.10
|
||||
, QuickCheck ^>=2.14.1
|
||||
, quickcheck-arbitrary-adt ^>=0.3.1.0
|
||||
, text ^>=1.2.4.0
|
||||
|
|
|
|||
317
lib/GHCup.hs
317
lib/GHCup.hs
|
|
@ -18,7 +18,7 @@ Copyright : (c) Julian Ospald, 2020
|
|||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
Portability : portable
|
||||
|
||||
This module contains the main functions that correspond
|
||||
to the command line interface, like installation, listing versions
|
||||
|
|
@ -58,6 +58,7 @@ 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
|
||||
|
|
@ -65,10 +66,7 @@ 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
|
||||
|
|
@ -76,10 +74,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
|
||||
|
||||
|
|
@ -149,7 +147,7 @@ installGHCBindist dlinfo ver pfreq = do
|
|||
|
||||
where
|
||||
toolchainSanityChecks = do
|
||||
r <- forM ["CC", "LD"] (liftIO . getEnv)
|
||||
r <- forM ["CC", "LD"] (liftIO . lookupEnv)
|
||||
case catMaybes r of
|
||||
[] -> pure ()
|
||||
_ -> do
|
||||
|
|
@ -168,9 +166,9 @@ installPackedGHC :: ( MonadMask m
|
|||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Path Abs -- ^ Path to the packed GHC bindist
|
||||
=> FilePath -- ^ Path to the packed GHC bindist
|
||||
-> Maybe TarDir -- ^ Subdir of the archive
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Version -- ^ The GHC version
|
||||
-> PlatformRequest
|
||||
-> Excepts
|
||||
|
|
@ -204,18 +202,24 @@ installUnpackedGHC :: ( MonadReader AppState m
|
|||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||
-> FilePath -- ^ 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 "./configure"
|
||||
False
|
||||
(("--prefix=" <> toFilePath inst) : alpineArgs)
|
||||
[rel|ghc-configure|]
|
||||
lEM $ execLogged "sh"
|
||||
("./configure" : ("--prefix=" <> inst) : alpineArgs)
|
||||
(Just path)
|
||||
"ghc-configure"
|
||||
Nothing
|
||||
lEM $ make ["install"] (Just path)
|
||||
pure ()
|
||||
|
|
@ -225,6 +229,7 @@ installUnpackedGHC path inst ver PlatformRequest{..} = do
|
|||
= ["--disable-ld-override"]
|
||||
| otherwise
|
||||
= []
|
||||
#endif
|
||||
|
||||
|
||||
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
|
||||
|
|
@ -301,9 +306,9 @@ installCabalBindist dlinfo ver PlatformRequest {..} = do
|
|||
whenM
|
||||
(lift (cabalInstalled ver) >>= \a -> liftIO $
|
||||
handleIO (\_ -> pure False)
|
||||
$ fmap (\x -> a && isSymbolicLink x)
|
||||
$ fmap (\x -> a && x)
|
||||
-- ignore when the installation is a legacy cabal (binary, not symlink)
|
||||
$ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
|
||||
$ pathIsSymbolicLink (binDir </> "cabal" <> exeExt)
|
||||
)
|
||||
(throwE $ AlreadyInstalled Cabal ver)
|
||||
|
||||
|
|
@ -328,19 +333,18 @@ installCabalBindist dlinfo ver PlatformRequest {..} = do
|
|||
where
|
||||
-- | Install an unpacked cabal distribution.
|
||||
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installCabal' path inst = do
|
||||
lift $ $(logInfo) "Installing cabal"
|
||||
let cabalFile = [rel|cabal|]
|
||||
let cabalFile = "cabal"
|
||||
liftIO $ createDirRecursive' inst
|
||||
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
|
||||
let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let destPath = inst </> destFileName
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile)
|
||||
(path </> cabalFile <> exeExt)
|
||||
destPath
|
||||
Overwrite
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
|
||||
|
|
@ -437,8 +441,8 @@ installHLSBindist dlinfo ver PlatformRequest{..} = do
|
|||
where
|
||||
-- | Install an unpacked hls distribution.
|
||||
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installHLS' path inst = do
|
||||
lift $ $(logInfo) "Installing HLS"
|
||||
|
|
@ -452,20 +456,19 @@ installHLSBindist dlinfo ver PlatformRequest{..} = do
|
|||
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
|
||||
)
|
||||
forM_ bins $ \f -> do
|
||||
toF <- parseRel (toFilePath f <> "~" <> verToBS ver)
|
||||
let toF = dropSuffix exeExt f
|
||||
<> "~" <> T.unpack (prettyVer ver) <> exeExt
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> f)
|
||||
(inst </> toF)
|
||||
Overwrite
|
||||
lift $ chmod_755 (inst </> toF)
|
||||
|
||||
-- install haskell-language-server-wrapper
|
||||
let wrapper = [rel|haskell-language-server-wrapper|]
|
||||
toF <- parseRel (toFilePath wrapper <> "-" <> verToBS ver)
|
||||
let wrapper = "haskell-language-server-wrapper"
|
||||
toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> wrapper)
|
||||
(path </> wrapper <> exeExt)
|
||||
(inst </> toF)
|
||||
Overwrite
|
||||
lift $ chmod_755 (inst </> toF)
|
||||
|
||||
|
||||
|
|
@ -596,19 +599,18 @@ installStackBindist dlinfo ver PlatformRequest {..} = do
|
|||
where
|
||||
-- | Install an unpacked stack distribution.
|
||||
installStack' :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked stack bindist (where the executable resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
=> 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 = [rel|stack|]
|
||||
let stackFile = "stack"
|
||||
liftIO $ createDirRecursive' inst
|
||||
destFileName <- lift $ parseRel (toFilePath stackFile <> "-" <> verToBS ver)
|
||||
let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let destPath = inst </> destFileName
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> stackFile)
|
||||
(path </> stackFile <> exeExt)
|
||||
destPath
|
||||
Overwrite
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
|
||||
|
|
@ -640,7 +642,7 @@ setGHC :: ( MonadReader AppState m
|
|||
-> SetGHC
|
||||
-> Excepts '[NotInstalled] m GHCTargetVersion
|
||||
setGHC ver sghc = do
|
||||
let verBS = verToBS (_tvVersion ver)
|
||||
let verS = T.unpack $ prettyVer (_tvVersion ver)
|
||||
ghcdir <- lift $ ghcupGHCDir ver
|
||||
|
||||
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
|
||||
|
|
@ -662,49 +664,50 @@ setGHC ver sghc = do
|
|||
mTargetFile <- case sghc of
|
||||
SetGHCOnly -> pure $ Just file
|
||||
SetGHC_XY -> do
|
||||
v' <-
|
||||
handle
|
||||
handle
|
||||
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
|
||||
$ 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')
|
||||
$ do
|
||||
(mj, mi) <- getMajorMinorV (_tvVersion ver)
|
||||
let major' = intToText mj <> "." <> intToText mi
|
||||
pure $ Just (file <> "-" <> T.unpack major')
|
||||
SetGHC_XYZ ->
|
||||
fmap Just $ parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
pure $ Just (file <> "-" <> verS)
|
||||
|
||||
-- create symlink
|
||||
forM mTargetFile $ \targetFile -> do
|
||||
let fullF = binDir </> targetFile
|
||||
destL <- lift $ ghcLinkDestination (toFilePath file) ver
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
|
||||
liftIO $ createSymlink fullF destL
|
||||
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
|
||||
|
||||
-- create symlink for share dir
|
||||
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS
|
||||
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
|
||||
|
||||
pure ver
|
||||
|
||||
where
|
||||
|
||||
symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m)
|
||||
=> Path Abs
|
||||
-> ByteString
|
||||
=> FilePath
|
||||
-> String
|
||||
-> m ()
|
||||
symlinkShareDir ghcdir verBS = do
|
||||
symlinkShareDir ghcdir ver' = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
let destdir = baseDir
|
||||
case sghc of
|
||||
SetGHCOnly -> do
|
||||
let sharedir = [rel|share|]
|
||||
let sharedir = "share"
|
||||
let fullsharedir = ghcdir </> sharedir
|
||||
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
|
||||
let fullF = destdir </> sharedir
|
||||
let targetF = "./ghc/" <> verBS <> "/" <> toFilePath sharedir
|
||||
let targetF = "." </> "ghc" </> ver' </> sharedir
|
||||
$(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
|
||||
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
|
||||
liftIO $ createSymlink fullF targetF
|
||||
liftIO $ createDirectoryLink targetF fullF
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
|
|
@ -714,8 +717,7 @@ setCabal :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, M
|
|||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setCabal ver = do
|
||||
let verBS = verToBS ver
|
||||
targetFile <- parseRel ("cabal-" <> verBS)
|
||||
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
|
||||
-- symlink destination
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
|
@ -725,17 +727,17 @@ setCabal ver = do
|
|||
$ throwE
|
||||
$ NotInstalled Cabal (GHCTargetVersion Nothing ver)
|
||||
|
||||
let cabalbin = binDir </> [rel|cabal|]
|
||||
let cabalbin = binDir </> "cabal" <> exeExt
|
||||
|
||||
-- delete old file (may be binary or symlink)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile
|
||||
lift $ $(logDebug) [i|rm -f #{cabalbin}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile
|
||||
cabalbin
|
||||
|
||||
-- create symlink
|
||||
let destL = toFilePath targetFile
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath cabalbin}|]
|
||||
liftIO $ createSymlink cabalbin destL
|
||||
let destL = targetFile
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{cabalbin}|]
|
||||
liftIO $ createFileLink destL cabalbin
|
||||
|
||||
pure ()
|
||||
|
||||
|
|
@ -760,32 +762,32 @@ 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 #{toFilePath (binDir </> f)}|]
|
||||
liftIO $ deleteFile (binDir </> f)
|
||||
lift $ $(logDebug) [i|rm #{binDir </> f}|]
|
||||
liftIO $ removeFile (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 = toFilePath f
|
||||
target <- parseRel . head . B.split _tilde . toFilePath $ f
|
||||
let destL = f
|
||||
let target = (<> exeExt) . head . splitOn "~" $ f
|
||||
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath (binDir </> target)}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> target)
|
||||
lift $ $(logDebug) [i|rm -f #{binDir </> target}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> target)
|
||||
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath (binDir </> target)}|]
|
||||
liftIO $ createSymlink (binDir </> target) destL
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{binDir </> target}|]
|
||||
liftIO $ createFileLink destL (binDir </> target)
|
||||
|
||||
-- set haskell-language-server-wrapper symlink
|
||||
let destL = "haskell-language-server-wrapper-" <> verToBS ver
|
||||
let wrapper = binDir </> [rel|haskell-language-server-wrapper|]
|
||||
let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
|
||||
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath wrapper}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile wrapper
|
||||
lift $ $(logDebug) [i|rm -f #{wrapper}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile wrapper
|
||||
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath wrapper}|]
|
||||
liftIO $ createSymlink wrapper destL
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{wrapper}|]
|
||||
liftIO $ createFileLink destL wrapper
|
||||
|
||||
pure ()
|
||||
|
||||
|
|
@ -795,8 +797,7 @@ setStack :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, M
|
|||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setStack ver = do
|
||||
let verBS = verToBS ver
|
||||
targetFile <- parseRel ("stack-" <> verBS)
|
||||
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
|
||||
-- symlink destination
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
|
@ -806,17 +807,16 @@ setStack ver = do
|
|||
$ throwE
|
||||
$ NotInstalled Stack (GHCTargetVersion Nothing ver)
|
||||
|
||||
let stackbin = binDir </> [rel|stack|]
|
||||
let stackbin = binDir </> "stack" <> exeExt
|
||||
|
||||
-- delete old file (may be binary or symlink)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath stackbin}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile
|
||||
lift $ $(logDebug) [i|rm -f #{stackbin}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile
|
||||
stackbin
|
||||
|
||||
-- create symlink
|
||||
let destL = toFilePath targetFile
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath stackbin}|]
|
||||
liftIO $ createSymlink stackbin destL
|
||||
lift $ $(logDebug) [i|ln -s #{targetFile} #{stackbin}|]
|
||||
liftIO $ createFileLink targetFile stackbin
|
||||
|
||||
pure ()
|
||||
|
||||
|
|
@ -948,13 +948,13 @@ listVersions av lt' criteria pfreq = do
|
|||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
[i|Could not parse version of stray directory #{toFilePath e}|]
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
pure Nothing
|
||||
|
||||
strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
=> Map.Map Version [Tag]
|
||||
-> Maybe Version
|
||||
-> [Either (Path Rel) Version]
|
||||
-> [Either FilePath Version]
|
||||
-> m [ListResult]
|
||||
strayCabals avTools cSet cabals = do
|
||||
fmap catMaybes $ forM cabals $ \case
|
||||
|
|
@ -977,7 +977,7 @@ listVersions av lt' criteria pfreq = do
|
|||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
[i|Could not parse version of stray directory #{toFilePath e}|]
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
pure Nothing
|
||||
|
||||
strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
|
|
@ -1005,7 +1005,7 @@ listVersions av lt' criteria pfreq = do
|
|||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
[i|Could not parse version of stray directory #{toFilePath e}|]
|
||||
[i|Could not parse version of stray directory #{e}|]
|
||||
pure Nothing
|
||||
|
||||
strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
|
||||
|
|
@ -1033,18 +1033,18 @@ listVersions av lt' criteria pfreq = do
|
|||
}
|
||||
Left e -> do
|
||||
$(logWarn)
|
||||
[i|Could not parse version of stray directory #{toFilePath e}|]
|
||||
[i|Could not parse version of stray directory #{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 (Path Rel) Version]
|
||||
-> [Either FilePath Version]
|
||||
-> Maybe Version
|
||||
-> [Either (Path Rel) Version]
|
||||
-> [Either FilePath Version]
|
||||
-> Maybe Version
|
||||
-> [Either (Path Rel) Version]
|
||||
-> [Either FilePath Version]
|
||||
-> (Version, [Tag])
|
||||
-> m ListResult
|
||||
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = case t of
|
||||
|
|
@ -1156,8 +1156,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: #{toFilePath dir}|]
|
||||
liftIO $ deleteDirRecursive dir
|
||||
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
|
||||
liftIO $ removeDirectoryRecursive dir
|
||||
|
||||
v' <-
|
||||
handle
|
||||
|
|
@ -1171,7 +1171,7 @@ rmGHCVer ver = do
|
|||
|
||||
liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
$ deleteFile (baseDir </> [rel|share|])
|
||||
$ removeFile (baseDir </> "share")
|
||||
|
||||
|
||||
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
||||
|
|
@ -1186,15 +1186,15 @@ rmCabalVer ver = do
|
|||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
|
||||
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile (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 $ deleteFile
|
||||
(binDir </> [rel|cabal|])
|
||||
Nothing -> liftIO $ hideError doesNotExistErrorType $ removeFile
|
||||
(binDir </> "cabal" <> exeExt)
|
||||
|
||||
|
||||
-- | Delete a hls version. Will try to fix the hls symlinks
|
||||
|
|
@ -1210,14 +1210,15 @@ rmHLSVer ver = do
|
|||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
bins <- lift $ hlsAllBinaries ver
|
||||
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
|
||||
forM_ bins $ \f -> liftIO $ removeFile (binDir </> f)
|
||||
|
||||
when (Just ver == isHlsSet) $ do
|
||||
-- delete all set symlinks
|
||||
oldSyms <- lift hlsSymlinks
|
||||
forM_ oldSyms $ \f -> do
|
||||
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
|
||||
liftIO $ deleteFile (binDir </> f)
|
||||
let fullF = binDir </> f <> exeExt
|
||||
lift $ $(logDebug) [i|rm #{fullF}|]
|
||||
liftIO $ removeFile fullF
|
||||
-- set latest hls
|
||||
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||
case headMay . reverse . sort $ hlsVers of
|
||||
|
|
@ -1237,15 +1238,15 @@ rmStackVer ver = do
|
|||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
stackFile <- lift $ parseRel ("stack-" <> verToBS ver)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> stackFile)
|
||||
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 $ deleteFile
|
||||
(binDir </> [rel|stack|])
|
||||
Nothing -> liftIO $ hideError doesNotExistErrorType $ removeFile
|
||||
(binDir </> "stack" <> exeExt)
|
||||
|
||||
|
||||
|
||||
|
|
@ -1290,10 +1291,10 @@ compileGHC :: ( MonadMask m
|
|||
)
|
||||
=> GHCupDownloads
|
||||
-> Either GHCTargetVersion GitBranch -- ^ version to install
|
||||
-> Either Version (Path Abs) -- ^ version to bootstrap with
|
||||
-> Either Version FilePath -- ^ version to bootstrap with
|
||||
-> Maybe Int -- ^ jobs
|
||||
-> Maybe (Path Abs) -- ^ build config
|
||||
-> Maybe (Path Abs) -- ^ patch directory
|
||||
-> Maybe FilePath -- ^ build config
|
||||
-> Maybe FilePath -- ^ patch directory
|
||||
-> [Text] -- ^ additional args to ./configure
|
||||
-> PlatformRequest
|
||||
-> Excepts
|
||||
|
|
@ -1341,7 +1342,7 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
|
|||
-- clone from git
|
||||
Right GitBranch{..} -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing
|
||||
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
|
||||
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)|]
|
||||
|
|
@ -1362,13 +1363,13 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
|
|||
|
||||
lEM $ git [ "checkout", "FETCH_HEAD" ]
|
||||
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
|
||||
lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing
|
||||
lEM $ execLogged "./configure" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing
|
||||
lEM $ execLogged "sh" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" Nothing
|
||||
lEM $ execLogged "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" Nothing
|
||||
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}|]
|
||||
|
|
@ -1387,14 +1388,14 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
|
|||
|
||||
bghc <- case bstrap of
|
||||
Right g -> pure $ Right g
|
||||
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
|
||||
Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver))
|
||||
|
||||
(bindist, bmk) <- liftE $ runBuildAction
|
||||
tmpUnpack
|
||||
Nothing
|
||||
(do
|
||||
b <- compileBindist bghc tver workdir
|
||||
bmk <- liftIO $ readFileStrict (build_mk workdir)
|
||||
bmk <- liftIO $ B.readFile (build_mk workdir)
|
||||
pure (b, bmk)
|
||||
)
|
||||
|
||||
|
|
@ -1407,7 +1408,7 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
|
|||
(tver ^. tvVersion)
|
||||
pfreq
|
||||
|
||||
liftIO $ writeFile (ghcdir </> ghcUpSrcBuiltFile) (Just newFilePerms) bmk
|
||||
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
|
||||
|
||||
reThrowAll GHCupSetError $ postGHCInstall tver
|
||||
|
||||
|
|
@ -1439,13 +1440,13 @@ HADDOCK_DOCS = YES|]
|
|||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Either (Path Rel) (Path Abs)
|
||||
=> Either FilePath FilePath
|
||||
-> GHCTargetVersion
|
||||
-> Path Abs
|
||||
-> FilePath
|
||||
-> Excepts
|
||||
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
|
||||
m
|
||||
(Path Abs) -- ^ output path of bindist
|
||||
FilePath -- ^ output path of bindist
|
||||
compileBindist bghc tver workdir = do
|
||||
lift $ $(logInfo) [i|configuring build|]
|
||||
liftE checkBuildConfig
|
||||
|
|
@ -1460,41 +1461,39 @@ HADDOCK_DOCS = YES|]
|
|||
bghcPath <- case bghc of
|
||||
Right ghc' -> pure ghc'
|
||||
Left bver -> do
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
spaths <- liftIO getSearchPath
|
||||
liftIO (searchPath spaths bver) !? NotFoundInPATH bver
|
||||
lEM $ execLogged
|
||||
"./configure"
|
||||
False
|
||||
( maybe mempty
|
||||
(\x -> ["--target=" <> E.encodeUtf8 x])
|
||||
"sh"
|
||||
("./configure" : maybe mempty
|
||||
(\x -> ["--target=" <> T.unpack x])
|
||||
(_tvTarget tver)
|
||||
++ fmap E.encodeUtf8 aargs
|
||||
++ fmap T.unpack aargs
|
||||
)
|
||||
[rel|ghc-conf|]
|
||||
(Just workdir)
|
||||
(Just (("GHC", toFilePath bghcPath) : cEnv))
|
||||
"ghc-conf"
|
||||
(Just (("GHC", bghcPath) : cEnv))
|
||||
| otherwise -> do
|
||||
lEM $ execLogged
|
||||
"./configure"
|
||||
False
|
||||
( [ "--with-ghc=" <> either toFilePath toFilePath bghc
|
||||
"sh"
|
||||
( [ "./configure", "--with-ghc=" <> either id id bghc
|
||||
]
|
||||
++ maybe mempty
|
||||
(\x -> ["--target=" <> E.encodeUtf8 x])
|
||||
(\x -> ["--target=" <> T.unpack x])
|
||||
(_tvTarget tver)
|
||||
++ fmap E.encodeUtf8 aargs
|
||||
++ fmap T.unpack aargs
|
||||
)
|
||||
[rel|ghc-conf|]
|
||||
(Just workdir)
|
||||
"ghc-conf"
|
||||
(Just cEnv)
|
||||
|
||||
case mbuildConfig of
|
||||
Just bc -> liftIOException
|
||||
doesNotExistErrorType
|
||||
(FileDoesNotExistError $ toFilePath bc)
|
||||
(liftIO $ copyFile bc (build_mk workdir) Overwrite)
|
||||
(FileDoesNotExistError bc)
|
||||
(liftIO $ copyFile bc (build_mk workdir))
|
||||
Nothing ->
|
||||
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
|
||||
liftIO $ B.writeFile (build_mk workdir) defaultConf
|
||||
|
||||
lift $ $(logInfo) [i|Building (this may take a while)...|]
|
||||
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
|
||||
|
|
@ -1507,7 +1506,7 @@ HADDOCK_DOCS = YES|]
|
|||
execBlank
|
||||
([s|^ghc-.*\.tar\..*$|] :: ByteString)
|
||||
)
|
||||
c <- liftIO $ readFile (workdir </> tar)
|
||||
c <- liftIO $ BL.readFile (workdir </> tar)
|
||||
cDigest <-
|
||||
fmap (T.take 8)
|
||||
. lift
|
||||
|
|
@ -1517,17 +1516,14 @@ HADDOCK_DOCS = YES|]
|
|||
. SHA256.hashlazy
|
||||
$ c
|
||||
cTime <- liftIO getCurrentTime
|
||||
tarName <-
|
||||
parseRel
|
||||
[i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension (toFilePath tar)}|]
|
||||
let tarName = [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension 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 </> [rel|mk/build.mk|]
|
||||
build_mk workdir = workdir </> "mk" </> "build.mk"
|
||||
|
||||
checkBuildConfig :: (MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
|
|
@ -1537,10 +1533,10 @@ HADDOCK_DOCS = YES|]
|
|||
checkBuildConfig = do
|
||||
c <- case mbuildConfig of
|
||||
Just bc -> do
|
||||
BL.toStrict <$> liftIOException
|
||||
liftIOException
|
||||
doesNotExistErrorType
|
||||
(FileDoesNotExistError $ toFilePath bc)
|
||||
(liftIO $ readFile bc)
|
||||
(FileDoesNotExistError bc)
|
||||
(liftIO $ B.readFile bc)
|
||||
Nothing -> pure defaultConf
|
||||
let lines' = fmap T.strip . T.lines $ decUTF8Safe c
|
||||
|
||||
|
|
@ -1572,7 +1568,7 @@ upgradeGHCup :: ( MonadMask m
|
|||
, MonadUnliftIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
|
||||
-> Maybe FilePath -- ^ full file destination to write ghcup into
|
||||
-> Bool -- ^ whether to force update regardless
|
||||
-- of currently installed version
|
||||
-> PlatformRequest
|
||||
|
|
@ -1592,25 +1588,24 @@ 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 = [rel|ghcup|]
|
||||
let fn = "ghcup" <> exeExt
|
||||
p <- liftE $ download dli tmp (Just fn)
|
||||
let destDir = dirname destFile
|
||||
let destDir = takeDirectory destFile
|
||||
destFile = fromMaybe (binDir </> fn) mtarget
|
||||
lift $ $(logDebug) [i|mkdir -p #{toFilePath destDir}|]
|
||||
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
|
||||
liftIO $ createDirRecursive' destDir
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath destFile}|]
|
||||
liftIO $ hideError NoSuchThing $ deleteFile destFile
|
||||
lift $ $(logDebug) [i|cp #{toFilePath p} #{toFilePath destFile}|]
|
||||
lift $ $(logDebug) [i|rm -f #{destFile}|]
|
||||
liftIO $ hideError NoSuchThing $ removeFile destFile
|
||||
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||
destFile
|
||||
Overwrite
|
||||
lift $ chmod_755 destFile
|
||||
|
||||
liftIO (isInPath destFile) >>= \b -> unless b $
|
||||
lift $ $(logWarn) [i|"#{toFilePath (dirname destFile)}" is not in PATH! You have to add it in order to use ghcup.|]
|
||||
lift $ $(logWarn) [i|"#{takeFileName 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 "#{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.|]
|
||||
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.|]
|
||||
|
||||
pure latestVer
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ Copyright : (c) Julian Ospald, 2020
|
|||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
Portability : portable
|
||||
|
||||
Module for handling all download related functions.
|
||||
|
||||
|
|
@ -53,11 +53,11 @@ import Control.Monad.Trans.Resource
|
|||
hiding ( throwM )
|
||||
import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.CaseInsensitive ( CI )
|
||||
#endif
|
||||
import Data.List ( find )
|
||||
import Data.List.Extra
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Time.Clock
|
||||
|
|
@ -66,34 +66,29 @@ 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
|
||||
import qualified Data.Text as T
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
|
@ -158,12 +153,12 @@ readFromCache = do
|
|||
lift $ $(logWarn)
|
||||
[i|Could not get download info, trying cached version (this may not be recent!)|]
|
||||
let path = view pathL' ghcupURL
|
||||
yaml_file <- (cacheDir </>) <$> urlBaseName path
|
||||
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
|
||||
bs <-
|
||||
handleIO' NoSuchThing
|
||||
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
|
||||
(\_ -> throwE $ FileDoesNotExistError yaml_file)
|
||||
$ liftIO
|
||||
$ readFile yaml_file
|
||||
$ L.readFile yaml_file
|
||||
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
|
||||
|
||||
|
||||
|
|
@ -207,29 +202,27 @@ getBase =
|
|||
smartDl uri' = do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
let path = view pathL' uri'
|
||||
json_file <- (cacheDir </>) <$> urlBaseName path
|
||||
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
then do
|
||||
accessTime <-
|
||||
PF.accessTimeHiRes
|
||||
<$> liftIO (PF.getFileStatus (toFilePath json_file))
|
||||
currentTime <- liftIO getPOSIXTime
|
||||
accessTime <- liftIO $ getAccessTime json_file
|
||||
currentTime <- liftIO getCurrentTime
|
||||
|
||||
-- access time won't work on most linuxes, but we can try regardless
|
||||
if (currentTime - accessTime) > 300
|
||||
if (utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300
|
||||
then do -- no access in last 5 minutes, re-check upstream mod time
|
||||
getModTime >>= \case
|
||||
Just modTime -> do
|
||||
fileMod <- liftIO $ getModificationTime json_file
|
||||
if modTime > fileMod
|
||||
then dlWithMod modTime json_file
|
||||
else liftIO $ readFile json_file
|
||||
else liftIO $ L.readFile json_file
|
||||
Nothing -> do
|
||||
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
|
||||
dlWithoutMod json_file
|
||||
else -- access in less than 5 minutes, re-use file
|
||||
liftIO $ readFile json_file
|
||||
liftIO $ L.readFile json_file
|
||||
else do
|
||||
liftIO $ createDirRecursive' cacheDir
|
||||
getModTime >>= \case
|
||||
|
|
@ -247,9 +240,9 @@ getBase =
|
|||
pure bs
|
||||
dlWithoutMod json_file = do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile json_file
|
||||
liftIO $ writeFileL json_file (Just newFilePerms) bs
|
||||
liftIO $ setModificationTime json_file (fromIntegral @Int 0)
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile json_file
|
||||
liftIO $ L.writeFile json_file bs
|
||||
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
|
||||
pure bs
|
||||
|
||||
|
||||
|
|
@ -278,11 +271,10 @@ getBase =
|
|||
|
||||
#endif
|
||||
|
||||
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
|
||||
writeFileWithModTime :: UTCTime -> FilePath -> L.ByteString -> IO ()
|
||||
writeFileWithModTime utctime path content = do
|
||||
let mod_time = utcTimeToPOSIXSeconds utctime
|
||||
writeFileL path (Just newFilePerms) content
|
||||
setModificationTimeHiRes path mod_time
|
||||
L.writeFile path content
|
||||
setModificationTime path utctime
|
||||
|
||||
|
||||
getDownloadInfo :: Tool
|
||||
|
|
@ -334,9 +326,9 @@ download :: ( MonadMask m
|
|||
, MonadIO m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Path Abs -- ^ destination dir
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
|
||||
-> FilePath -- ^ destination dir
|
||||
-> Maybe FilePath -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m FilePath
|
||||
download dli dest mfn
|
||||
| scheme == "https" = dl
|
||||
| scheme == "http" = dl
|
||||
|
|
@ -348,9 +340,9 @@ download dli dest mfn
|
|||
cp = do
|
||||
-- destination dir must exist
|
||||
liftIO $ createDirRecursive' dest
|
||||
destFile <- getDestFile
|
||||
fromFile <- parseAbs path
|
||||
liftIO $ copyFile fromFile destFile Strict
|
||||
let destFile = getDestFile
|
||||
let fromFile = T.unpack . decUTF8Safe $ path
|
||||
liftIO $ copyFile fromFile destFile
|
||||
pure destFile
|
||||
dl = do
|
||||
let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
|
||||
|
|
@ -358,25 +350,25 @@ download dli dest mfn
|
|||
|
||||
-- destination dir must exist
|
||||
liftIO $ createDirRecursive' dest
|
||||
destFile <- getDestFile
|
||||
let destFile = getDestFile
|
||||
|
||||
-- download
|
||||
flip onException
|
||||
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
|
||||
(liftIO $ hideError doesNotExistErrorType $ removeFile destFile)
|
||||
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
|
||||
(\e ->
|
||||
liftIO (hideError doesNotExistErrorType $ deleteFile destFile)
|
||||
liftIO (hideError doesNotExistErrorType $ removeFile destFile)
|
||||
>> (throwE . DownloadFailed $ e)
|
||||
) $ do
|
||||
lift getDownloader >>= \case
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
|
||||
(o' ++ ["-fL", "-o", toFilePath destFile, serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl"
|
||||
(o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
Wget -> do
|
||||
o' <- liftIO getWgetOpts
|
||||
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True
|
||||
(o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget"
|
||||
(o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
Internal -> do
|
||||
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
|
||||
|
|
@ -387,8 +379,8 @@ download dli dest mfn
|
|||
pure destFile
|
||||
|
||||
-- Manage to find a file we can write the body into.
|
||||
getDestFile :: MonadThrow m => m (Path Abs)
|
||||
getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
|
||||
getDestFile :: FilePath
|
||||
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path))) (dest </>) mfn
|
||||
|
||||
path = view (dlUri % pathL') dli
|
||||
|
||||
|
|
@ -404,14 +396,14 @@ downloadCached :: ( MonadMask m
|
|||
, MonadReader AppState m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
|
||||
-> Maybe FilePath -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m FilePath
|
||||
downloadCached dli mfn = do
|
||||
cache <- lift getCache
|
||||
case cache of
|
||||
True -> do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
|
||||
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
|
||||
let cachfile = cacheDir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
|
|
@ -453,8 +445,8 @@ downloadBS uri'
|
|||
| scheme == "http"
|
||||
= dl False
|
||||
| scheme == "file"
|
||||
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
|
||||
(liftIO $ RD.readFile path)
|
||||
= liftIOException doesNotExistErrorType (FileDoesNotExistError $ T.unpack $ decUTF8Safe path)
|
||||
(liftIO $ L.readFile (T.unpack $ decUTF8Safe path))
|
||||
| otherwise
|
||||
= throwE UnsupportedScheme
|
||||
|
||||
|
|
@ -470,20 +462,20 @@ downloadBS uri'
|
|||
lift getDownloader >>= \case
|
||||
Curl -> do
|
||||
o' <- liftIO getCurlOpts
|
||||
let exe = [rel|curl|]
|
||||
args = o' ++ ["-sSfL", serializeURIRef' uri']
|
||||
let exe = "curl"
|
||||
args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
|
||||
liftIO (executeOut exe args Nothing) >>= \case
|
||||
CapturedProcess ExitSuccess stdout _ -> do
|
||||
pure $ L.fromStrict stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
|
||||
pure stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
|
||||
Wget -> do
|
||||
o' <- liftIO getWgetOpts
|
||||
let exe = [rel|wget|]
|
||||
args = o' ++ ["-qO-", serializeURIRef' uri']
|
||||
let exe = "wget"
|
||||
args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
|
||||
liftIO (executeOut exe args Nothing) >>= \case
|
||||
CapturedProcess ExitSuccess stdout _ -> do
|
||||
pure $ L.fromStrict stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
|
||||
pure stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
Internal -> do
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
|
|
@ -493,31 +485,31 @@ downloadBS uri'
|
|||
|
||||
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
|
||||
=> DownloadInfo
|
||||
-> Path Abs
|
||||
-> FilePath
|
||||
-> Excepts '[DigestError] m ()
|
||||
checkDigest dli file = do
|
||||
verify <- lift ask <&> (not . noVerify . settings)
|
||||
when verify $ do
|
||||
p' <- toFilePath <$> basename file
|
||||
let p' = takeFileName file
|
||||
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
|
||||
c <- liftIO $ readFile file
|
||||
c <- liftIO $ L.readFile file
|
||||
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
|
||||
let eDigest = view dlHash dli
|
||||
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
|
||||
|
||||
|
||||
-- | Get additional curl args from env. This is an undocumented option.
|
||||
getCurlOpts :: IO [ByteString]
|
||||
getCurlOpts :: IO [String]
|
||||
getCurlOpts =
|
||||
getEnv "GHCUP_CURL_OPTS" >>= \case
|
||||
Just r -> pure $ BS.split _space r
|
||||
lookupEnv "GHCUP_CURL_OPTS" >>= \case
|
||||
Just r -> pure $ splitOn " " r
|
||||
Nothing -> pure []
|
||||
|
||||
|
||||
-- | Get additional wget args from env. This is an undocumented option.
|
||||
getWgetOpts :: IO [ByteString]
|
||||
getWgetOpts :: IO [String]
|
||||
getWgetOpts =
|
||||
getEnv "GHCUP_WGET_OPTS" >>= \case
|
||||
Just r -> pure $ BS.split _space r
|
||||
lookupEnv "GHCUP_WGET_OPTS" >>= \case
|
||||
Just r -> pure $ splitOn " " r
|
||||
Nothing -> pure []
|
||||
|
||||
|
|
|
|||
|
|
@ -24,8 +24,6 @@ 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
|
||||
|
|
@ -33,11 +31,8 @@ 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
|
||||
|
|
@ -81,12 +76,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)
|
||||
-> Path Abs -- ^ destination file to create and write to
|
||||
-> FilePath -- ^ destination file to create and write to
|
||||
-> Excepts '[DownloadFailed] m ()
|
||||
downloadToFile https host fullPath port destFile = do
|
||||
fd <- liftIO $ createRegularFileFd newFilePerms destFile
|
||||
let stepper = fdWrite fd
|
||||
flip finally (liftIO $ closeFd fd)
|
||||
fd <- liftIO $ openFile destFile WriteMode
|
||||
let stepper = BS.hPut fd
|
||||
flip finally (liftIO $ hClose fd)
|
||||
$ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -15,12 +15,11 @@ Copyright : (c) Julian Ospald, 2020
|
|||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Errors where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
#if !defined(TAR)
|
||||
import Codec.Archive
|
||||
|
|
@ -28,11 +27,9 @@ 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
|
||||
|
|
@ -86,12 +83,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 ByteString
|
||||
data UnknownArchive = UnknownArchive FilePath
|
||||
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 "#{decUTF8Safe file}"|]
|
||||
text [i|The archive format is unknown. We don't know how to extract the file "#{file}"|]
|
||||
|
||||
-- | The scheme is not supported (such as ftp).
|
||||
data UnsupportedScheme = UnsupportedScheme
|
||||
|
|
@ -143,12 +140,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 (Path Rel)
|
||||
data NotFoundInPATH = NotFoundInPATH FilePath
|
||||
deriving Show
|
||||
|
||||
instance Pretty NotFoundInPATH where
|
||||
pPrint (NotFoundInPATH exe) =
|
||||
text [i|The exe "#{decUTF8Safe . toFilePath $ exe}" was not found in PATH.|]
|
||||
text [i|The exe "#{exe}" was not found in PATH.|]
|
||||
|
||||
-- | JSON decoding failed.
|
||||
data JSONError = JSONDecodeError String
|
||||
|
|
@ -160,12 +157,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 ByteString
|
||||
data FileDoesNotExistError = FileDoesNotExistError FilePath
|
||||
deriving Show
|
||||
|
||||
instance Pretty FileDoesNotExistError where
|
||||
pPrint (FileDoesNotExistError file) =
|
||||
text [i|File "#{decUTF8Safe file}" does not exist.|]
|
||||
text [i|File "#{file}" does not exist.|]
|
||||
|
||||
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
|
||||
deriving Show
|
||||
|
|
@ -252,11 +249,11 @@ deriving instance Show DownloadFailed
|
|||
|
||||
|
||||
-- | A build failed.
|
||||
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
|
||||
data BuildFailed = forall es . Show (V es) => BuildFailed FilePath (V es)
|
||||
|
||||
instance Pretty BuildFailed where
|
||||
pPrint (BuildFailed path reason) =
|
||||
text [i|BuildFailed failed in dir "#{decUTF8Safe . toFilePath $ path}": #{reason}|]
|
||||
text [i|BuildFailed failed in dir "#{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 : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Platform where
|
||||
|
||||
|
|
@ -36,18 +36,20 @@ 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 ]--
|
||||
|
|
@ -96,22 +98,23 @@ 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 [rel|freebsd-version|] [] Nothing
|
||||
getDarwinVersion = liftIO $ fmap _stdOut $ executeOut [rel|sw_vers|]
|
||||
liftIO $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
|
||||
getDarwinVersion = liftIO $ fmap _stdOut $ executeOut "sw_vers"
|
||||
["-productVersion"]
|
||||
Nothing
|
||||
|
||||
|
|
@ -147,12 +150,12 @@ getLinuxDistro = do
|
|||
where
|
||||
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
|
||||
|
||||
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|]
|
||||
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"
|
||||
|
||||
try_os_release :: IO (Text, Maybe Text)
|
||||
try_os_release = do
|
||||
|
|
@ -165,11 +168,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 <- fmap decUTF8Safe' $ readFile redhat_release
|
||||
t <- T.readFile redhat_release
|
||||
let nameRegex n =
|
||||
makeRegexOpts compIgnoreCase
|
||||
execBlank
|
||||
|
|
@ -191,5 +194,5 @@ getLinuxDistro = do
|
|||
|
||||
try_debian_version :: IO (Text, Maybe Text)
|
||||
try_debian_version = do
|
||||
ver <- readFile debian_version
|
||||
pure (T.pack "debian", Just . decUTF8Safe' $ ver)
|
||||
ver <- T.readFile debian_version
|
||||
pure (T.pack "debian", Just ver)
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ Copyright : (c) Julian Ospald, 2020
|
|||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Requirements where
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types
|
||||
|
|
@ -11,26 +10,39 @@ Copyright : (c) Julian Ospald, 2020
|
|||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Types where
|
||||
module GHCup.Types
|
||||
( module GHCup.Types
|
||||
#if defined(BRICK)
|
||||
, Key(..)
|
||||
#endif
|
||||
)
|
||||
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
|
||||
|
||||
|
||||
#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 ]--
|
||||
|
|
@ -157,12 +169,15 @@ 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
|
||||
|
|
@ -218,12 +233,12 @@ data DownloadInfo = DownloadInfo
|
|||
|
||||
|
||||
-- | How to descend into a tar archive.
|
||||
data TarDir = RealDir (Path Rel)
|
||||
data TarDir = RealDir FilePath
|
||||
| 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 [i|#{E.decodeUtf8With E.lenientDecode . toFilePath $ path}|]
|
||||
pPrint (RealDir path) = text path
|
||||
pPrint (RegexDir regex) = text regex
|
||||
|
||||
|
||||
|
|
@ -250,42 +265,42 @@ defaultUserSettings :: UserSettings
|
|||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
data UserKeyBindings = UserKeyBindings
|
||||
{ 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
|
||||
, kShowAllTools :: Maybe Vty.Key
|
||||
{ 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
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
data KeyBindings = KeyBindings
|
||||
{ bUp :: Vty.Key
|
||||
, bDown :: Vty.Key
|
||||
, bQuit :: Vty.Key
|
||||
, bInstall :: Vty.Key
|
||||
, bUninstall :: Vty.Key
|
||||
, bSet :: Vty.Key
|
||||
, bChangelog :: Vty.Key
|
||||
, bShowAllVersions :: Vty.Key
|
||||
, bShowAllTools :: Vty.Key
|
||||
{ bUp :: Key
|
||||
, bDown :: Key
|
||||
, bQuit :: Key
|
||||
, bInstall :: Key
|
||||
, bUninstall :: Key
|
||||
, bSet :: Key
|
||||
, bChangelog :: Key
|
||||
, bShowAllVersions :: Key
|
||||
, bShowAllTools :: Key
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
defaultKeyBindings :: KeyBindings
|
||||
defaultKeyBindings = KeyBindings
|
||||
{ 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'
|
||||
, bShowAllVersions = Vty.KChar 'a'
|
||||
, bShowAllTools = Vty.KChar 't'
|
||||
{ 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'
|
||||
}
|
||||
|
||||
data AppState = AppState
|
||||
|
|
@ -305,11 +320,11 @@ data Settings = Settings
|
|||
deriving (Show, GHC.Generic)
|
||||
|
||||
data Dirs = Dirs
|
||||
{ baseDir :: Path Abs
|
||||
, binDir :: Path Abs
|
||||
, cacheDir :: Path Abs
|
||||
, logsDir :: Path Abs
|
||||
, confDir :: Path Abs
|
||||
{ baseDir :: FilePath
|
||||
, binDir :: FilePath
|
||||
, cacheDir :: FilePath
|
||||
, logsDir :: FilePath
|
||||
, confDir :: FilePath
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
|
@ -326,10 +341,10 @@ data Downloader = Curl
|
|||
deriving (Eq, Show, Ord)
|
||||
|
||||
data DebugInfo = DebugInfo
|
||||
{ diBaseDir :: Path Abs
|
||||
, diBinDir :: Path Abs
|
||||
, diGHCDir :: Path Abs
|
||||
, diCacheDir :: Path Abs
|
||||
{ diBaseDir :: FilePath
|
||||
, diBinDir :: FilePath
|
||||
, diGHCDir :: FilePath
|
||||
, diCacheDir :: FilePath
|
||||
, diArch :: Architecture
|
||||
, diPlatform :: PlatformResult
|
||||
}
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ Copyright : (c) Julian Ospald, 2020
|
|||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Types.JSON where
|
||||
|
||||
|
|
@ -33,15 +33,11 @@ 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
|
||||
|
||||
|
|
@ -64,7 +60,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 } ''Vty.Key
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
|
||||
|
||||
instance ToJSON Tag where
|
||||
toJSON Latest = String "Latest"
|
||||
|
|
@ -128,11 +124,13 @@ 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
|
||||
|
|
@ -199,20 +197,6 @@ 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 : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
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 : POSIX
|
||||
Portability : portable
|
||||
|
||||
This module contains GHCup helpers specific to
|
||||
installation and introspection of files/versions etc.
|
||||
|
|
@ -39,6 +39,7 @@ 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
|
||||
|
|
@ -51,28 +52,21 @@ 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.Posix.FilePath ( getSearchPath
|
||||
, takeFileName
|
||||
)
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import System.IO.Unsafe ( unsafeInterleaveIO )
|
||||
import Text.Regex.Posix
|
||||
import URI.ByteString
|
||||
|
||||
|
|
@ -85,9 +79,7 @@ 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
|
||||
|
||||
|
|
@ -102,14 +94,13 @@ import qualified Text.Megaparsec as MP
|
|||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
||||
=> ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
=> FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> GHCTargetVersion
|
||||
-> m ByteString
|
||||
-> m FilePath
|
||||
ghcLinkDestination tool ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
t <- parseRel tool
|
||||
ghcd <- ghcupGHCDir ver
|
||||
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
|
||||
pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
|
||||
|
||||
|
||||
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
|
||||
|
|
@ -127,10 +118,10 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
|
|||
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion)
|
||||
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
|
||||
let fullF = binDir </> f_xyz
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
|
||||
|
||||
|
||||
-- | Removes the set ghc version for the given target, if any.
|
||||
|
|
@ -148,13 +139,13 @@ rmPlain target = do
|
|||
forM_ mtv $ \tv -> do
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
let fullF = binDir </> f
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
let fullF = binDir </> f <> exeExt
|
||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
|
||||
-- old ghcup
|
||||
let hdc_file = binDir </> [rel|haddock-ghc|]
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
|
||||
let hdc_file = binDir </> "haddock-ghc" <> exeExt
|
||||
lift $ $(logDebug) [i|rm -f #{hdc_file}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile hdc_file
|
||||
|
||||
|
||||
-- | Remove the major GHC symlink, e.g. ghc-8.6.
|
||||
|
|
@ -174,10 +165,10 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
|
|||
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
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
|
||||
let f_xy = f <> "-" <> T.unpack v' <> exeExt
|
||||
let fullF = binDir </> f_xy
|
||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
|
||||
|
||||
|
||||
|
||||
|
|
@ -208,42 +199,40 @@ ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
|
|||
-> m (Maybe GHCTargetVersion)
|
||||
ghcSet mtarget = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
|
||||
let ghcBin = binDir </> ghc
|
||||
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
|
||||
let ghcBin = binDir </> ghc <> exeExt
|
||||
|
||||
-- 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 <- readSymbolicLink $ toFilePath ghcBin
|
||||
link <- liftIO $ getSymbolicLinkTarget ghcBin
|
||||
Just <$> ghcLinkVersion link
|
||||
|
||||
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
|
||||
ghcLinkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "ghcLinkVersion" t
|
||||
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
|
||||
ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
|
||||
where
|
||||
parser =
|
||||
(do
|
||||
_ <- parseUntil1 (MP.chunk "/ghc/")
|
||||
_ <- MP.chunk "/ghc/"
|
||||
r <- parseUntil1 (MP.chunk "/")
|
||||
_ <- parseUntil1 ghcSubPath
|
||||
_ <- ghcSubPath
|
||||
r <- parseUntil1 pathSep
|
||||
rest <- MP.getInput
|
||||
MP.setInput r
|
||||
x <- ghcTargetVerP
|
||||
MP.setInput rest
|
||||
pure x
|
||||
)
|
||||
<* MP.chunk "/"
|
||||
<* pathSep
|
||||
<* 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 (Path Rel) GHCTargetVersion]
|
||||
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
|
||||
getInstalledGHCs = do
|
||||
ghcdir <- ghcupGHCBaseDir
|
||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
|
||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
|
||||
forM fs $ \f -> case parseGHCupGHCDir f of
|
||||
Right r -> pure $ Right r
|
||||
Left _ -> pure $ Left f
|
||||
|
|
@ -251,7 +240,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 (Path Rel) Version]
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledCabals = do
|
||||
cs <- cabalSet -- for legacy cabal
|
||||
getInstalledCabals' cs
|
||||
|
|
@ -259,13 +248,13 @@ getInstalledCabals = do
|
|||
|
||||
getInstalledCabals' :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
=> Maybe Version
|
||||
-> m [Either (Path Rel) Version]
|
||||
-> m [Either FilePath 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 . decUTF8Safe) . B.stripPrefix "cabal-" . toFilePath $ f of
|
||||
vs <- forM bins $ \f -> case fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "cabal-" $ f of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
|
|
@ -283,22 +272,20 @@ 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 </> [rel|cabal|]
|
||||
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
|
||||
let cabalbin = binDir </> "cabal" <> exeExt
|
||||
b <- handleIO (\_ -> pure False) $ liftIO $ pathIsSymbolicLink cabalbin
|
||||
if
|
||||
| b -> do
|
||||
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
broken <- liftIO $ isBrokenSymlink cabalbin
|
||||
if broken
|
||||
then do
|
||||
$(logWarn) [i|Symlink #{cabalbin} is broken.|]
|
||||
pure Nothing
|
||||
then pure Nothing
|
||||
else do
|
||||
link <- liftIO $ readSymbolicLink $ toFilePath cabalbin
|
||||
link <- liftIO $ getSymbolicLinkTarget 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 #{toFilePath 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 #{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
|
||||
|
|
@ -306,8 +293,8 @@ cabalSet = do
|
|||
["--numeric-version"]
|
||||
Nothing
|
||||
fmap join $ forM mc $ \c -> if
|
||||
| not (B.null (_stdOut c)), _exitCode c == ExitSuccess -> do
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
|
||||
| not (BL.null (_stdOut c)), _exitCode c == ExitSuccess -> do
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . BL.toStrict . _stdOut $ c
|
||||
case version $ decUTF8Safe reportedVer of
|
||||
Left e -> throwM e
|
||||
Right r -> pure $ Just r
|
||||
|
|
@ -316,10 +303,8 @@ 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 => ByteString -> m Version
|
||||
linkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "" t
|
||||
linkVersion :: MonadThrow m => FilePath -> m Version
|
||||
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
|
||||
|
||||
parser
|
||||
= MP.try (stripAbsolutePath *> cabalParse)
|
||||
|
|
@ -329,10 +314,10 @@ cabalSet = do
|
|||
cabalParse = MP.chunk "cabal-" *> version'
|
||||
-- parses any path component ending with path separator,
|
||||
-- e.g. "foo/"
|
||||
stripPathComponet = parseUntil1 "/" *> MP.chunk "/"
|
||||
stripPathComponet = parseUntil1 pathSep *> pathSep
|
||||
-- parses an absolute path up until the last path separator,
|
||||
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
|
||||
stripAbsolutePath = MP.chunk "/" *> MP.many (MP.try stripPathComponet)
|
||||
stripAbsolutePath = pathSep *> 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)
|
||||
|
|
@ -342,7 +327,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 (Path Rel) Version]
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledHLSs = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
|
|
@ -353,7 +338,7 @@ getInstalledHLSs = do
|
|||
)
|
||||
forM bins $ \f ->
|
||||
case
|
||||
fmap (version . decUTF8Safe) . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f
|
||||
fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "haskell-language-server-wrapper-" $ f
|
||||
of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
|
|
@ -362,7 +347,7 @@ getInstalledHLSs = do
|
|||
-- | Get all installed stacks, by matching on
|
||||
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
|
||||
getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
|
||||
=> m [Either (Path Rel) Version]
|
||||
=> m [Either FilePath Version]
|
||||
getInstalledStacks = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
|
|
@ -373,7 +358,7 @@ getInstalledStacks = do
|
|||
)
|
||||
forM bins $ \f ->
|
||||
case
|
||||
fmap (version . decUTF8Safe) . B.stripPrefix "stack-" . toFilePath $ f
|
||||
fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "stack-" $ f
|
||||
of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
|
|
@ -384,20 +369,18 @@ getInstalledStacks = do
|
|||
stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
|
||||
stackSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
let stackBin = binDir </> [rel|stack|]
|
||||
let stackBin = binDir </> "stack" <> exeExt
|
||||
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
broken <- isBrokenSymlink stackBin
|
||||
if broken
|
||||
then pure Nothing
|
||||
else do
|
||||
link <- readSymbolicLink $ toFilePath stackBin
|
||||
link <- liftIO $ getSymbolicLinkTarget stackBin
|
||||
Just <$> linkVersion link
|
||||
where
|
||||
linkVersion :: MonadThrow m => ByteString -> m Version
|
||||
linkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "" t
|
||||
linkVersion :: MonadThrow m => FilePath -> m Version
|
||||
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
|
||||
where
|
||||
parser =
|
||||
MP.chunk "stack-" *> version'
|
||||
|
|
@ -420,20 +403,18 @@ 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 </> [rel|haskell-language-server-wrapper|]
|
||||
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
|
||||
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
broken <- isBrokenSymlink hlsBin
|
||||
if broken
|
||||
then pure Nothing
|
||||
else do
|
||||
link <- readSymbolicLink $ toFilePath hlsBin
|
||||
link <- liftIO $ getSymbolicLinkTarget hlsBin
|
||||
Just <$> linkVersion link
|
||||
where
|
||||
linkVersion :: MonadThrow m => ByteString -> m Version
|
||||
linkVersion bs = do
|
||||
t <- throwEither $ E.decodeUtf8' bs
|
||||
throwEither $ MP.parse parser "" t
|
||||
linkVersion :: MonadThrow m => FilePath -> m Version
|
||||
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
|
||||
where
|
||||
parser =
|
||||
MP.chunk "haskell-language-server-wrapper-" *> version'
|
||||
|
|
@ -452,13 +433,12 @@ hlsGHCVersions = do
|
|||
bins <- hlsServerBinaries h'
|
||||
pure $ fmap
|
||||
(version
|
||||
. decUTF8Safe
|
||||
. T.pack
|
||||
. fromJust
|
||||
. B.stripPrefix "haskell-language-server-"
|
||||
. stripPrefix "haskell-language-server-"
|
||||
. head
|
||||
. B.split _tilde
|
||||
. toFilePath
|
||||
)
|
||||
. splitOn "~"
|
||||
)
|
||||
bins
|
||||
pure . rights . concat . maybeToList $ vers
|
||||
|
||||
|
|
@ -466,7 +446,7 @@ hlsGHCVersions = do
|
|||
-- | Get all server binaries for an hls version, if any.
|
||||
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
|
||||
=> Version
|
||||
-> m [Path Rel]
|
||||
-> m [FilePath]
|
||||
hlsServerBinaries ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
|
|
@ -474,7 +454,7 @@ hlsServerBinaries ver = do
|
|||
(makeRegexOpts
|
||||
compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
|
||||
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
|
||||
)
|
||||
)
|
||||
|
||||
|
|
@ -482,7 +462,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 (Path Rel))
|
||||
-> m (Maybe FilePath)
|
||||
hlsWrapperBinary ver = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
|
|
@ -490,7 +470,7 @@ hlsWrapperBinary ver = do
|
|||
(makeRegexOpts
|
||||
compExtended
|
||||
execBlank
|
||||
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [s|$|] :: ByteString
|
||||
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
|
||||
)
|
||||
)
|
||||
case wrapper of
|
||||
|
|
@ -501,7 +481,7 @@ hlsWrapperBinary ver = do
|
|||
|
||||
|
||||
-- | Get all binaries for an hls version, if any.
|
||||
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
|
||||
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath]
|
||||
hlsAllBinaries ver = do
|
||||
hls <- hlsServerBinaries ver
|
||||
wrapper <- hlsWrapperBinary ver
|
||||
|
|
@ -509,7 +489,7 @@ hlsAllBinaries ver = do
|
|||
|
||||
|
||||
-- | Get the active symlinks for hls.
|
||||
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Path Rel]
|
||||
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath]
|
||||
hlsSymlinks = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
|
|
@ -519,9 +499,8 @@ hlsSymlinks = do
|
|||
([s|^haskell-language-server-.*$|] :: ByteString)
|
||||
)
|
||||
filterM
|
||||
( fmap (== SymbolicLink)
|
||||
. liftIO
|
||||
. getFileType
|
||||
( liftIO
|
||||
. pathIsSymbolicLink
|
||||
. (binDir </>)
|
||||
)
|
||||
oldSyms
|
||||
|
|
@ -585,61 +564,61 @@ getLatestGHCFor major' minor' dls =
|
|||
|
||||
-- | Unpack an archive to a temporary directory and return that path.
|
||||
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
=> Path Abs -- ^ destination dir
|
||||
-> Path Abs -- ^ archive path
|
||||
=> FilePath -- ^ destination dir
|
||||
-> FilePath -- ^ archive path
|
||||
-> Excepts '[UnknownArchive
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
] m ()
|
||||
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
|
||||
unpackToDir dfp av = do
|
||||
let fn = takeFileName av
|
||||
lift $ $(logInfo) [i|Unpacking: #{fn} to #{dfp}|]
|
||||
|
||||
#if defined(TAR)
|
||||
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
|
||||
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
|
||||
untar = liftIO . Tar.unpack dfp . Tar.read
|
||||
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
rf :: MonadIO m => FilePath -> Excepts '[] m BL.ByteString
|
||||
rf = liftIO . BL.readFile
|
||||
#else
|
||||
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
|
||||
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
|
||||
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
|
||||
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
|
||||
rf = liftIO . BL.readFile
|
||||
#endif
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| ".tar.gz" `B.isSuffixOf` fn -> liftE
|
||||
| ".tar.gz" `isSuffixOf` fn -> liftE
|
||||
(untar . GZip.decompress =<< rf av)
|
||||
| ".tar.xz" `B.isSuffixOf` fn -> do
|
||||
| ".tar.xz" `isSuffixOf` fn -> do
|
||||
filecontents <- liftE $ rf av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftE $ untar decompressed
|
||||
| ".tar.bz2" `B.isSuffixOf` fn ->
|
||||
| ".tar.bz2" `isSuffixOf` fn ->
|
||||
liftE (untar . BZip.decompress =<< rf av)
|
||||
| ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av)
|
||||
| ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av)
|
||||
| ".zip" `isSuffixOf` fn ->
|
||||
withArchive av (unpackInto dfp)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
=> Path Abs -- ^ archive path
|
||||
=> FilePath -- ^ archive path
|
||||
-> Excepts '[UnknownArchive
|
||||
#if defined(TAR)
|
||||
, Tar.FormatError
|
||||
#else
|
||||
, ArchiveResult
|
||||
#endif
|
||||
] m [ByteString]
|
||||
] m [FilePath]
|
||||
getArchiveFiles av = do
|
||||
fn <- toFilePath <$> basename av
|
||||
let fn = takeFileName av
|
||||
|
||||
#if defined(TAR)
|
||||
let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [ByteString]
|
||||
let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [FilePath]
|
||||
entries =
|
||||
lE @Tar.FormatError
|
||||
. Tar.foldEntries
|
||||
|
|
@ -648,41 +627,45 @@ getArchiveFiles av = do
|
|||
(\e -> Left e)
|
||||
. Tar.read
|
||||
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[Tar.FormatError] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
rf :: MonadIO m => FilePath -> Excepts '[Tar.FormatError] m BL.ByteString
|
||||
rf = liftIO . BL.readFile
|
||||
#else
|
||||
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [ByteString]
|
||||
entries = (fmap . fmap) (E.encodeUtf8 . T.pack . filepath) . lE . readArchiveBSL
|
||||
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath]
|
||||
entries = (fmap . fmap) filepath . lE . readArchiveBSL
|
||||
|
||||
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
|
||||
rf = liftIO . readFile
|
||||
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
|
||||
rf = liftIO . BL.readFile
|
||||
#endif
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| ".tar.gz" `B.isSuffixOf` fn -> liftE
|
||||
| ".tar.gz" `isSuffixOf` fn -> liftE
|
||||
(entries . GZip.decompress =<< rf av)
|
||||
| ".tar.xz" `B.isSuffixOf` fn -> do
|
||||
| ".tar.xz" `isSuffixOf` fn -> do
|
||||
filecontents <- liftE $ rf av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftE $ entries decompressed
|
||||
| ".tar.bz2" `B.isSuffixOf` fn ->
|
||||
| ".tar.bz2" `isSuffixOf` fn ->
|
||||
liftE (entries . BZip.decompress =<< rf av)
|
||||
| ".tar" `B.isSuffixOf` fn -> liftE (entries =<< rf av)
|
||||
| ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av)
|
||||
| ".zip" `isSuffixOf` fn ->
|
||||
withArchive av $ do
|
||||
entries' <- getEntries
|
||||
pure $ fmap unEntrySelector $ Map.keys entries'
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
|
||||
=> Path Abs -- ^ unpacked tar dir
|
||||
=> FilePath -- ^ unpacked tar dir
|
||||
-> TarDir -- ^ how to descend
|
||||
-> Excepts '[TarDirDoesNotExist] m (Path Abs)
|
||||
-> Excepts '[TarDirDoesNotExist] m FilePath
|
||||
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 = splitOn "/" r
|
||||
let rs = split (`elem` pathSeparators) r
|
||||
foldlM
|
||||
(\y x ->
|
||||
(handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
|
||||
|
|
@ -743,117 +726,124 @@ getDownloader = ask <&> downloader . settings
|
|||
-------------
|
||||
|
||||
|
||||
urlBaseName :: MonadThrow m
|
||||
=> ByteString -- ^ the url path (without scheme and host)
|
||||
-> m (Path Rel)
|
||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
|
||||
-> ByteString
|
||||
urlBaseName = 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, e.g.:
|
||||
-- Returns unversioned relative files without extension, 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 [Path Rel]
|
||||
-> Excepts '[NotInstalled] m [FilePath]
|
||||
ghcToolFiles ver = do
|
||||
ghcdir <- lift $ ghcupGHCDir ver
|
||||
let bindir = ghcdir </> [rel|bin|]
|
||||
let bindir = ghcdir </> "bin"
|
||||
|
||||
-- fail if ghc is not installed
|
||||
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
|
||||
(throwE (NotInstalled GHC ver))
|
||||
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
files <- liftIO $ listDirectory bindir
|
||||
-- figure out the <ver> suffix, because this might not be `Version` for
|
||||
-- alpha/rc releases, but x.y.a.somedate.
|
||||
|
||||
-- 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)
|
||||
)
|
||||
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"
|
||||
|
||||
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
|
||||
pure $ onlyUnversioned $ fmap (dropSuffix exeExt) files
|
||||
where
|
||||
isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
|
||||
-- GHC is moving some builds to Hadrian for bindists,
|
||||
-- which doesn't create versioned binaries.
|
||||
-- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
|
||||
isHadrian :: Path Abs -- ^ ghcbin path
|
||||
-> IO Bool
|
||||
isHadrian = fmap (/= SymbolicLink) . getFileType
|
||||
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!"
|
||||
|
||||
|
||||
|
||||
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
|
||||
-- this GHC was built from source. It contains the build config.
|
||||
ghcUpSrcBuiltFile :: Path Rel
|
||||
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
|
||||
ghcUpSrcBuiltFile :: FilePath
|
||||
ghcUpSrcBuiltFile = ".ghcup_src_built"
|
||||
|
||||
|
||||
-- | Calls gmake if it exists in PATH, otherwise make.
|
||||
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
|
||||
=> [ByteString]
|
||||
-> Maybe (Path Abs)
|
||||
=> [String]
|
||||
-> Maybe FilePath
|
||||
-> m (Either ProcessError ())
|
||||
make args workdir = do
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
|
||||
spaths <- liftIO getSearchPath
|
||||
has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
|
||||
let mymake = if has_gmake then "gmake" else "make"
|
||||
execLogged mymake True args [rel|ghc-make|] workdir Nothing
|
||||
execLogged mymake args workdir "ghc-make" Nothing
|
||||
|
||||
makeOut :: [ByteString]
|
||||
-> Maybe (Path Abs)
|
||||
makeOut :: [String]
|
||||
-> Maybe FilePath
|
||||
-> IO CapturedProcess
|
||||
makeOut args workdir = do
|
||||
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|]
|
||||
spaths <- liftIO getSearchPath
|
||||
has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
|
||||
let mymake = if has_gmake then "gmake" else "make"
|
||||
liftIO $ executeOut mymake args workdir
|
||||
|
||||
|
||||
-- | Try to apply patches in order. Fails with 'PatchFailed'
|
||||
-- on first failure.
|
||||
applyPatches :: (MonadLogger m, MonadIO m)
|
||||
=> Path Abs -- ^ dir containing patches
|
||||
-> Path Abs -- ^ dir to apply patches in
|
||||
=> FilePath -- ^ dir containing patches
|
||||
-> FilePath -- ^ dir to apply patches in
|
||||
-> Excepts '[PatchFailed] m ()
|
||||
applyPatches pdir ddir = do
|
||||
patches <- liftIO $ getDirsFiles pdir
|
||||
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
|
||||
forM_ (sort patches) $ \patch' -> do
|
||||
lift $ $(logInfo) [i|Applying patch #{patch'}|]
|
||||
fmap (either (const Nothing) Just)
|
||||
(liftIO $ exec
|
||||
"patch"
|
||||
True
|
||||
["-p1", "-i", toFilePath patch']
|
||||
["-p1", "-i", patch']
|
||||
(Just ddir)
|
||||
Nothing)
|
||||
!? PatchFailed
|
||||
|
||||
|
||||
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
|
||||
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
|
||||
darwinNotarization :: Platform -> FilePath -> IO (Either ProcessError ())
|
||||
darwinNotarization Darwin path = exec
|
||||
"xattr"
|
||||
True
|
||||
["-r", "-d", "com.apple.quarantine", toFilePath path]
|
||||
["-r", "-d", "com.apple.quarantine", path]
|
||||
Nothing
|
||||
Nothing
|
||||
darwinNotarization _ _ = pure $ Right ()
|
||||
|
|
@ -871,19 +861,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)
|
||||
=> Path Abs -- ^ build directory (cleaned up depending on Settings)
|
||||
-> Maybe (Path Abs) -- ^ dir to *always* clean up on exception
|
||||
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
||||
-> Maybe FilePath -- ^ dir to *always* clean up on exception
|
||||
-> Excepts e m a
|
||||
-> Excepts '[BuildFailed] m a
|
||||
runBuildAction bdir instdir action = do
|
||||
AppState { settings = Settings {..} } <- lift ask
|
||||
let exAction = do
|
||||
forM_ instdir $ \dir ->
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
|
||||
liftIO $ hideError doesNotExistErrorType $ removeDirectoryRecursive dir
|
||||
when (keepDirs == Never)
|
||||
$ liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
$ deleteDirRecursive bdir
|
||||
$ removeDirectoryRecursive bdir
|
||||
v <-
|
||||
flip onException exAction
|
||||
$ catchAllE
|
||||
|
|
@ -892,32 +882,90 @@ runBuildAction bdir instdir action = do
|
|||
throwE (BuildFailed bdir es)
|
||||
) action
|
||||
|
||||
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
|
||||
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ removeDirectoryRecursive
|
||||
bdir
|
||||
pure v
|
||||
|
||||
|
||||
-- | More permissive version of 'createDirRecursive'. This doesn't
|
||||
-- error when the destination is a symlink to a directory.
|
||||
createDirRecursive' :: Path b -> IO ()
|
||||
createDirRecursive' :: FilePath -> IO ()
|
||||
createDirRecursive' p =
|
||||
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
|
||||
. createDirRecursive newDirPerms
|
||||
. createDirectoryIfMissing True
|
||||
$ p
|
||||
|
||||
where
|
||||
isSymlinkDir e = do
|
||||
ft <- getFileType p
|
||||
ft <- pathIsSymbolicLink p
|
||||
case ft of
|
||||
SymbolicLink -> do
|
||||
True -> do
|
||||
rp <- canonicalizePath p
|
||||
rft <- getFileType rp
|
||||
rft <- doesDirectoryExist rp
|
||||
case rft of
|
||||
Directory -> pure ()
|
||||
True -> pure ()
|
||||
_ -> throwIO e
|
||||
_ -> throwIO e
|
||||
|
||||
|
||||
-- | Recursively copy the contents of one directory to another path.
|
||||
--
|
||||
-- This is a rip-off of Cabal library.
|
||||
copyDirectoryRecursive :: FilePath -> FilePath -> 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
|
||||
|
|
@ -938,3 +986,13 @@ traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
|
|||
-- | Gathering monoidal values
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
|
@ -12,7 +13,7 @@ Copyright : (c) Julian Ospald, 2020
|
|||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Utils.Dirs
|
||||
( getDirs
|
||||
|
|
@ -34,7 +35,6 @@ 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,32 +42,20 @@ 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 Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.Directory
|
||||
import System.DiskSpace
|
||||
import System.Posix.Env.ByteString ( getEnv
|
||||
, getEnvDefault
|
||||
)
|
||||
import System.Posix.FilePath hiding ( (</>) )
|
||||
import System.Posix.Temp.ByteString ( mkdtemp )
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO.Temp
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.ByteString as BS
|
||||
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)
|
||||
|
||||
|
|
@ -82,96 +70,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 (Path Abs)
|
||||
ghcupBaseDir :: IO FilePath
|
||||
ghcupBaseDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- getEnv "XDG_DATA_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> [rel|.local/share|])
|
||||
pure (bdir </> [rel|ghcup|])
|
||||
pure (home </> ".local" </> "share")
|
||||
pure (bdir </> "ghcup")
|
||||
else do
|
||||
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> parseAbs r
|
||||
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> pure r
|
||||
Nothing -> liftIO getHomeDirectory
|
||||
pure (bdir </> [rel|.ghcup|])
|
||||
pure (bdir </> ".ghcup")
|
||||
|
||||
|
||||
-- | ~/.ghcup by default
|
||||
--
|
||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
|
||||
ghcupConfigDir :: IO (Path Abs)
|
||||
ghcupConfigDir :: IO FilePath
|
||||
ghcupConfigDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- getEnv "XDG_CONFIG_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> [rel|.config|])
|
||||
pure (bdir </> [rel|ghcup|])
|
||||
pure (home </> ".config")
|
||||
pure (bdir </> "ghcup")
|
||||
else do
|
||||
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> parseAbs r
|
||||
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> pure r
|
||||
Nothing -> liftIO getHomeDirectory
|
||||
pure (bdir </> [rel|.ghcup|])
|
||||
pure (bdir </> ".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 (Path Abs)
|
||||
ghcupBinDir :: IO FilePath
|
||||
ghcupBinDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
getEnv "XDG_BIN_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
lookupEnv "XDG_BIN_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> [rel|.local/bin|])
|
||||
else ghcupBaseDir <&> (</> [rel|bin|])
|
||||
pure (home </> ".local" </> "bin")
|
||||
else ghcupBaseDir <&> (</> "bin")
|
||||
|
||||
|
||||
-- | Defaults to '~/.ghcup/cache'.
|
||||
--
|
||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
|
||||
ghcupCacheDir :: IO (Path Abs)
|
||||
ghcupCacheDir :: IO FilePath
|
||||
ghcupCacheDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> [rel|.cache|])
|
||||
pure (bdir </> [rel|ghcup|])
|
||||
else ghcupBaseDir <&> (</> [rel|cache|])
|
||||
pure (home </> ".cache")
|
||||
pure (bdir </> "ghcup")
|
||||
else ghcupBaseDir <&> (</> "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 (Path Abs)
|
||||
ghcupLogsDir :: IO FilePath
|
||||
ghcupLogsDir = do
|
||||
xdg <- useXDG
|
||||
if xdg
|
||||
then do
|
||||
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> parseAbs r
|
||||
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
|
||||
Just r -> pure r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> [rel|.cache|])
|
||||
pure (bdir </> [rel|ghcup/logs|])
|
||||
else ghcupBaseDir <&> (</> [rel|logs|])
|
||||
pure (home </> ".cache")
|
||||
pure (bdir </> "ghcup" </> "logs")
|
||||
else ghcupBaseDir <&> (</> "logs")
|
||||
|
||||
|
||||
getDirs :: IO Dirs
|
||||
|
|
@ -194,11 +182,11 @@ ghcupConfigFile :: (MonadIO m)
|
|||
=> Excepts '[JSONError] m UserSettings
|
||||
ghcupConfigFile = do
|
||||
confDir <- liftIO ghcupConfigDir
|
||||
let file = confDir </> [rel|config.yaml|]
|
||||
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
|
||||
case bs of
|
||||
let file = confDir </> "config.yaml"
|
||||
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile file
|
||||
case contents of
|
||||
Nothing -> pure defaultUserSettings
|
||||
Just bs' -> lE' JSONDecodeError . first show . Y.decodeEither' . L.toStrict $ bs'
|
||||
Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
|
||||
|
||||
|
||||
-------------------------
|
||||
|
|
@ -207,10 +195,10 @@ ghcupConfigFile = do
|
|||
|
||||
|
||||
-- | ~/.ghcup/ghc by default.
|
||||
ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
|
||||
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
|
||||
ghcupGHCBaseDir = do
|
||||
AppState { dirs = Dirs {..} } <- ask
|
||||
pure (baseDir </> [rel|ghc|])
|
||||
pure (baseDir </> "ghc")
|
||||
|
||||
|
||||
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
|
||||
|
|
@ -219,35 +207,32 @@ ghcupGHCBaseDir = do
|
|||
-- * 8.8.4
|
||||
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
|
||||
=> GHCTargetVersion
|
||||
-> m (Path Abs)
|
||||
-> m FilePath
|
||||
ghcupGHCDir ver = do
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel $ E.encodeUtf8 (tVerToText ver)
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
let verdir = T.unpack $ tVerToText ver
|
||||
pure (ghcbasedir </> verdir)
|
||||
|
||||
|
||||
-- | See 'ghcupToolParser'.
|
||||
parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
|
||||
parseGHCupGHCDir (toFilePath -> f) = do
|
||||
fp <- throwEither $ E.decodeUtf8' f
|
||||
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
|
||||
parseGHCupGHCDir (T.pack -> fp) =
|
||||
throwEither $ MP.parse ghcTargetVerP "" fp
|
||||
|
||||
|
||||
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
|
||||
mkGhcupTmpDir = do
|
||||
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
|
||||
let fp = T.unpack $ decUTF8Safe tmpdir
|
||||
tmpdir <- liftIO getCanonicalTemporaryDirectory
|
||||
|
||||
let minSpace = 5000 -- a rough guess, aight?
|
||||
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace fp
|
||||
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
|
||||
when (maybe False (toBytes minSpace >) space) $ do
|
||||
$(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) [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)
|
||||
"...waiting for 10 seconds before continuing anyway, you can still abort..."
|
||||
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
|
||||
|
||||
tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
|
||||
parseAbs tmp
|
||||
liftIO $ createTempDirectory tmpdir "ghcup"
|
||||
where
|
||||
toBytes mb = mb * 1024 * 1024
|
||||
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
|
||||
|
|
@ -256,8 +241,8 @@ mkGhcupTmpDir = do
|
|||
where t = 10^n
|
||||
|
||||
|
||||
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)
|
||||
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
|
||||
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) removeDirectoryRecursive)
|
||||
|
||||
|
||||
|
||||
|
|
@ -267,29 +252,19 @@ 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 <$> getEnv "GHCUP_USE_XDG_DIRS"
|
||||
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
|
||||
|
||||
|
||||
relativeSymlink :: Path Abs -- ^ the path in which to create the symlink
|
||||
-> Path Abs -- ^ the symlink destination
|
||||
-> ByteString
|
||||
relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
|
||||
relativeSymlink :: FilePath -- ^ the path in which to create the symlink
|
||||
-> FilePath -- ^ the symlink destination
|
||||
-> FilePath
|
||||
relativeSymlink p1 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 ("/" : drop (length common) d2)
|
||||
<> joinPath ([pathSeparator] : drop (length common) d2)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,494 +1,17 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
{-|
|
||||
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
|
||||
|
||||
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
|
||||
-> m (Either ProcessError ())
|
||||
execLogged exe spath args lfile chdir env = 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
|
||||
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 <- 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 -> 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 -> "[ " <> 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
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module GHCup.Utils.File (
|
||||
module GHCup.Utils.File.Common,
|
||||
#if IS_WINDOWS
|
||||
module GHCup.Utils.File.Windows
|
||||
#else
|
||||
module GHCup.Utils.File.Posix
|
||||
#endif
|
||||
) where
|
||||
|
||||
import GHCup.Utils.File.Common
|
||||
#if IS_WINDOWS
|
||||
import GHCup.Utils.File.Windows
|
||||
#else
|
||||
import GHCup.Utils.File.Posix
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -0,0 +1,122 @@
|
|||
{-# 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
|
||||
|
||||
|
|
@ -0,0 +1,368 @@
|
|||
{-# 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
|
||||
|
|
@ -0,0 +1,202 @@
|
|||
{-# 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,14 +8,13 @@ Copyright : (c) Julian Ospald, 2020
|
|||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
Portability : portable
|
||||
|
||||
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
|
||||
|
||||
|
|
@ -23,14 +22,15 @@ 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,19 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
|
|||
rawOutter outr
|
||||
|
||||
|
||||
initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m (Path Abs)
|
||||
initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m FilePath
|
||||
initGHCupFileLogging = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
let logfile = logsDir </> [rel|ghcup.log|]
|
||||
let logfile = logsDir </> "ghcup.log"
|
||||
liftIO $ do
|
||||
createDirRecursive' logsDir
|
||||
createDirectoryIfMissing True logsDir
|
||||
logFiles <- findFiles
|
||||
logsDir
|
||||
(makeRegexOpts compExtended
|
||||
execBlank
|
||||
([s|^.*\.log$|] :: B.ByteString)
|
||||
)
|
||||
forM_ logFiles $ hideError doesNotExistErrorType . deleteFile . (logsDir </>)
|
||||
forM_ logFiles $ hideError doesNotExistErrorType . removeFile . (logsDir </>)
|
||||
|
||||
createRegularFile newFilePerms logfile
|
||||
writeFile logfile ""
|
||||
pure logfile
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ Copyright : (c) Julian Ospald, 2020
|
|||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Utils.MegaParsec where
|
||||
|
||||
|
|
@ -23,6 +23,7 @@ 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
|
||||
|
|
@ -117,3 +118,7 @@ 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 : POSIX
|
||||
Portability : portable
|
||||
|
||||
GHCup specific prelude. Lots of Excepts functionality.
|
||||
-}
|
||||
|
|
@ -32,8 +32,6 @@ 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
|
||||
|
|
@ -242,6 +240,8 @@ 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,14 +252,6 @@ 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 : POSIX
|
||||
Portability : portable
|
||||
|
||||
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 : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
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 : POSIX
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Version where
|
||||
|
||||
|
|
|
|||
26
stack.yaml
26
stack.yaml
|
|
@ -1,4 +1,4 @@
|
|||
resolver: lts-17.4
|
||||
resolver: lts-17.11
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
|
@ -7,6 +7,9 @@ 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
|
||||
|
|
@ -17,16 +20,18 @@ 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
|
||||
- hpath-0.11.0@sha256:12b8405bee13d0007d644a888ef8407069ce7bbbd76970f8746b801447124ade,1440
|
||||
- hpath-directory-0.14.1@sha256:548ac1321222c34caa843a41a2379a77d961141082a4695bb37cc4731e91b2c7,5312
|
||||
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
|
||||
- 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
|
||||
- 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
|
||||
- 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
|
||||
|
|
@ -40,13 +45,8 @@ flags:
|
|||
libarchive:
|
||||
system-libarchive: false
|
||||
|
||||
ghcup:
|
||||
tui: true
|
||||
internal-downloader: true
|
||||
|
||||
system-ghc: true
|
||||
compiler: ghc-8.10.4
|
||||
compiler-check: match-exact
|
||||
regex-posix:
|
||||
_regex-posix-clib: true
|
||||
|
||||
ghc-options:
|
||||
"$locals": -O2
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@ 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
|
||||
|
|
@ -164,11 +163,6 @@ 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue