From 2c3ebe706d44312ff7e70052c869d5ccb44237b7 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 14 May 2021 23:09:45 +0200 Subject: [PATCH] Windows support --- .../linux/alpine/install_deps.sh | 3 + .gitlab/before_script/linux/install_deps.sh | 2 +- .../linux/install_deps_manual.sh | 2 +- .../linux/install_deps_minimal.sh | 2 +- .gitlab/script/ghcup_version.sh | 12 +- HACKING.md | 4 - README.md | 2 +- app/ghcup-gen/Validate.hs | 11 +- app/ghcup/BrickMain.hs | 4 +- app/ghcup/Main.hs | 63 +-- cabal.project | 5 + ghcup-0.0.4.yaml | 150 +++++ ghcup.cabal | 71 ++- lib/GHCup.hs | 317 ++++++----- lib/GHCup/Download.hs | 126 ++--- lib/GHCup/Download/IOStreams.hs | 15 +- lib/GHCup/Errors.hs | 21 +- lib/GHCup/Platform.hs | 37 +- lib/GHCup/Requirements.hs | 2 +- lib/GHCup/Types.hs | 107 ++-- lib/GHCup/Types/JSON.hs | 24 +- lib/GHCup/Types/Optics.hs | 2 +- lib/GHCup/Utils.hs | 438 ++++++++------- lib/GHCup/Utils/Dirs.hs | 153 +++--- lib/GHCup/Utils/File.hs | 511 +----------------- lib/GHCup/Utils/File/Common.hs | 122 +++++ lib/GHCup/Utils/File/Posix.hs | 368 +++++++++++++ lib/GHCup/Utils/File/Windows.hs | 202 +++++++ lib/GHCup/Utils/Logger.hs | 18 +- lib/GHCup/Utils/MegaParsec.hs | 7 +- lib/GHCup/Utils/Prelude.hs | 14 +- lib/GHCup/Utils/String/QQ.hs | 2 +- lib/GHCup/Utils/Version/QQ.hs | 2 +- lib/GHCup/Version.hs | 2 +- stack.yaml | 26 +- test/GHCup/ArbitraryTypes.hs | 6 - 36 files changed, 1615 insertions(+), 1238 deletions(-) create mode 100644 lib/GHCup/Utils/File/Common.hs create mode 100644 lib/GHCup/Utils/File/Posix.hs create mode 100644 lib/GHCup/Utils/File/Windows.hs diff --git a/.gitlab/before_script/linux/alpine/install_deps.sh b/.gitlab/before_script/linux/alpine/install_deps.sh index 8c80c27..34bdae2 100755 --- a/.gitlab/before_script/linux/alpine/install_deps.sh +++ b/.gitlab/before_script/linux/alpine/install_deps.sh @@ -41,6 +41,9 @@ apk add --no-cache \ zlib \ zlib-dev \ zlib-static \ + bzip2 \ + bzip2-dev \ + bzip2-static \ gmp \ gmp-dev \ openssl-dev \ diff --git a/.gitlab/before_script/linux/install_deps.sh b/.gitlab/before_script/linux/install_deps.sh index 8a2a6cb..ed7e5c0 100755 --- a/.gitlab/before_script/linux/install_deps.sh +++ b/.gitlab/before_script/linux/install_deps.sh @@ -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 diff --git a/.gitlab/before_script/linux/install_deps_manual.sh b/.gitlab/before_script/linux/install_deps_manual.sh index bd22343..11ad1eb 100755 --- a/.gitlab/before_script/linux/install_deps_manual.sh +++ b/.gitlab/before_script/linux/install_deps_manual.sh @@ -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 diff --git a/.gitlab/before_script/linux/install_deps_minimal.sh b/.gitlab/before_script/linux/install_deps_minimal.sh index 5dcff27..6330538 100755 --- a/.gitlab/before_script/linux/install_deps_minimal.sh +++ b/.gitlab/before_script/linux/install_deps_minimal.sh @@ -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 diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 6cae4bf..03344ec 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -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 diff --git a/HACKING.md b/HACKING.md index 623086b..d30433c 100644 --- a/HACKING.md +++ b/HACKING.md @@ -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. diff --git a/README.md b/README.md index 5a1999f..72254e1 100644 --- a/README.md +++ b/README.md @@ -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? diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index fa8518b..6e6e2b4 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -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 diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index d11003c..9ea6f75 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 4535958..306d842 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 |] 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}|] diff --git a/cabal.project b/cabal.project index 2e0cbc0..63683df 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/ghcup-0.0.4.yaml b/ghcup-0.0.4.yaml index 0ea060e..deb6eea 100644 --- a/ghcup-0.0.4.yaml +++ b/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 diff --git a/ghcup.cabal b/ghcup.cabal index c97c299..0754616 100644 --- a/ghcup.cabal +++ b/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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 71a6a88..3608d10 100644 --- a/lib/GHCup.hs +++ b/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/\@ 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- 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 diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 0b075b0..0ea5e1d 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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 [] diff --git a/lib/GHCup/Download/IOStreams.hs b/lib/GHCup/Download/IOStreams.hs index d463fcc..8eb94e4 100644 --- a/lib/GHCup/Download/IOStreams.hs +++ b/lib/GHCup/Download/IOStreams.hs @@ -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 diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index f86d690..de9576c 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -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 diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index e05ba33..e36cb50 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -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) diff --git a/lib/GHCup/Requirements.hs b/lib/GHCup/Requirements.hs index a1b4a84..31a9ab4 100644 --- a/lib/GHCup/Requirements.hs +++ b/lib/GHCup/Requirements.hs @@ -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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 4e1ae2c..77bb4a6 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 } diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 390a61b..39501c9 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -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] diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index 2486175..d971ccd 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 742e121..ebde758 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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//bin/ghc -- for old ghcup, it is ../ghc//bin/ghc- 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/. -- 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\/\\/bin\/\*@ -- while ignoring @*-\@ 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 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\/\\/@ 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 + diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 2838c52..c1468b0 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -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/'. @@ -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) diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index e782839..9f74867 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -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 diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs new file mode 100644 index 0000000..1897ced --- /dev/null +++ b/lib/GHCup/Utils/File/Common.hs @@ -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 + diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs new file mode 100644 index 0000000..006fd60 --- /dev/null +++ b/lib/GHCup/Utils/File/Posix.hs @@ -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 diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs new file mode 100644 index 0000000..0975cfe --- /dev/null +++ b/lib/GHCup/Utils/File/Windows.hs @@ -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 diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 5f84c39..1c5555a 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -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 diff --git a/lib/GHCup/Utils/MegaParsec.hs b/lib/GHCup/Utils/MegaParsec.hs index c92762c..b622eb8 100644 --- a/lib/GHCup/Utils/MegaParsec.hs +++ b/lib/GHCup/Utils/MegaParsec.hs @@ -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 diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index a270e20..47ad7ab 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -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 diff --git a/lib/GHCup/Utils/String/QQ.hs b/lib/GHCup/Utils/String/QQ.hs index 85f566f..a47bb41 100644 --- a/lib/GHCup/Utils/String/QQ.hs +++ b/lib/GHCup/Utils/String/QQ.hs @@ -7,7 +7,7 @@ Copyright : (c) Audrey Tang 2019, Julian Ospald listOf1 (elements ['a' .. 'z']) - instance Arbitrary TarDir where arbitrary = genericArbitrary shrink = genericShrink