diff --git a/HACKING.md b/HACKING.md
index 623086be03d53f39451c1a42d7783db26dfcfb61..d30433c1494ca266d1e2fd415a3df69cdf326f88 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 5a1999f62650533aa5e09f37cc1565dcee333c45..72254e1fd8187376768b8ee57d09bfe273d3abde 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 fa8518bca252900b510f255874a9c57e1fdfcd78..9bdb3053daf1b33fc3b2ca11d8739eeffcbbe592 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
@@ -238,7 +237,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 +251,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 d11003c453c21449c56485fabdfbc3f090d363b3..9ea6f75ae5270afeba9516a84f44b9a75962656e 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 4535958f53e594bc4ed0192b324c34f75db7f17a..306d842c0f3602e5f79268edadd69fb012b3ed18 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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
- , rawOutter = appendFile logfile
+ , rawOutter = B.appendFile logfile
}
let runLogger = myLoggerT loggerConfig
@@ -1616,12 +1596,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
Upgrade uOpts force -> do
target <- case uOpts of
- UpgradeInplace -> do
- efp <- liftIO getExecutablePath
- p <- parseAbs . E.encodeUtf8 . T.pack $ efp
- pure $ Just p
+ UpgradeInplace -> Just <$> liftIO getExecutablePath
(UpgradeAt p) -> pure $ Just p
- UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
+ UpgradeGHCupDir -> pure (Just (binDir </> "ghcup"))
runUpgrade (liftE $ upgradeGHCup dls target force pfreq) >>= \case
VRight v' -> do
@@ -1677,12 +1654,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
+ Windows -> "start"
if clOpen
then
exec cmd
- True
- [serializeURIRef' uri]
+ [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing
Nothing
>>= \case
@@ -1977,10 +1954,10 @@ checkForUpdates dls pfreq = do
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = [i|Debug Info
==========
-GHCup base dir: #{toFilePath diBaseDir}
-GHCup bin dir: #{toFilePath diBinDir}
-GHCup GHC directory: #{toFilePath diGHCDir}
-GHCup cache directory: #{toFilePath diCacheDir}
+GHCup base dir: #{diBaseDir}
+GHCup bin dir: #{diBinDir}
+GHCup GHC directory: #{diGHCDir}
+GHCup cache directory: #{diCacheDir}
Architecture: #{prettyShow diArch}
Platform: #{prettyShow diPlatform}
Version: #{describe_result}|]
diff --git a/cabal.project b/cabal.project
index 2e0cbc09ce186976fd672c3269d499810cd2d656..361aa936d864468b8ffc66c263d44342e18c2856 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/hasufell/tar-bytestring
+ tag: 9b5970ca6c924069498e95a8b59cb21e909a9ebe
+
constraints: http-io-streams -brotli
package libarchive
diff --git a/ghcup-0.0.4.yaml b/ghcup-0.0.4.yaml
index 0ea060ed73471f6437785454739508ec48c23a4b..7097842fb68576f4d949660dca527fdb6d8c3819 100644
--- a/ghcup-0.0.4.yaml
+++ b/ghcup-0.0.4.yaml
@@ -1524,6 +1524,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-windows-extra-src.tar.xz
+ dlSubdir: ghc-9.0.1
+ dlHash: 55e27d1907430cfba0f8b6c35c40dbb6f23b0a3518bfa5c9b453ba5cde86030c
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-901-32-deb9
diff --git a/ghcup.cabal b/ghcup.cabal
index c97c29933f567991652136ba22eabb082d5d3ab2..23f51af401ba3f434b26a90a8487e583729cebfd 100644
--- a/ghcup.cabal
+++ b/ghcup.cabal
@@ -58,6 +58,7 @@ library
GHCup.Utils
GHCup.Utils.Dirs
GHCup.Utils.File
+ GHCup.Utils.File.Common
GHCup.Utils.Logger
GHCup.Utils.MegaParsec
GHCup.Utils.Prelude
@@ -96,15 +97,14 @@ library
, concurrent-output ^>=1.10.11
, containers ^>=0.6
, cryptohash-sha256 ^>=0.11.101.0
+ , deepseq
+ , directory
, disk-free-space ^>=0.1.0.1
+ , extra
+ , filepath
, 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 +115,7 @@ library
, parsec ^>=3.1
, pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0
+ , process
, regex-posix ^>=0.96
, resourcet ^>=1.2.2
, safe ^>=0.3.18
@@ -122,22 +123,19 @@ 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
+ , temporary
, template-haskell >=2.7 && <2.17
, 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
, zlib ^>=0.6.2.2
@@ -153,11 +151,28 @@ library
if flag(tar)
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
+ else
+ build-depends:
+ unix ^>=2.7
+ , unix-bytestring
+ , hpath-posix
+ , streamly-posix ^>=0.1.0.0
+ other-modules: GHCup.Utils.File.Posix
+
+ 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 +196,9 @@ executable ghcup
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
+ , filepath
, 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 +218,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:
@@ -214,7 +228,6 @@ executable ghcup
if flag(tar)
cpp-options: -DTAR
-
else
build-depends: libarchive ^>=3.0.0.0
@@ -241,10 +254,9 @@ executable ghcup-gen
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
+ , filepath
, 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
@@ -264,7 +276,7 @@ executable ghcup-gen
if flag(tar)
cpp-options: -DTAR
- build-depends: tar-bytestring ^>=0.6.3.1
+ build-depends: tar
else
build-depends: libarchive ^>=3.0.0.0
@@ -297,7 +309,6 @@ 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
, QuickCheck ^>=2.14.1
diff --git a/lib/GHCup.hs b/lib/GHCup.hs
index 71a6a88bf7b7c406b258aecfbf589dfdce96a534..ebafc1c927ce21034b4bb084f542073e8075e802 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,17 @@ 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 ()
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|]
+ (("--prefix=" <> inst) : alpineArgs)
(Just path)
+ "ghc-configure"
Nothing
lEM $ make ["install"] (Just path)
pure ()
@@ -301,9 +298,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")
)
(throwE $ AlreadyInstalled Cabal ver)
@@ -328,19 +325,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)
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
destPath
- Overwrite
lift $ chmod_755 destPath
@@ -437,8 +433,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 +448,18 @@ installHLSBindist dlinfo ver PlatformRequest{..} = do
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
- toF <- parseRel (toFilePath f <> "~" <> verToBS ver)
+ let toF = f <> "~" <> T.unpack (prettyVer ver)
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)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper)
(inst </> toF)
- Overwrite
lift $ chmod_755 (inst </> toF)
@@ -596,19 +590,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)
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile)
destPath
- Overwrite
lift $ chmod_755 destPath
@@ -640,7 +633,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 +655,47 @@ 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
+ destL <- lift $ ghcLinkDestination file ver
+ 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 $ createFileLink targetF fullF
_ -> pure ()
@@ -714,8 +705,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)
-- symlink destination
AppState {dirs = Dirs {..}} <- lift ask
@@ -725,17 +715,17 @@ setCabal ver = do
$ throwE
$ NotInstalled Cabal (GHCTargetVersion Nothing ver)
- let cabalbin = binDir </> [rel|cabal|]
+ let cabalbin = binDir </> "cabal"
-- 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 +750,32 @@ setHLS ver = do
-- selected version, so we could end up with stray or incorrect symlinks.
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
- lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
- liftIO $ deleteFile (binDir </> f)
+ lift $ $(logDebug) [i|rm #{binDir </> f}|]
+ liftIO $ removeFile (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver
when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
forM_ bins $ \f -> do
- let destL = toFilePath f
- target <- parseRel . head . B.split _tilde . toFilePath $ f
+ let destL = f
+ let target = 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)
+ let wrapper = binDir </> "haskell-language-server-wrapper"
- 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 +785,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)
-- symlink destination
AppState {dirs = Dirs {..}} <- lift ask
@@ -806,17 +795,16 @@ setStack ver = do
$ throwE
$ NotInstalled Stack (GHCTargetVersion Nothing ver)
- let stackbin = binDir </> [rel|stack|]
+ let stackbin = binDir </> "stack"
-- 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 +936,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 +965,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 +993,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 +1021,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 +1144,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 +1159,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 +1174,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))
+ 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")
-- | Delete a hls version. Will try to fix the hls symlinks
@@ -1210,14 +1198,14 @@ 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)
+ lift $ $(logDebug) [i|rm #{binDir </> f}|]
+ liftIO $ removeFile (binDir </> f)
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
@@ -1237,15 +1225,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))
+ 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")
@@ -1290,10 +1278,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 +1329,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 +1350,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 "./boot" [] (Just tmpUnpack) "ghc-bootstrap" Nothing
+ lEM $ execLogged "./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 +1375,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 +1395,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 +1427,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 +1448,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])
+ (\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
+ ( [ "--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 +1493,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 +1503,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 +1520,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 +1555,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 +1575,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"
p <- liftE $ download dli tmp (Just fn)
- let destDir = dirname destFile
+ let destDir = takeFileName 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 0b075b0fa2b75e4d2be3266f2162f199a688b432..5234e67ef81dc21a174c16bae32fb779a176b908 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.
@@ -57,7 +57,7 @@ import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
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 = maybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) id 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 d463fcc178fca06565f3ce898e34d111d56c07d7..8eb94e413909b8b6e8c05933ea7cb535b96e90db 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 f86d6909cb131152a534261d14edc1ec3995fe2a..de9576cb3118e7b88a91ed422598c43e772dcf6d 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 e05ba331a6057180dc68c58b4ae0cfbfe6a68ff4..e36cb5007aec4c6c3923c25a9d6bbba827e810aa 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 a1b4a844f0efe2a7d7eeb7a503f8215ea9cf78f5..31a9ab40b73f5e49d344d84ab485397315c19243 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 4e1ae2cc7b8fb47f5bd989cac9d62c22ca2361cf..3bd8de98a6feee6dab1812d00ab7629d40ef24ef 100644
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -11,26 +11,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)
+ , module Graphics.Vty (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 +170,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 +234,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 +266,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 +321,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 +342,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 390a61b978017e37eb540cdebde0d25e1044b199..39501c9f5be86ebe917cf0e179e459dbe69cc17a 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 2486175c281d1c4edfd1d085f50f7e999a63792f..d971ccd78ed38a4ba720638e64a6a1adf4e45d5f 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 742e12110d92daea8518f77e804afd941365da02..7679e4f0326ac58d70b006d3a7ec486d73ecbcfd 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.
@@ -59,20 +59,12 @@ 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 Text.Regex.Posix
import URI.ByteString
@@ -85,10 +77,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 +91,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 +115,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)
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.
@@ -149,12 +137,12 @@ rmPlain target = 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
+ 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"
+ 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 +162,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 f_xyz = f <> "-" <> T.unpack v'
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
@@ -208,19 +196,17 @@ 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 ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
let ghcBin = binDir </> ghc
-- link destination is of the form ../ghc/<ver>/bin/ghc
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
- link <- 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 -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
where
parser =
(do
@@ -240,10 +226,10 @@ ghcLinkVersion bs = do
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
-getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
+getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir
- fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
+ fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r
Left _ -> pure $ Left f
@@ -251,7 +237,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 +245,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) . stripPrefix "cabal-" $ f of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
@@ -283,8 +269,8 @@ 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"
+ b <- handleIO (\_ -> pure False) $ liftIO $ pathIsSymbolicLink cabalbin
if
| b -> do
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@@ -294,11 +280,11 @@ cabalSet = do
$(logWarn) [i|Symlink #{cabalbin} is broken.|]
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 +292,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 +302,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
parser
= MP.try (stripAbsolutePath *> cabalParse)
@@ -342,7 +326,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 +337,7 @@ getInstalledHLSs = do
)
forM bins $ \f ->
case
- fmap (version . decUTF8Safe) . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f
+ fmap (version . T.pack) . stripPrefix "haskell-language-server-wrapper-" $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
@@ -362,7 +346,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 +357,7 @@ getInstalledStacks = do
)
forM bins $ \f ->
case
- fmap (version . decUTF8Safe) . B.stripPrefix "stack-" . toFilePath $ f
+ fmap (version . T.pack) . stripPrefix "stack-" $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
@@ -384,20 +368,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"
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 fp = throwEither $ MP.parse parser "" (T.pack fp)
where
parser =
MP.chunk "stack-" *> version'
@@ -420,20 +402,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"
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 fp = throwEither $ MP.parse parser "" (T.pack fp)
where
parser =
MP.chunk "haskell-language-server-wrapper-" *> version'
@@ -452,13 +432,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 +445,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
@@ -482,7 +461,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
@@ -501,7 +480,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 +488,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 +498,8 @@ hlsSymlinks = do
([s|^haskell-language-server-.*$|] :: ByteString)
)
filterM
- ( fmap (== SymbolicLink)
- . liftIO
- . getFileType
+ ( liftIO
+ . pathIsSymbolicLink
. (binDir </>)
)
oldSyms
@@ -585,61 +563,59 @@ 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)
| 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,34 +624,34 @@ 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)
| 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))
@@ -743,10 +719,9 @@ getDownloader = ask <&> downloader . settings
-------------
-urlBaseName :: MonadThrow m
- => ByteString -- ^ the url path (without scheme and host)
- -> m (Path Rel)
-urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
+urlBaseName :: ByteString -- ^ the url path (without scheme and host)
+ -> ByteString
+urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
@@ -757,16 +732,16 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
- -> Excepts '[NotInstalled] m [Path Rel]
+ -> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles ver = do
ghcdir <- lift $ ghcupGHCDir ver
- let bindir = ghcdir </> [rel|bin|]
+ let bindir = ghcdir </> "bin"
-- fail if ghc is not installed
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled GHC ver))
- files <- liftIO $ getDirsFiles' bindir
+ files <- liftIO $ listDirectory bindir
-- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate.
@@ -785,75 +760,73 @@ ghcToolFiles ver = do
then pure id
else do
(Just symver) <-
- B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName
- <$> liftIO (readSymbolicLink $ toFilePath ghcbinPath)
- when (B.null symver)
+ stripPrefix (ghcbin <> "-") . takeFileName
+ <$> liftIO (getSymbolicLinkTarget ghcbinPath)
+ when (null symver)
(throwIO $ userError "Fatal: ghc symlink target is broken")
- pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
+ pure $ filter (\x -> not $ symver `isSuffixOf` x)
pure $ onlyUnversioned files
where
-- 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
+ isHadrian :: FilePath -- ^ ghcbin path
-> IO Bool
- isHadrian = fmap (/= SymbolicLink) . getFileType
+ isHadrian = pathIsSymbolicLink
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
-- this GHC was built from source. It contains the build config.
-ghcUpSrcBuiltFile :: Path Rel
-ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
+ghcUpSrcBuiltFile :: FilePath
+ghcUpSrcBuiltFile = ".ghcup_src_built"
-- | Calls gmake if it exists in PATH, otherwise make.
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
- => [ByteString]
- -> Maybe (Path Abs)
+ => [String]
+ -> Maybe (FilePath)
-> m (Either ProcessError ())
make args workdir = do
- spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
- has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
+ spaths <- liftIO getSearchPath
+ has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
let mymake = if has_gmake then "gmake" else "make"
- execLogged mymake True args [rel|ghc-make|] workdir Nothing
+ execLogged mymake args workdir "ghc-make" Nothing
-makeOut :: [ByteString]
- -> Maybe (Path Abs)
+makeOut :: [String]
+ -> Maybe (FilePath)
-> IO CapturedProcess
makeOut args workdir = do
- spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
- has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
- let mymake = if has_gmake then [rel|gmake|] else [rel|make|]
+ spaths <- liftIO getSearchPath
+ has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
+ let mymake = if has_gmake then "gmake" else "make"
liftIO $ executeOut mymake args workdir
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadLogger m, MonadIO m)
- => Path Abs -- ^ dir containing patches
- -> Path Abs -- ^ dir to apply patches in
+ => FilePath -- ^ dir containing patches
+ -> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do
- patches <- liftIO $ getDirsFiles pdir
+ patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) [i|Applying patch #{patch'}|]
fmap (either (const Nothing) Just)
(liftIO $ exec
"patch"
- True
- ["-p1", "-i", toFilePath patch']
+ ["-p1", "-i", patch']
(Just ddir)
Nothing)
!? PatchFailed
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
-darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
+darwinNotarization :: Platform -> FilePath -> IO (Either ProcessError ())
darwinNotarization Darwin path = exec
"xattr"
- True
- ["-r", "-d", "com.apple.quarantine", toFilePath path]
+ ["-r", "-d", "com.apple.quarantine", path]
Nothing
Nothing
darwinNotarization _ _ = pure $ Right ()
@@ -871,19 +844,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,28 +865,28 @@ 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
diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs
index 2838c52f7e745c189889d0167807c76e502d9175..61266e6216430830c377277a43cd3fca741013b4 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 qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.UTF8 as UTF8
+import System.Environment
+import System.FilePath
+import System.IO.Temp
+
+import qualified Data.ByteString as BS
import qualified Data.Text as T
-import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
-import qualified System.Posix.FilePath as FP
-import qualified System.Posix.User as PU
import qualified Text.Megaparsec as MP
import Control.Concurrent (threadDelay)
@@ -82,96 +70,96 @@ import Control.Concurrent (threadDelay)
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
-ghcupBaseDir :: IO (Path Abs)
+ghcupBaseDir :: IO FilePath
ghcupBaseDir = do
xdg <- useXDG
if xdg
then do
- bdir <- getEnv "XDG_DATA_HOME" >>= \case
- Just r -> parseAbs r
+ bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
+ Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
- pure (home </> [rel|.local/share|])
- pure (bdir </> [rel|ghcup|])
+ pure (home </> ".local/share")
+ pure (bdir </> "ghcup")
else do
- bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
- Just r -> parseAbs r
+ bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+ Just r -> pure r
Nothing -> liftIO getHomeDirectory
- pure (bdir </> [rel|.ghcup|])
+ pure (bdir </> ".ghcup")
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
-ghcupConfigDir :: IO (Path Abs)
+ghcupConfigDir :: IO FilePath
ghcupConfigDir = do
xdg <- useXDG
if xdg
then do
- bdir <- getEnv "XDG_CONFIG_HOME" >>= \case
- Just r -> parseAbs r
+ bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
+ Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
- pure (home </> [rel|.config|])
- pure (bdir </> [rel|ghcup|])
+ pure (home </> ".config")
+ pure (bdir </> "ghcup")
else do
- bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
- Just r -> parseAbs r
+ bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+ Just r -> pure r
Nothing -> liftIO getHomeDirectory
- pure (bdir </> [rel|.ghcup|])
+ pure (bdir </> ".ghcup")
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
-- (which, sadly is not strictly xdg spec).
-ghcupBinDir :: IO (Path Abs)
+ghcupBinDir :: IO FilePath
ghcupBinDir = do
xdg <- useXDG
if xdg
then do
- getEnv "XDG_BIN_HOME" >>= \case
- Just r -> parseAbs r
+ lookupEnv "XDG_BIN_HOME" >>= \case
+ Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
- pure (home </> [rel|.local/bin|])
- else ghcupBaseDir <&> (</> [rel|bin|])
+ pure (home </> ".local/bin")
+ else ghcupBaseDir <&> (</> "bin")
-- | Defaults to '~/.ghcup/cache'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
-ghcupCacheDir :: IO (Path Abs)
+ghcupCacheDir :: IO FilePath
ghcupCacheDir = do
xdg <- useXDG
if xdg
then do
- bdir <- getEnv "XDG_CACHE_HOME" >>= \case
- Just r -> parseAbs r
+ bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+ Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
- pure (home </> [rel|.cache|])
- pure (bdir </> [rel|ghcup|])
- else ghcupBaseDir <&> (</> [rel|cache|])
+ pure (home </> ".cache")
+ pure (bdir </> "ghcup")
+ else ghcupBaseDir <&> (</> "cache")
-- | Defaults to '~/.ghcup/logs'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
-ghcupLogsDir :: IO (Path Abs)
+ghcupLogsDir :: IO FilePath
ghcupLogsDir = do
xdg <- useXDG
if xdg
then do
- bdir <- getEnv "XDG_CACHE_HOME" >>= \case
- Just r -> parseAbs r
+ bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+ Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
- pure (home </> [rel|.cache|])
- pure (bdir </> [rel|ghcup/logs|])
- else ghcupBaseDir <&> (</> [rel|logs|])
+ pure (home </> ".cache")
+ pure (bdir </> "ghcup/logs")
+ else ghcupBaseDir <&> (</> "logs")
getDirs :: IO Dirs
@@ -194,11 +182,11 @@ ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings
ghcupConfigFile = do
confDir <- liftIO ghcupConfigDir
- let file = confDir </> [rel|config.yaml|]
- bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
- case bs of
+ let file = confDir </> "config.yaml"
+ contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile file
+ case contents of
Nothing -> pure defaultUserSettings
- Just bs' -> lE' JSONDecodeError . first show . Y.decodeEither' . L.toStrict $ bs'
+ Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
-------------------------
@@ -207,10 +195,10 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default.
-ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
+ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
ghcupGHCBaseDir = do
AppState { dirs = Dirs {..} } <- ask
- pure (baseDir </> [rel|ghc|])
+ pure (baseDir </> "ghc")
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
@@ -219,35 +207,33 @@ 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 $ fromMaybe "/tmp" <$> lookupEnv "TMPDIR"
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
+ tmp <- liftIO $ createTempDirectory tmpdir "ghcup-"
+ pure tmp
where
toBytes mb = mb * 1024 * 1024
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
@@ -256,8 +242,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,24 +253,14 @@ 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
diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs
index e782839d70895b523bcbe184b6febcda8e2ab17d..9f74867fa913281514596f259b9e3d0ff272d13d 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 0000000000000000000000000000000000000000..5b7918ec27af33981c9ef838466a70bd037a8532
--- /dev/null
+++ b/lib/GHCup/Utils/File/Common.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module GHCup.Utils.File.Common where
+
+import GHCup.Utils.Prelude
+import GHCup.Types
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.DeepSeq
+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 Foreign.C.Error
+import GHC.IO.Exception
+import GHC.IO.Handle
+import Optics hiding ((<|), (|>))
+import System.Console.Pretty hiding ( Pretty )
+import System.Console.Regions
+import System.IO
+import System.IO.Error
+import System.Process
+import System.Posix.Types
+import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
+import Text.Regex.Posix
+
+
+import System.Directory
+import System.FilePath
+import Control.Monad.Extra
+
+
+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 Streamly.External.Posix.DirStream
+import qualified Streamly.Prelude as S
+import qualified Text.Megaparsec as MP
+import qualified Data.ByteString as BS
+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
+
+
+findFiles' :: FilePath -> MP.Parsec Void Text () -> IO [FilePath]
+findFiles' path parser = do
+ contents <- listDirectory path
+ pure $ fmap T.unpack $ filter (isJust . MP.parseMaybe parser) (fmap T.pack contents)
+
+
+isBrokenSymlink :: FilePath -> IO Bool
+isBrokenSymlink p =
+ handleIO
+ (\e -> if ioeGetErrorType e == NoSuchThing then pure True else throwIO e)
+ $ do
+ _ <- canonicalizePath p
+ pure False
+
diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs
new file mode 100644
index 0000000000000000000000000000000000000000..8dfb1848d3c1da6ba0b9b79742799021f2145db8
--- /dev/null
+++ b/lib/GHCup/Utils/File/Posix.hs
@@ -0,0 +1,379 @@
+{-# 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.Functor
+import Data.IORef
+import Data.Maybe
+import Data.Sequence ( Seq, (|>) )
+import Data.String.Interpolate
+import Data.List
+import Data.Text ( Text )
+import Data.Void
+import Data.Word8
+import GHC.IO.Exception
+import Optics hiding ((<|), (|>))
+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.Foreign ( oExcl, oAppend )
+import System.Posix.IO
+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 as SPP
+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 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 (if "./" `isPrefixOf` exe then False else True) 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 (if "./" `isPrefixOf` exe then False else True) 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 0000000000000000000000000000000000000000..618239f168320b37fdb8604a82d41c27965c2a52
--- /dev/null
+++ b/lib/GHCup/Utils/File/Windows.hs
@@ -0,0 +1,225 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-|
+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.Utils.Prelude
+import GHCup.Types
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.DeepSeq
+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 Foreign.C.Error
+import GHC.IO.Exception
+import GHC.IO.Handle
+import Optics hiding ((<|), (|>))
+import System.Console.Pretty hiding ( Pretty )
+import System.Console.Regions
+import System.IO
+import System.IO.Error
+import System.Process
+import System.Posix.Types
+import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
+import Text.Regex.Posix
+
+
+import System.Directory
+import System.FilePath.Windows
+import Control.Monad.Extra
+
+
+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 Streamly.External.Posix.DirStream
+import qualified Streamly.Prelude as S
+import qualified Text.Megaparsec as MP
+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 -- ^ standard input
+ -> 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 <- BL.hGetContents outh
+ err <- BL.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, out, 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, std_in = NoStream } ""
+ 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 { settings = Settings {..}, 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 = NoStream }
+ $ \_ (Just cStdout) (Just cStderr) ph -> do
+ withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
+ withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
+ waitOut
+ waitErr
+ waitForProcess ph
+
+ where
+ tee :: FilePath -> Handle -> IO ()
+ tee logFile handle = do
+ some <- BS.hGetSome handle 512
+ if BS.null some
+ then pure ()
+ else do
+ void $ BS.appendFile logFile some
+ void $ BS.hPut stdout some
+ tee logFile handle
+
+
+-- | 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, out, err) <- readCreateProcessWithExitCodeBS (proc exe args){ cwd = chdir, std_in = NoStream, env = env } ""
+ pure $ toProcessError exe args exit
+
+
+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 5f84c397c1d7b65e9d131b4b8a6f73964026796d..1c5555a1139c1c51a2c360b176a9dbfeaf2b656a 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 c92762cc0f329e9a038c3ecd629d0111d2996c46..94e2d7eba219c9a1948a34db837ea5ac29f4eec0 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
diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs
index a270e20de3e798efe6116f6ef68aefe3a41a5654..47ad7ab9cf4c9681f7228099759c10f273151e52 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 85f566f7ce1ad877605cca396e9893f4ffe8694c..a47bb410de6b325cafb5af0d827b7a606a18786c 100644
--- a/lib/GHCup/Utils/String/QQ.hs
+++ b/lib/GHCup/Utils/String/QQ.hs
@@ -7,7 +7,7 @@ Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufel
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
-Portability : POSIX
+Portability : portable
QuasiQuoter for non-interpolated strings, texts and bytestrings.
diff --git a/lib/GHCup/Utils/Version/QQ.hs b/lib/GHCup/Utils/Version/QQ.hs
index 9523db95ccd7db9974272d4807ff187c1021b6f7..e16d9a8cc9a08e7edd5a5428d4af84b5cae5ca7f 100644
--- a/lib/GHCup/Utils/Version/QQ.hs
+++ b/lib/GHCup/Utils/Version/QQ.hs
@@ -14,7 +14,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
-Portability : POSIX
+Portability : portable
-}
module GHCup.Utils.Version.QQ where
diff --git a/lib/GHCup/Version.hs b/lib/GHCup/Version.hs
index 2cb8030f675cdfc2044f25a0cdf1893630b0b0b0..03944a579a893a346e2a07a0a1b5723fe224b38b 100644
--- a/lib/GHCup/Version.hs
+++ b/lib/GHCup/Version.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.Version where
diff --git a/stack.yaml b/stack.yaml
index c7a0937e6f325c0753d590e07cfd129b0d181522..9bf2d609602ed71f3323201b9492cc82cc93d8a9 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -7,6 +7,9 @@ extra-deps:
- git: https://github.com/hasufell/text-conversions.git
commit: 9abf0e5e5664a3178367597c32db19880477a53c
+ - git: https://github.com/hasufell/tar-bytestring
+ commit: 9b5970ca6c924069498e95a8b59cb21e909a9ebe
+
- IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
- ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
- brotli-0.0.0.0@sha256:2bf383a4cd308745740986be0b18381c5a0784393fe69b91456aacb2d603de46,2964
@@ -17,12 +20,9 @@ extra-deps:
- haskus-utils-data-1.3@sha256:f62c4e49021b463185d043f7b69c727b63af641a71d7edd582d9f4f98e80e500,1466
- haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
- haskus-utils-variant-3.0@sha256:8d51e45d3b664e61ccc25a58b37c0ccc4ee7537138b9fee21cd15c356906dd34,2159
- - hpath-0.11.0@sha256:12b8405bee13d0007d644a888ef8407069ce7bbbd76970f8746b801447124ade,1440
- - hpath-directory-0.14.1@sha256:548ac1321222c34caa843a41a2379a77d961141082a4695bb37cc4731e91b2c7,5312
+ - http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
- - hpath-io-0.14.1@sha256:d91373cd81483eb370a1c683e4add6182250dccce32f9b682bb1104f7765c750,1522
- hpath-posix-0.13.2@sha256:eec4ff2b00dc86be847aca0f409fc8f6212ffd2170ec36a17dc9a52b46562392,1615
- - http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
- lzma-static-5.2.5.2@sha256:ac38dcad9ab423342a72ba48415bd75f62234e9c9e11831495b75603b5a060f6,7184
- libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
@@ -36,13 +36,10 @@ extra-deps:
flags:
http-io-streams:
brotli: false
-
libarchive:
system-libarchive: false
-
- ghcup:
- tui: true
- internal-downloader: true
+ regex-posix:
+ _regex-posix-clib: true
system-ghc: true
compiler: ghc-8.10.4
diff --git a/test/GHCup/ArbitraryTypes.hs b/test/GHCup/ArbitraryTypes.hs
index e7179183e2ebbbacf334c7f138e07eec7719c9d4..1f536987f1ca72222a3338f381733a6f7254d966 100644
--- a/test/GHCup/ArbitraryTypes.hs
+++ b/test/GHCup/ArbitraryTypes.hs
@@ -11,7 +11,6 @@ import GHCup.Types
import Data.ByteString ( ByteString )
import Data.Versions
import Data.List.NonEmpty
-import HPath
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary )
import Test.QuickCheck.Arbitrary.Generic
@@ -164,11 +163,6 @@ instance Arbitrary VersionCmp where
arbitrary = genericArbitrary
shrink = genericShrink
-instance Arbitrary (Path Rel) where
- arbitrary =
- either (error . show) id . parseRel . E.encodeUtf8 . T.pack
- <$> listOf1 (elements ['a' .. 'z'])
-
instance Arbitrary TarDir where
arbitrary = genericArbitrary
shrink = genericShrink