hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Windows support

Browse Source
This commit is contained in:
Julian Ospald
2021-05-14 23:09:45 +02:00
parent b94a4123eb
commit 2c3ebe706d
36 changed files with 1615 additions and 1238 deletions
Download Patch File Download Diff File Expand all files Collapse all files

317
lib/GHCup.hs
View File

@@ -18,7 +18,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
This module contains the main functions that correspond
to the command line interface, like installation, listing versions
@@ -58,6 +58,7 @@ import Control.Monad.Trans.Resource
import Data.ByteString ( ByteString )
import Data.Either
import Data.List
import Data.List.Extra
import Data.Maybe
import Data.String ( fromString )
import Data.String.Interpolate
@@ -65,10 +66,7 @@ import Data.Text ( Text )
import Data.Time.Clock
import Data.Time.Format.ISO8601
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO hiding ( hideError )
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
@@ -76,10 +74,10 @@ import Prelude hiding ( abs
, writeFile
)
import Safe hiding ( at )
import System.Directory hiding ( findFiles )
import System.Environment
import System.FilePath
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment, getEnv )
import System.Posix.FilePath ( getSearchPath, takeExtension )
import System.Posix.Files.ByteString
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
@@ -149,7 +147,7 @@ installGHCBindist dlinfo ver pfreq = do
where
toolchainSanityChecks = do
r <- forM ["CC", "LD"] (liftIO . getEnv)
r <- forM ["CC", "LD"] (liftIO . lookupEnv)
case catMaybes r of
[] -> pure ()
_ -> do
@@ -168,9 +166,9 @@ installPackedGHC :: ( MonadMask m
, MonadIO m
, MonadUnliftIO m
)
=> Path Abs -- ^ Path to the packed GHC bindist
=> FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive
-> Path Abs -- ^ Path to install to
-> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version
-> PlatformRequest
-> Excepts
@@ -204,18 +202,24 @@ installUnpackedGHC :: ( MonadReader AppState m
, MonadLogger m
, MonadIO m
)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version
-> PlatformRequest
-> Excepts '[ProcessError] m ()
#if defined(IS_WINDOWS)
installUnpackedGHC path inst _ _ = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
-- windows bindists are relocatable and don't need
-- to run configure
liftIO $ copyDirectoryRecursive path inst
#else
installUnpackedGHC path inst ver PlatformRequest{..} = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "./configure"
False
(("--prefix=" <> toFilePath inst) : alpineArgs)
[rel|ghc-configure|]
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst) : alpineArgs)
(Just path)
"ghc-configure"
Nothing
lEM $ make ["install"] (Just path)
pure ()
@@ -225,6 +229,7 @@ installUnpackedGHC path inst ver PlatformRequest{..} = do
= ["--disable-ld-override"]
| otherwise
= []
#endif
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@@ -301,9 +306,9 @@ installCabalBindist dlinfo ver PlatformRequest {..} = do
whenM
(lift (cabalInstalled ver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x)
$ fmap (\x -> a && x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
$ pathIsSymbolicLink (binDir </> "cabal" <> exeExt)
)
(throwE $ AlreadyInstalled Cabal ver)
@@ -328,19 +333,18 @@ installCabalBindist dlinfo ver PlatformRequest {..} = do
where
-- | Install an unpacked cabal distribution.
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> Path Abs -- ^ Path to install to
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m ()
installCabal' path inst = do
lift $ $(logInfo) "Installing cabal"
let cabalFile = [rel|cabal|]
let cabalFile = "cabal"
liftIO $ createDirRecursive' inst
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
(path </> cabalFile <> exeExt)
destPath
Overwrite
lift $ chmod_755 destPath
@@ -437,8 +441,8 @@ installHLSBindist dlinfo ver PlatformRequest{..} = do
where
-- | Install an unpacked hls distribution.
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked hls bindist (where the executable resides)
-> Path Abs -- ^ Path to install to
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m ()
installHLS' path inst = do
lift $ $(logInfo) "Installing HLS"
@@ -452,20 +456,19 @@ installHLSBindist dlinfo ver PlatformRequest{..} = do
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
toF <- parseRel (toFilePath f <> "~" <> verToBS ver)
let toF = dropSuffix exeExt f
<> "~" <> T.unpack (prettyVer ver) <> exeExt
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> f)
(inst </> toF)
Overwrite
lift $ chmod_755 (inst </> toF)
-- install haskell-language-server-wrapper
let wrapper = [rel|haskell-language-server-wrapper|]
toF <- parseRel (toFilePath wrapper <> "-" <> verToBS ver)
let wrapper = "haskell-language-server-wrapper"
toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper)
(path </> wrapper <> exeExt)
(inst </> toF)
Overwrite
lift $ chmod_755 (inst </> toF)
@@ -596,19 +599,18 @@ installStackBindist dlinfo ver PlatformRequest {..} = do
where
-- | Install an unpacked stack distribution.
installStack' :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked stack bindist (where the executable resides)
-> Path Abs -- ^ Path to install to
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Excepts '[CopyError] m ()
installStack' path inst = do
lift $ $(logInfo) "Installing stack"
let stackFile = [rel|stack|]
let stackFile = "stack"
liftIO $ createDirRecursive' inst
destFileName <- lift $ parseRel (toFilePath stackFile <> "-" <> verToBS ver)
let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile)
(path </> stackFile <> exeExt)
destPath
Overwrite
lift $ chmod_755 destPath
@@ -640,7 +642,7 @@ setGHC :: ( MonadReader AppState m
-> SetGHC
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC ver sghc = do
let verBS = verToBS (_tvVersion ver)
let verS = T.unpack $ prettyVer (_tvVersion ver)
ghcdir <- lift $ ghcupGHCDir ver
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
@@ -662,49 +664,50 @@ setGHC ver sghc = do
mTargetFile <- case sghc of
SetGHCOnly -> pure $ Just file
SetGHC_XY -> do
v' <-
handle
handle
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM v' $ \(mj, mi) ->
let major' = E.encodeUtf8 $ intToText mj <> "." <> intToText mi
in parseRel (toFilePath file <> B.singleton _hyphen <> major')
$ do
(mj, mi) <- getMajorMinorV (_tvVersion ver)
let major' = intToText mj <> "." <> intToText mi
pure $ Just (file <> "-" <> T.unpack major')
SetGHC_XYZ ->
fmap Just $ parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
pure $ Just (file <> "-" <> verS)
-- create symlink
forM mTargetFile $ \targetFile -> do
let fullF = binDir </> targetFile
destL <- lift $ ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
let fullF = binDir </> targetFile <> exeExt
fileWithExt = file <> exeExt
destL <- lift $ ghcLinkDestination fileWithExt ver
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
lift $ $(logDebug) [i|ln -s #{destL} #{fullF}|]
liftIO $ createFileLink destL fullF
-- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
pure ver
where
symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m)
=> Path Abs
-> ByteString
=> FilePath
-> String
-> m ()
symlinkShareDir ghcdir verBS = do
symlinkShareDir ghcdir ver' = do
AppState { dirs = Dirs {..} } <- ask
let destdir = baseDir
case sghc of
SetGHCOnly -> do
let sharedir = [rel|share|]
let sharedir = "share"
let fullsharedir = ghcdir </> sharedir
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
let fullF = destdir </> sharedir
let targetF = "./ghc/" <> verBS <> "/" <> toFilePath sharedir
let targetF = "." </> "ghc" </> ver' </> sharedir
$(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
liftIO $ createSymlink fullF targetF
liftIO $ createDirectoryLink targetF fullF
_ -> pure ()
@@ -714,8 +717,7 @@ setCabal :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, M
=> Version
-> Excepts '[NotInstalled] m ()
setCabal ver = do
let verBS = verToBS ver
targetFile <- parseRel ("cabal-" <> verBS)
let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination
AppState {dirs = Dirs {..}} <- lift ask
@@ -725,17 +727,17 @@ setCabal ver = do
$ throwE
$ NotInstalled Cabal (GHCTargetVersion Nothing ver)
let cabalbin = binDir </> [rel|cabal|]
let cabalbin = binDir </> "cabal" <> exeExt
-- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile
lift $ $(logDebug) [i|rm -f #{cabalbin}|]
liftIO $ hideError doesNotExistErrorType $ removeFile
cabalbin
-- create symlink
let destL = toFilePath targetFile
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath cabalbin}|]
liftIO $ createSymlink cabalbin destL
let destL = targetFile
lift $ $(logDebug) [i|ln -s #{destL} #{cabalbin}|]
liftIO $ createFileLink destL cabalbin
pure ()
@@ -760,32 +762,32 @@ setHLS ver = do
-- selected version, so we could end up with stray or incorrect symlinks.
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
liftIO $ deleteFile (binDir </> f)
lift $ $(logDebug) [i|rm #{binDir </> f}|]
liftIO $ removeFile (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver
when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
forM_ bins $ \f -> do
let destL = toFilePath f
target <- parseRel . head . B.split _tilde . toFilePath $ f
let destL = f
let target = (<> exeExt) . head . splitOn "~" $ f
lift $ $(logDebug) [i|rm -f #{toFilePath (binDir </> target)}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> target)
lift $ $(logDebug) [i|rm -f #{binDir </> target}|]
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> target)
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath (binDir </> target)}|]
liftIO $ createSymlink (binDir </> target) destL
lift $ $(logDebug) [i|ln -s #{destL} #{binDir </> target}|]
liftIO $ createFileLink destL (binDir </> target)
-- set haskell-language-server-wrapper symlink
let destL = "haskell-language-server-wrapper-" <> verToBS ver
let wrapper = binDir </> [rel|haskell-language-server-wrapper|]
let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
lift $ $(logDebug) [i|rm -f #{toFilePath wrapper}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile wrapper
lift $ $(logDebug) [i|rm -f #{wrapper}|]
liftIO $ hideError doesNotExistErrorType $ removeFile wrapper
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath wrapper}|]
liftIO $ createSymlink wrapper destL
lift $ $(logDebug) [i|ln -s #{destL} #{wrapper}|]
liftIO $ createFileLink destL wrapper
pure ()
@@ -795,8 +797,7 @@ setStack :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, M
=> Version
-> Excepts '[NotInstalled] m ()
setStack ver = do
let verBS = verToBS ver
targetFile <- parseRel ("stack-" <> verBS)
let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-- symlink destination
AppState {dirs = Dirs {..}} <- lift ask
@@ -806,17 +807,16 @@ setStack ver = do
$ throwE
$ NotInstalled Stack (GHCTargetVersion Nothing ver)
let stackbin = binDir </> [rel|stack|]
let stackbin = binDir </> "stack" <> exeExt
-- delete old file (may be binary or symlink)
lift $ $(logDebug) [i|rm -f #{toFilePath stackbin}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile
lift $ $(logDebug) [i|rm -f #{stackbin}|]
liftIO $ hideError doesNotExistErrorType $ removeFile
stackbin
-- create symlink
let destL = toFilePath targetFile
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath stackbin}|]
liftIO $ createSymlink stackbin destL
lift $ $(logDebug) [i|ln -s #{targetFile} #{stackbin}|]
liftIO $ createFileLink targetFile stackbin
pure ()
@@ -948,13 +948,13 @@ listVersions av lt' criteria pfreq = do
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
[i|Could not parse version of stray directory #{e}|]
pure Nothing
strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> Maybe Version
-> [Either (Path Rel) Version]
-> [Either FilePath Version]
-> m [ListResult]
strayCabals avTools cSet cabals = do
fmap catMaybes $ forM cabals $ \case
@@ -977,7 +977,7 @@ listVersions av lt' criteria pfreq = do
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
[i|Could not parse version of stray directory #{e}|]
pure Nothing
strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
@@ -1005,7 +1005,7 @@ listVersions av lt' criteria pfreq = do
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
[i|Could not parse version of stray directory #{e}|]
pure Nothing
strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
@@ -1033,18 +1033,18 @@ listVersions av lt' criteria pfreq = do
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
[i|Could not parse version of stray directory #{e}|]
pure Nothing
-- NOTE: this are not cross ones, because no bindists
toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> Tool
-> Maybe Version
-> [Either (Path Rel) Version]
-> [Either FilePath Version]
-> Maybe Version
-> [Either (Path Rel) Version]
-> [Either FilePath Version]
-> Maybe Version
-> [Either (Path Rel) Version]
-> [Either FilePath Version]
-> (Version, [Tag])
-> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = case t of
@@ -1156,8 +1156,8 @@ rmGHCVer ver = do
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|]
liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
liftIO $ removeDirectoryRecursive dir
v' <-
handle
@@ -1171,7 +1171,7 @@ rmGHCVer ver = do
liftIO
$ hideError doesNotExistErrorType
$ deleteFile (baseDir </> [rel|share|])
$ removeFile (baseDir </> "share")
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
@@ -1186,15 +1186,15 @@ rmCabalVer ver = do
AppState {dirs = Dirs {..}} <- lift ask
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> cabalFile)
when (Just ver == cSet) $ do
cVers <- lift $ fmap rights getInstalledCabals
case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
(binDir </> [rel|cabal|])
Nothing -> liftIO $ hideError doesNotExistErrorType $ removeFile
(binDir </> "cabal" <> exeExt)
-- | Delete a hls version. Will try to fix the hls symlinks
@@ -1210,14 +1210,15 @@ rmHLSVer ver = do
AppState {dirs = Dirs {..}} <- lift ask
bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
forM_ bins $ \f -> liftIO $ removeFile (binDir </> f)
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
liftIO $ deleteFile (binDir </> f)
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) [i|rm #{fullF}|]
liftIO $ removeFile fullF
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
@@ -1237,15 +1238,15 @@ rmStackVer ver = do
AppState {dirs = Dirs {..}} <- lift ask
stackFile <- lift $ parseRel ("stack-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> stackFile)
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> stackFile)
when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks
case headMay . reverse . sort $ sVers of
Just latestver -> setStack latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
(binDir </> [rel|stack|])
Nothing -> liftIO $ hideError doesNotExistErrorType $ removeFile
(binDir </> "stack" <> exeExt)
@@ -1290,10 +1291,10 @@ compileGHC :: ( MonadMask m
)
=> GHCupDownloads
-> Either GHCTargetVersion GitBranch -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Either Version FilePath -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
-> Maybe (Path Abs) -- ^ build config
-> Maybe (Path Abs) -- ^ patch directory
-> Maybe FilePath -- ^ build config
-> Maybe FilePath -- ^ patch directory
-> [Text] -- ^ additional args to ./configure
-> PlatformRequest
-> Excepts
@@ -1341,7 +1342,7 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
-- clone from git
Right GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
lift $ $(logInfo) [i|Fetching git repo #{rep} at ref #{ref} (this may take a while)|]
@@ -1362,13 +1363,13 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
lEM $ git [ "checkout", "FETCH_HEAD" ]
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing
lEM $ execLogged "./configure" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing
lEM $ execLogged "sh" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" Nothing
lEM $ execLogged "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" Nothing
CapturedProcess {..} <- liftIO $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
case _exitCode of
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe $ _stdOut
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe _stdErr))
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
lift $ $(logInfo) [i|Git version #{ref} corresponds to GHC version #{prettyVer tver}|]
@@ -1387,14 +1388,14 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
Left bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver))
(bindist, bmk) <- liftE $ runBuildAction
tmpUnpack
Nothing
(do
b <- compileBindist bghc tver workdir
bmk <- liftIO $ readFileStrict (build_mk workdir)
bmk <- liftIO $ B.readFile (build_mk workdir)
pure (b, bmk)
)
@@ -1407,7 +1408,7 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
(tver ^. tvVersion)
pfreq
liftIO $ writeFile (ghcdir </> ghcUpSrcBuiltFile) (Just newFilePerms) bmk
liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
reThrowAll GHCupSetError $ postGHCInstall tver
@@ -1439,13 +1440,13 @@ HADDOCK_DOCS = YES|]
, MonadIO m
, MonadFail m
)
=> Either (Path Rel) (Path Abs)
=> Either FilePath FilePath
-> GHCTargetVersion
-> Path Abs
-> FilePath
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
m
(Path Abs) -- ^ output path of bindist
FilePath -- ^ output path of bindist
compileBindist bghc tver workdir = do
lift $ $(logInfo) [i|configuring build|]
liftE checkBuildConfig
@@ -1460,41 +1461,39 @@ HADDOCK_DOCS = YES|]
bghcPath <- case bghc of
Right ghc' -> pure ghc'
Left bver -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
spaths <- liftIO getSearchPath
liftIO (searchPath spaths bver) !? NotFoundInPATH bver
lEM $ execLogged
"./configure"
False
( maybe mempty
(\x -> ["--target=" <> E.encodeUtf8 x])
"sh"
("./configure" : maybe mempty
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
++ fmap E.encodeUtf8 aargs
++ fmap T.unpack aargs
)
[rel|ghc-conf|]
(Just workdir)
(Just (("GHC", toFilePath bghcPath) : cEnv))
"ghc-conf"
(Just (("GHC", bghcPath) : cEnv))
| otherwise -> do
lEM $ execLogged
"./configure"
False
( [ "--with-ghc=" <> either toFilePath toFilePath bghc
"sh"
( [ "./configure", "--with-ghc=" <> either id id bghc
]
++ maybe mempty
(\x -> ["--target=" <> E.encodeUtf8 x])
(\x -> ["--target=" <> T.unpack x])
(_tvTarget tver)
++ fmap E.encodeUtf8 aargs
++ fmap T.unpack aargs
)
[rel|ghc-conf|]
(Just workdir)
"ghc-conf"
(Just cEnv)
case mbuildConfig of
Just bc -> liftIOException
doesNotExistErrorType
(FileDoesNotExistError $ toFilePath bc)
(liftIO $ copyFile bc (build_mk workdir) Overwrite)
(FileDoesNotExistError bc)
(liftIO $ copyFile bc (build_mk workdir))
Nothing ->
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
liftIO $ B.writeFile (build_mk workdir) defaultConf
lift $ $(logInfo) [i|Building (this may take a while)...|]
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
@@ -1507,7 +1506,7 @@ HADDOCK_DOCS = YES|]
execBlank
([s|^ghc-.*\.tar\..*$|] :: ByteString)
)
c <- liftIO $ readFile (workdir </> tar)
c <- liftIO $ BL.readFile (workdir </> tar)
cDigest <-
fmap (T.take 8)
. lift
@@ -1517,17 +1516,14 @@ HADDOCK_DOCS = YES|]
. SHA256.hashlazy
$ c
cTime <- liftIO getCurrentTime
tarName <-
parseRel
[i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension (toFilePath tar)}|]
let tarName = [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
let tarPath = cacheDir </> tarName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath
Strict
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
pure tarPath
build_mk workdir = workdir </> [rel|mk/build.mk|]
build_mk workdir = workdir </> "mk" </> "build.mk"
checkBuildConfig :: (MonadCatch m, MonadIO m)
=> Excepts
@@ -1537,10 +1533,10 @@ HADDOCK_DOCS = YES|]
checkBuildConfig = do
c <- case mbuildConfig of
Just bc -> do
BL.toStrict <$> liftIOException
liftIOException
doesNotExistErrorType
(FileDoesNotExistError $ toFilePath bc)
(liftIO $ readFile bc)
(FileDoesNotExistError bc)
(liftIO $ B.readFile bc)
Nothing -> pure defaultConf
let lines' = fmap T.strip . T.lines $ decUTF8Safe c
@@ -1572,7 +1568,7 @@ upgradeGHCup :: ( MonadMask m
, MonadUnliftIO m
)
=> GHCupDownloads
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
-> Maybe FilePath -- ^ full file destination to write ghcup into
-> Bool -- ^ whether to force update regardless
-- of currently installed version
-> PlatformRequest
@@ -1592,25 +1588,24 @@ upgradeGHCup dls mtarget force pfreq = do
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|]
let fn = "ghcup" <> exeExt
p <- liftE $ download dli tmp (Just fn)
let destDir = dirname destFile
let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn) mtarget
lift $ $(logDebug) [i|mkdir -p #{toFilePath destDir}|]
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
liftIO $ createDirRecursive' destDir
lift $ $(logDebug) [i|rm -f #{toFilePath destFile}|]
liftIO $ hideError NoSuchThing $ deleteFile destFile
lift $ $(logDebug) [i|cp #{toFilePath p} #{toFilePath destFile}|]
lift $ $(logDebug) [i|rm -f #{destFile}|]
liftIO $ hideError NoSuchThing $ removeFile destFile
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile
Overwrite
lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> unless b $
lift $ $(logWarn) [i|"#{toFilePath (dirname destFile)}" is not in PATH! You have to add it in order to use ghcup.|]
lift $ $(logWarn) [i|"#{takeFileName destFile}" is not in PATH! You have to add it in order to use ghcup.|]
liftIO (isShadowed destFile) >>= \case
Nothing -> pure ()
Just pa -> lift $ $(logWarn) [i|ghcup is shadowed by "#{toFilePath pa}". The upgrade will not be in effect, unless you remove "#{toFilePath pa}" or make sure "#{toFilePath destDir}" comes before "#{toFilePath (dirname pa)}" in PATH.|]
Just pa -> lift $ $(logWarn) [i|ghcup is shadowed by "#{pa}". The upgrade will not be in effect, unless you remove "#{pa}" or make sure "#{destDir}" comes before "#{takeFileName pa}" in PATH.|]
pure latestVer

126
lib/GHCup/Download.hs
View File

@@ -16,7 +16,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
Module for handling all download related functions.
@@ -53,11 +53,11 @@ import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson
import Data.Bifunctor
import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.ByteString ( ByteString )
import Data.CaseInsensitive ( CI )
#endif
import Data.List ( find )
import Data.List.Extra
import Data.Maybe
import Data.String.Interpolate
import Data.Time.Clock
@@ -66,34 +66,29 @@ import Data.Time.Clock.POSIX
import Data.Time.Format
#endif
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO as HIO hiding ( hideError )
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Directory
import System.Environment
import System.FilePath
import System.IO.Error
import System.Posix.Env.ByteString ( getEnv )
import URI.ByteString
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
#if defined(INTERNAL_DOWNLOADER)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
#endif
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.Files.ByteString as PF
import qualified System.Posix.RawFilePath.Directory
as RD
@@ -158,12 +153,12 @@ readFromCache = do
lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL
yaml_file <- (cacheDir </>) <$> urlBaseName path
let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
bs <-
handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
(\_ -> throwE $ FileDoesNotExistError yaml_file)
$ liftIO
$ readFile yaml_file
$ L.readFile yaml_file
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
@@ -207,29 +202,27 @@ getBase =
smartDl uri' = do
AppState {dirs = Dirs {..}} <- lift ask
let path = view pathL' uri'
json_file <- (cacheDir </>) <$> urlBaseName path
let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
e <- liftIO $ doesFileExist json_file
if e
then do
accessTime <-
PF.accessTimeHiRes
<$> liftIO (PF.getFileStatus (toFilePath json_file))
currentTime <- liftIO getPOSIXTime
accessTime <- liftIO $ getAccessTime json_file
currentTime <- liftIO getCurrentTime
-- access time won't work on most linuxes, but we can try regardless
if (currentTime - accessTime) > 300
if (utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300
then do -- no access in last 5 minutes, re-check upstream mod time
getModTime >>= \case
Just modTime -> do
fileMod <- liftIO $ getModificationTime json_file
if modTime > fileMod
then dlWithMod modTime json_file
else liftIO $ readFile json_file
else liftIO $ L.readFile json_file
Nothing -> do
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
dlWithoutMod json_file
else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file
liftIO $ L.readFile json_file
else do
liftIO $ createDirRecursive' cacheDir
getModTime >>= \case
@@ -247,9 +240,9 @@ getBase =
pure bs
dlWithoutMod json_file = do
bs <- liftE $ downloadBS uri'
liftIO $ hideError doesNotExistErrorType $ deleteFile json_file
liftIO $ writeFileL json_file (Just newFilePerms) bs
liftIO $ setModificationTime json_file (fromIntegral @Int 0)
liftIO $ hideError doesNotExistErrorType $ removeFile json_file
liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
pure bs
@@ -278,11 +271,10 @@ getBase =
#endif
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
writeFileWithModTime :: UTCTime -> FilePath -> L.ByteString -> IO ()
writeFileWithModTime utctime path content = do
let mod_time = utcTimeToPOSIXSeconds utctime
writeFileL path (Just newFilePerms) content
setModificationTimeHiRes path mod_time
L.writeFile path content
setModificationTime path utctime
getDownloadInfo :: Tool
@@ -334,9 +326,9 @@ download :: ( MonadMask m
, MonadIO m
)
=> DownloadInfo
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
-> FilePath -- ^ destination dir
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
download dli dest mfn
| scheme == "https" = dl
| scheme == "http" = dl
@@ -348,9 +340,9 @@ download dli dest mfn
cp = do
-- destination dir must exist
liftIO $ createDirRecursive' dest
destFile <- getDestFile
fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict
let destFile = getDestFile
let fromFile = T.unpack . decUTF8Safe $ path
liftIO $ copyFile fromFile destFile
pure destFile
dl = do
let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
@@ -358,25 +350,25 @@ download dli dest mfn
-- destination dir must exist
liftIO $ createDirRecursive' dest
destFile <- getDestFile
let destFile = getDestFile
-- download
flip onException
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
(liftIO $ hideError doesNotExistErrorType $ removeFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
liftIO (hideError doesNotExistErrorType $ deleteFile destFile)
liftIO (hideError doesNotExistErrorType $ removeFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
lift getDownloader >>= \case
Curl -> do
o' <- liftIO getCurlOpts
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
(o' ++ ["-fL", "-o", toFilePath destFile, serializeURIRef' $ view dlUri dli]) Nothing Nothing
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl"
(o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
Wget -> do
o' <- liftIO getWgetOpts
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True
(o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget"
(o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
@@ -387,8 +379,8 @@ download dli dest mfn
pure destFile
-- Manage to find a file we can write the body into.
getDestFile :: MonadThrow m => m (Path Abs)
getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
getDestFile :: FilePath
getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path))) (dest </>) mfn
path = view (dlUri % pathL') dli
@@ -404,14 +396,14 @@ downloadCached :: ( MonadMask m
, MonadReader AppState m
)
=> DownloadInfo
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
-> Maybe FilePath -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m FilePath
downloadCached dli mfn = do
cache <- lift getCache
case cache of
True -> do
AppState {dirs = Dirs {..}} <- lift ask
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
let cachfile = cacheDir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
@@ -453,8 +445,8 @@ downloadBS uri'
| scheme == "http"
= dl False
| scheme == "file"
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
(liftIO $ RD.readFile path)
= liftIOException doesNotExistErrorType (FileDoesNotExistError $ T.unpack $ decUTF8Safe path)
(liftIO $ L.readFile (T.unpack $ decUTF8Safe path))
| otherwise
= throwE UnsupportedScheme
@@ -470,20 +462,20 @@ downloadBS uri'
lift getDownloader >>= \case
Curl -> do
o' <- liftIO getCurlOpts
let exe = [rel|curl|]
args = o' ++ ["-sSfL", serializeURIRef' uri']
let exe = "curl"
args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
Wget -> do
o' <- liftIO getWgetOpts
let exe = [rel|wget|]
args = o' ++ ["-qO-", serializeURIRef' uri']
let exe = "wget"
args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
liftIO (executeOut exe args Nothing) >>= \case
CapturedProcess ExitSuccess stdout _ -> do
pure $ L.fromStrict stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
pure stdout
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
#if defined(INTERNAL_DOWNLOADER)
Internal -> do
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
@@ -493,31 +485,31 @@ downloadBS uri'
checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
=> DownloadInfo
-> Path Abs
-> FilePath
-> Excepts '[DigestError] m ()
checkDigest dli file = do
verify <- lift ask <&> (not . noVerify . settings)
when verify $ do
p' <- toFilePath <$> basename file
let p' = takeFileName file
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
c <- liftIO $ readFile file
c <- liftIO $ L.readFile file
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
let eDigest = view dlHash dli
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
-- | Get additional curl args from env. This is an undocumented option.
getCurlOpts :: IO [ByteString]
getCurlOpts :: IO [String]
getCurlOpts =
getEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ BS.split _space r
lookupEnv "GHCUP_CURL_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []
-- | Get additional wget args from env. This is an undocumented option.
getWgetOpts :: IO [ByteString]
getWgetOpts :: IO [String]
getWgetOpts =
getEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ BS.split _space r
lookupEnv "GHCUP_WGET_OPTS" >>= \case
Just r -> pure $ splitOn " " r
Nothing -> pure []

15
lib/GHCup/Download/IOStreams.hs
View File

@@ -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

21
lib/GHCup/Errors.hs
View File

@@ -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

37
lib/GHCup/Platform.hs
View File

@@ -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)

2
lib/GHCup/Requirements.hs
View File

@@ -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

107
lib/GHCup/Types.hs
View File

@@ -2,7 +2,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Types
@@ -11,26 +10,39 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Types where
module GHCup.Types
( module GHCup.Types
#if defined(BRICK)
, Key(..)
#endif
)
where
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import HPath
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString
#if defined(BRICK)
import Graphics.Vty ( Key(..) )
#endif
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Encoding.Error as E
import qualified GHC.Generics as GHC
import qualified Graphics.Vty as Vty
#if !defined(BRICK)
data Key = KEsc | KChar Char | KBS | KEnter
| KLeft | KRight | KUp | KDown
| KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
| KFun Int | KBackTab | KPrtScr | KPause | KIns
| KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
deriving (Eq,Show,Read,Ord,GHC.Generic)
#endif
--------------------
--[ GHCInfo Tree ]--
@@ -157,12 +169,15 @@ data Platform = Linux LinuxDistro
| Darwin
-- ^ must exit
| FreeBSD
| Windows
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
platformToString :: Platform -> String
platformToString (Linux distro) = "linux-" ++ distroToString distro
platformToString Darwin = "darwin"
platformToString FreeBSD = "freebsd"
platformToString Windows = "windows"
instance Pretty Platform where
pPrint = text . platformToString
@@ -218,12 +233,12 @@ data DownloadInfo = DownloadInfo
-- | How to descend into a tar archive.
data TarDir = RealDir (Path Rel)
data TarDir = RealDir FilePath
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, Ord, GHC.Generic, Show)
instance Pretty TarDir where
pPrint (RealDir path) = text [i|#{E.decodeUtf8With E.lenientDecode . toFilePath $ path}|]
pPrint (RealDir path) = text path
pPrint (RegexDir regex) = text regex
@@ -250,42 +265,42 @@ defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data UserKeyBindings = UserKeyBindings
{ kUp :: Maybe Vty.Key
, kDown :: Maybe Vty.Key
, kQuit :: Maybe Vty.Key
, kInstall :: Maybe Vty.Key
, kUninstall :: Maybe Vty.Key
, kSet :: Maybe Vty.Key
, kChangelog :: Maybe Vty.Key
, kShowAll :: Maybe Vty.Key
, kShowAllTools :: Maybe Vty.Key
{ kUp :: Maybe Key
, kDown :: Maybe Key
, kQuit :: Maybe Key
, kInstall :: Maybe Key
, kUninstall :: Maybe Key
, kSet :: Maybe Key
, kChangelog :: Maybe Key
, kShowAll :: Maybe Key
, kShowAllTools :: Maybe Key
}
deriving (Show, GHC.Generic)
data KeyBindings = KeyBindings
{ bUp :: Vty.Key
, bDown :: Vty.Key
, bQuit :: Vty.Key
, bInstall :: Vty.Key
, bUninstall :: Vty.Key
, bSet :: Vty.Key
, bChangelog :: Vty.Key
, bShowAllVersions :: Vty.Key
, bShowAllTools :: Vty.Key
{ bUp :: Key
, bDown :: Key
, bQuit :: Key
, bInstall :: Key
, bUninstall :: Key
, bSet :: Key
, bChangelog :: Key
, bShowAllVersions :: Key
, bShowAllTools :: Key
}
deriving (Show, GHC.Generic)
defaultKeyBindings :: KeyBindings
defaultKeyBindings = KeyBindings
{ bUp = Vty.KUp
, bDown = Vty.KDown
, bQuit = Vty.KChar 'q'
, bInstall = Vty.KChar 'i'
, bUninstall = Vty.KChar 'u'
, bSet = Vty.KChar 's'
, bChangelog = Vty.KChar 'c'
, bShowAllVersions = Vty.KChar 'a'
, bShowAllTools = Vty.KChar 't'
{ bUp = KUp
, bDown = KDown
, bQuit = KChar 'q'
, bInstall = KChar 'i'
, bUninstall = KChar 'u'
, bSet = KChar 's'
, bChangelog = KChar 'c'
, bShowAllVersions = KChar 'a'
, bShowAllTools = KChar 't'
}
data AppState = AppState
@@ -305,11 +320,11 @@ data Settings = Settings
deriving (Show, GHC.Generic)
data Dirs = Dirs
{ baseDir :: Path Abs
, binDir :: Path Abs
, cacheDir :: Path Abs
, logsDir :: Path Abs
, confDir :: Path Abs
{ baseDir :: FilePath
, binDir :: FilePath
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
}
deriving Show
@@ -326,10 +341,10 @@ data Downloader = Curl
deriving (Eq, Show, Ord)
data DebugInfo = DebugInfo
{ diBaseDir :: Path Abs
, diBinDir :: Path Abs
, diGHCDir :: Path Abs
, diCacheDir :: Path Abs
{ diBaseDir :: FilePath
, diBinDir :: FilePath
, diGHCDir :: FilePath
, diCacheDir :: FilePath
, diArch :: Architecture
, diPlatform :: PlatformResult
}

24
lib/GHCup/Types/JSON.hs
View File

@@ -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]

2
lib/GHCup/Types/Optics.hs
View File

@@ -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

438
lib/GHCup/Utils.hs
View File

@@ -14,7 +14,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
This module contains GHCup helpers specific to
installation and introspection of files/versions etc.
@@ -39,6 +39,7 @@ import GHCup.Utils.String.QQ
#if !defined(TAR)
import Codec.Archive hiding ( Directory )
#endif
import Codec.Archive.Zip
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
@@ -51,28 +52,21 @@ import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
import Data.List
import Data.List.Extra
import Data.List.NonEmpty ( NonEmpty( (:|) ))
import Data.List.Split
import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO hiding ( hideError )
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe
import System.Directory hiding ( findFiles )
import System.FilePath
import System.IO.Error
import System.Posix.FilePath ( getSearchPath
, takeFileName
)
import System.Posix.Files.ByteString ( readSymbolicLink )
import System.IO.Unsafe ( unsafeInterleaveIO )
import Text.Regex.Posix
import URI.ByteString
@@ -85,9 +79,7 @@ import qualified Codec.Compression.Lzma as Lzma
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
#if !defined(TAR)
import qualified Data.Text as T
#endif
import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
@@ -102,14 +94,13 @@ import qualified Text.Megaparsec as MP
-- | The symlink destination of a ghc tool.
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
=> ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
=> FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
-> GHCTargetVersion
-> m ByteString
-> m FilePath
ghcLinkDestination tool ver = do
AppState { dirs = Dirs {..} } <- ask
t <- parseRel tool
ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
@@ -127,10 +118,10 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion)
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
-- | Removes the set ghc version for the given target, if any.
@@ -148,13 +139,13 @@ rmPlain target = do
forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
let fullF = binDir </> f
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
-- old ghcup
let hdc_file = binDir </> [rel|haddock-ghc|]
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) [i|rm -f #{hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ removeFile hdc_file
-- | Remove the major GHC symlink, e.g. ghc-8.6.
@@ -174,10 +165,10 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> E.encodeUtf8 v')
let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy
lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ removeFile fullF
@@ -208,42 +199,40 @@ ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
-> m (Maybe GHCTargetVersion)
ghcSet mtarget = do
AppState {dirs = Dirs {..}} <- ask
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
let ghcBin = binDir </> ghc
let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
let ghcBin = binDir </> ghc <> exeExt
-- link destination is of the form ../ghc/<ver>/bin/ghc
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
link <- readSymbolicLink $ toFilePath ghcBin
link <- liftIO $ getSymbolicLinkTarget ghcBin
Just <$> ghcLinkVersion link
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
ghcLinkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "ghcLinkVersion" t
ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
where
parser =
(do
_ <- parseUntil1 (MP.chunk "/ghc/")
_ <- MP.chunk "/ghc/"
r <- parseUntil1 (MP.chunk "/")
_ <- parseUntil1 ghcSubPath
_ <- ghcSubPath
r <- parseUntil1 pathSep
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* MP.chunk "/"
<* pathSep
<* MP.takeRest
<* MP.eof
ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r
Left _ -> pure $ Left f
@@ -251,7 +240,7 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
=> m [Either FilePath Version]
getInstalledCabals = do
cs <- cabalSet -- for legacy cabal
getInstalledCabals' cs
@@ -259,13 +248,13 @@ getInstalledCabals = do
getInstalledCabals' :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> Maybe Version
-> m [Either (Path Rel) Version]
-> m [Either FilePath Version]
getInstalledCabals' cs = do
AppState {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case fmap (version . decUTF8Safe) . B.stripPrefix "cabal-" . toFilePath $ f of
vs <- forM bins $ \f -> case fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "cabal-" $ f of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
@@ -283,22 +272,20 @@ cabalInstalled ver = do
cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do
AppState {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> [rel|cabal|]
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
let cabalbin = binDir </> "cabal" <> exeExt
b <- handleIO (\_ -> pure False) $ liftIO $ pathIsSymbolicLink cabalbin
if
| b -> do
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- liftIO $ isBrokenSymlink cabalbin
if broken
then do
$(logWarn) [i|Symlink #{cabalbin} is broken.|]
pure Nothing
then pure Nothing
else do
link <- liftIO $ readSymbolicLink $ toFilePath cabalbin
link <- liftIO $ getSymbolicLinkTarget cabalbin
case linkVersion link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{toFilePath cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
pure Nothing
| otherwise -> do -- legacy behavior
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
@@ -306,8 +293,8 @@ cabalSet = do
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (B.null (_stdOut c)), _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
| not (BL.null (_stdOut c)), _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . BL.toStrict . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
@@ -316,10 +303,8 @@ cabalSet = do
-- We try to be extra permissive with link destination parsing,
-- because of:
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
parser
= MP.try (stripAbsolutePath *> cabalParse)
@@ -329,10 +314,10 @@ cabalSet = do
cabalParse = MP.chunk "cabal-" *> version'
-- parses any path component ending with path separator,
-- e.g. "foo/"
stripPathComponet = parseUntil1 "/" *> MP.chunk "/"
stripPathComponet = parseUntil1 pathSep *> pathSep
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = MP.chunk "/" *> MP.many (MP.try stripPathComponet)
stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -342,7 +327,7 @@ cabalSet = do
-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
=> m [Either FilePath Version]
getInstalledHLSs = do
AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -353,7 +338,7 @@ getInstalledHLSs = do
)
forM bins $ \f ->
case
fmap (version . decUTF8Safe) . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f
fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "haskell-language-server-wrapper-" $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
@@ -362,7 +347,7 @@ getInstalledHLSs = do
-- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
=> m [Either FilePath Version]
getInstalledStacks = do
AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -373,7 +358,7 @@ getInstalledStacks = do
)
forM bins $ \f ->
case
fmap (version . decUTF8Safe) . B.stripPrefix "stack-" . toFilePath $ f
fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "stack-" $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
@@ -384,20 +369,18 @@ getInstalledStacks = do
stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
stackSet = do
AppState {dirs = Dirs {..}} <- ask
let stackBin = binDir </> [rel|stack|]
let stackBin = binDir </> "stack" <> exeExt
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink stackBin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath stackBin
link <- liftIO $ getSymbolicLinkTarget stackBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
where
parser =
MP.chunk "stack-" *> version'
@@ -420,20 +403,18 @@ hlsInstalled ver = do
hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet = do
AppState {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink hlsBin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath hlsBin
link <- liftIO $ getSymbolicLinkTarget hlsBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
linkVersion :: MonadThrow m => FilePath -> m Version
linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
where
parser =
MP.chunk "haskell-language-server-wrapper-" *> version'
@@ -452,13 +433,12 @@ hlsGHCVersions = do
bins <- hlsServerBinaries h'
pure $ fmap
(version
. decUTF8Safe
. T.pack
. fromJust
. B.stripPrefix "haskell-language-server-"
. stripPrefix "haskell-language-server-"
. head
. B.split _tilde
. toFilePath
)
. splitOn "~"
)
bins
pure . rights . concat . maybeToList $ vers
@@ -466,7 +446,7 @@ hlsGHCVersions = do
-- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
=> Version
-> m [Path Rel]
-> m [FilePath]
hlsServerBinaries ver = do
AppState { dirs = Dirs {..} } <- ask
liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -474,7 +454,7 @@ hlsServerBinaries ver = do
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
)
)
@@ -482,7 +462,7 @@ hlsServerBinaries ver = do
-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
=> Version
-> m (Maybe (Path Rel))
-> m (Maybe FilePath)
hlsWrapperBinary ver = do
AppState { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -490,7 +470,7 @@ hlsWrapperBinary ver = do
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [s|$|] :: ByteString
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
)
)
case wrapper of
@@ -501,7 +481,7 @@ hlsWrapperBinary ver = do
-- | Get all binaries for an hls version, if any.
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath]
hlsAllBinaries ver = do
hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver
@@ -509,7 +489,7 @@ hlsAllBinaries ver = do
-- | Get the active symlinks for hls.
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Path Rel]
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath]
hlsSymlinks = do
AppState { dirs = Dirs {..} } <- ask
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -519,9 +499,8 @@ hlsSymlinks = do
([s|^haskell-language-server-.*$|] :: ByteString)
)
filterM
( fmap (== SymbolicLink)
. liftIO
. getFileType
( liftIO
. pathIsSymbolicLink
. (binDir </>)
)
oldSyms
@@ -585,61 +564,61 @@ getLatestGHCFor major' minor' dls =
-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ destination dir
-> Path Abs -- ^ archive path
=> FilePath -- ^ destination dir
-> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
unpackToDir dest av = do
fp <- decUTF8Safe . toFilePath <$> basename av
let dfp = decUTF8Safe . toFilePath $ dest
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
fn <- toFilePath <$> basename av
unpackToDir dfp av = do
let fn = takeFileName av
lift $ $(logInfo) [i|Unpacking: #{fn} to #{dfp}|]
#if defined(TAR)
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
untar = liftIO . Tar.unpack dfp . Tar.read
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
rf = liftIO . readFile
rf :: MonadIO m => FilePath -> Excepts '[] m BL.ByteString
rf = liftIO . BL.readFile
#else
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . readFile
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . BL.readFile
#endif
-- extract, depending on file extension
if
| ".tar.gz" `B.isSuffixOf` fn -> liftE
| ".tar.gz" `isSuffixOf` fn -> liftE
(untar . GZip.decompress =<< rf av)
| ".tar.xz" `B.isSuffixOf` fn -> do
| ".tar.xz" `isSuffixOf` fn -> do
filecontents <- liftE $ rf av
let decompressed = Lzma.decompress filecontents
liftE $ untar decompressed
| ".tar.bz2" `B.isSuffixOf` fn ->
| ".tar.bz2" `isSuffixOf` fn ->
liftE (untar . BZip.decompress =<< rf av)
| ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av)
| ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av)
| ".zip" `isSuffixOf` fn ->
withArchive av (unpackInto dfp)
| otherwise -> throwE $ UnknownArchive fn
getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ archive path
=> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
#if defined(TAR)
, Tar.FormatError
#else
, ArchiveResult
#endif
] m [ByteString]
] m [FilePath]
getArchiveFiles av = do
fn <- toFilePath <$> basename av
let fn = takeFileName av
#if defined(TAR)
let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [ByteString]
let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [FilePath]
entries =
lE @Tar.FormatError
. Tar.foldEntries
@@ -648,41 +627,45 @@ getArchiveFiles av = do
(\e -> Left e)
. Tar.read
rf :: MonadIO m => Path Abs -> Excepts '[Tar.FormatError] m BL.ByteString
rf = liftIO . readFile
rf :: MonadIO m => FilePath -> Excepts '[Tar.FormatError] m BL.ByteString
rf = liftIO . BL.readFile
#else
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [ByteString]
entries = (fmap . fmap) (E.encodeUtf8 . T.pack . filepath) . lE . readArchiveBSL
let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath]
entries = (fmap . fmap) filepath . lE . readArchiveBSL
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . readFile
rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . BL.readFile
#endif
-- extract, depending on file extension
if
| ".tar.gz" `B.isSuffixOf` fn -> liftE
| ".tar.gz" `isSuffixOf` fn -> liftE
(entries . GZip.decompress =<< rf av)
| ".tar.xz" `B.isSuffixOf` fn -> do
| ".tar.xz" `isSuffixOf` fn -> do
filecontents <- liftE $ rf av
let decompressed = Lzma.decompress filecontents
liftE $ entries decompressed
| ".tar.bz2" `B.isSuffixOf` fn ->
| ".tar.bz2" `isSuffixOf` fn ->
liftE (entries . BZip.decompress =<< rf av)
| ".tar" `B.isSuffixOf` fn -> liftE (entries =<< rf av)
| ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av)
| ".zip" `isSuffixOf` fn ->
withArchive av $ do
entries' <- getEntries
pure $ fmap unEntrySelector $ Map.keys entries'
| otherwise -> throwE $ UnknownArchive fn
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
=> Path Abs -- ^ unpacked tar dir
=> FilePath -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m (Path Abs)
-> Excepts '[TarDirDoesNotExist] m FilePath
intoSubdir bdir tardir = case tardir of
RealDir pr -> do
whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
(throwE $ TarDirDoesNotExist tardir)
pure (bdir </> pr)
RegexDir r -> do
let rs = splitOn "/" r
let rs = split (`elem` pathSeparators) r
foldlM
(\y x ->
(handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
@@ -743,117 +726,124 @@ getDownloader = ask <&> downloader . settings
-------------
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
urlBaseName :: ByteString -- ^ the url path (without scheme and host)
-> ByteString
urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
--
-- Returns unversioned relative files, e.g.:
-- Returns unversioned relative files without extension, e.g.:
--
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m [Path Rel]
-> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles ver = do
ghcdir <- lift $ ghcupGHCDir ver
let bindir = ghcdir </> [rel|bin|]
let bindir = ghcdir </> "bin"
-- fail if ghc is not installed
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled GHC ver))
files <- liftIO $ getDirsFiles' bindir
files <- liftIO $ listDirectory bindir
-- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate.
-- for cross, this won't be "ghc", but e.g.
-- "armv7-unknown-linux-gnueabihf-ghc"
[ghcbin] <- liftIO $ findFiles
bindir
(makeRegexOpts compExtended
execBlank
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
)
ghcIsHadrian <- liftIO $ isHadrian bindir
onlyUnversioned <- case ghcIsHadrian of
Right () -> pure id
Left (fmap (dropSuffix exeExt) -> [ghc, ghc_ver])
| (Just symver) <- stripPrefix (ghc <> "-") ghc_ver
, not (null symver) -> pure $ filter (\x -> not $ symver `isInfixOf` x)
_ -> fail "Fatal: Could not find internal GHC version"
let ghcbinPath = bindir </> ghcbin
ghcIsHadrian <- liftIO $ isHadrian ghcbinPath
onlyUnversioned <- if ghcIsHadrian
then pure id
else do
(Just symver) <-
B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName
<$> liftIO (readSymbolicLink $ toFilePath ghcbinPath)
when (B.null symver)
(throwIO $ userError "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
pure $ onlyUnversioned files
pure $ onlyUnversioned $ fmap (dropSuffix exeExt) files
where
isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
-- GHC is moving some builds to Hadrian for bindists,
-- which doesn't create versioned binaries.
-- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
isHadrian :: Path Abs -- ^ ghcbin path
-> IO Bool
isHadrian = fmap (/= SymbolicLink) . getFileType
isHadrian :: FilePath -- ^ ghcbin path
-> IO (Either [String] ()) -- ^ Right for Hadrian
isHadrian dir = do
-- Non-hadrian has e.g. ["ghc", "ghc-8.10.4"]
-- which also requires us to discover the internal version
-- to filter the correct tool files.
-- We can't use the symlink on windows, so we fall back to some
-- more complicated logic.
fs <- fmap
-- regex over-matches
(filter (isNotAnyInfix ["haddock", "ghc-pkg", "ghci"]))
$ liftIO $ findFiles
dir
(makeRegexOpts compExtended
execBlank
-- for cross, this won't be "ghc", but e.g.
-- "armv7-unknown-linux-gnueabihf-ghc"
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc.*$|] :: ByteString)
)
if | length fs == 1 -> pure $ Right () -- hadrian
| length fs == 2 -> pure $ Left
(sortOn length fs) -- legacy make, result should
-- be ["ghc", "ghc-8.10.4"]
| otherwise -> fail "isHadrian failed!"
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
-- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: Path Rel
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
ghcUpSrcBuiltFile :: FilePath
ghcUpSrcBuiltFile = ".ghcup_src_built"
-- | Calls gmake if it exists in PATH, otherwise make.
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
=> [ByteString]
-> Maybe (Path Abs)
=> [String]
-> Maybe FilePath
-> m (Either ProcessError ())
make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
spaths <- liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make|] workdir Nothing
execLogged mymake args workdir "ghc-make" Nothing
makeOut :: [ByteString]
-> Maybe (Path Abs)
makeOut :: [String]
-> Maybe FilePath
-> IO CapturedProcess
makeOut args workdir = do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
let mymake = if has_gmake then [rel|gmake|] else [rel|make|]
spaths <- liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
let mymake = if has_gmake then "gmake" else "make"
liftIO $ executeOut mymake args workdir
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadLogger m, MonadIO m)
=> Path Abs -- ^ dir containing patches
-> Path Abs -- ^ dir to apply patches in
=> FilePath -- ^ dir containing patches
-> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do
patches <- liftIO $ getDirsFiles pdir
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) [i|Applying patch #{patch'}|]
fmap (either (const Nothing) Just)
(liftIO $ exec
"patch"
True
["-p1", "-i", toFilePath patch']
["-p1", "-i", patch']
(Just ddir)
Nothing)
!? PatchFailed
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
darwinNotarization :: Platform -> FilePath -> IO (Either ProcessError ())
darwinNotarization Darwin path = exec
"xattr"
True
["-r", "-d", "com.apple.quarantine", toFilePath path]
["-r", "-d", "com.apple.quarantine", path]
Nothing
Nothing
darwinNotarization _ _ = pure $ Right ()
@@ -871,19 +861,19 @@ getChangeLog dls tool (Right tag) =
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
=> Path Abs -- ^ build directory (cleaned up depending on Settings)
-> Maybe (Path Abs) -- ^ dir to *always* clean up on exception
=> FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a
-> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do
AppState { settings = Settings {..} } <- lift ask
let exAction = do
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
liftIO $ hideError doesNotExistErrorType $ removeDirectoryRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ deleteDirRecursive bdir
$ removeDirectoryRecursive bdir
v <-
flip onException exAction
$ catchAllE
@@ -892,32 +882,90 @@ runBuildAction bdir instdir action = do
throwE (BuildFailed bdir es)
) action
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ removeDirectoryRecursive
bdir
pure v
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: Path b -> IO ()
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirRecursive newDirPerms
. createDirectoryIfMissing True
$ p
where
isSymlinkDir e = do
ft <- getFileType p
ft <- pathIsSymbolicLink p
case ft of
SymbolicLink -> do
True -> do
rp <- canonicalizePath p
rft <- getFileType rp
rft <- doesDirectoryExist rp
case rft of
Directory -> pure ()
True -> pure ()
_ -> throwIO e
_ -> throwIO e
-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
copyDirectoryRecursive srcDir destDir = do
srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith copyFile destDir [ (srcDir, f)
| f <- srcFiles ]
where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (FilePath -> FilePath -> IO ())
-> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith doCopy targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
traverse_ (createDirectoryIfMissing True) dirs
-- Copy all the files
sequence_ [ let src = srcBase </> srcFile
dest = targetDir </> srcFile
in doCopy src dest
| (srcBase, srcFile) <- srcFiles ]
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
where
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories [] = return []
recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
files' <- recurseDirectories (dirs' ++ dirs)
return (files ++ files')
where
collect files dirs' [] = return (reverse files
,reverse dirs')
collect files dirs' (entry:entries) | ignore entry
= collect files dirs' entries
collect files dirs' (entry:entries) = do
let dirEntry = dir </> entry
isDirectory <- doesDirectoryExist (topdir </> dirEntry)
if isDirectory
then collect files (dirEntry:dirs') entries
else collect (dirEntry:files) dirs' entries
ignore ['.'] = True
ignore ['.', '.'] = True
ignore _ = False
getVersionInfo :: Version
-> Tool
-> GHCupDownloads
@@ -938,3 +986,13 @@ traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = \t -> (`traverseFold` t)
-- | The file extension for executables.
exeExt :: String
#if defined(IS_WINDOWS)
exeExt = ".exe"
#else
exeExt = ""
#endif

153
lib/GHCup/Utils/Dirs.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -12,7 +13,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Utils.Dirs
( getDirs
@@ -34,7 +35,6 @@ import GHCup.Types.JSON ( )
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Unlift
@@ -42,32 +42,20 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Maybe
import Data.String.Interpolate
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Directory
import System.DiskSpace
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Temp.ByteString ( mkdtemp )
import System.Environment
import System.FilePath
import System.IO.Temp
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
import qualified Text.Megaparsec as MP
import Control.Concurrent (threadDelay)
@@ -82,96 +70,96 @@ import Control.Concurrent (threadDelay)
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir :: IO FilePath
ghcupBaseDir = do
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_DATA_HOME" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.local/share|])
pure (bdir </> [rel|ghcup|])
pure (home </> ".local" </> "share")
pure (bdir </> "ghcup")
else do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
pure (bdir </> ".ghcup")
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
ghcupConfigDir :: IO (Path Abs)
ghcupConfigDir :: IO FilePath
ghcupConfigDir = do
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_CONFIG_HOME" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.config|])
pure (bdir </> [rel|ghcup|])
pure (home </> ".config")
pure (bdir </> "ghcup")
else do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
pure (bdir </> ".ghcup")
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
-- (which, sadly is not strictly xdg spec).
ghcupBinDir :: IO (Path Abs)
ghcupBinDir :: IO FilePath
ghcupBinDir = do
xdg <- useXDG
if xdg
then do
getEnv "XDG_BIN_HOME" >>= \case
Just r -> parseAbs r
lookupEnv "XDG_BIN_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.local/bin|])
else ghcupBaseDir <&> (</> [rel|bin|])
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
-- | Defaults to '~/.ghcup/cache'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir :: IO FilePath
ghcupCacheDir = do
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.cache|])
pure (bdir </> [rel|ghcup|])
else ghcupBaseDir <&> (</> [rel|cache|])
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
-- | Defaults to '~/.ghcup/logs'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
ghcupLogsDir :: IO (Path Abs)
ghcupLogsDir :: IO FilePath
ghcupLogsDir = do
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
Just r -> parseAbs r
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.cache|])
pure (bdir </> [rel|ghcup/logs|])
else ghcupBaseDir <&> (</> [rel|logs|])
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
getDirs :: IO Dirs
@@ -194,11 +182,11 @@ ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings
ghcupConfigFile = do
confDir <- liftIO ghcupConfigDir
let file = confDir </> [rel|config.yaml|]
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
case bs of
let file = confDir </> "config.yaml"
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile file
case contents of
Nothing -> pure defaultUserSettings
Just bs' -> lE' JSONDecodeError . first show . Y.decodeEither' . L.toStrict $ bs'
Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
-------------------------
@@ -207,10 +195,10 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
ghcupGHCBaseDir = do
AppState { dirs = Dirs {..} } <- ask
pure (baseDir </> [rel|ghc|])
pure (baseDir </> "ghc")
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
@@ -219,35 +207,32 @@ ghcupGHCBaseDir = do
-- * 8.8.4
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
=> GHCTargetVersion
-> m (Path Abs)
-> m FilePath
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel $ E.encodeUtf8 (tVerToText ver)
ghcbasedir <- ghcupGHCBaseDir
let verdir = T.unpack $ tVerToText ver
pure (ghcbasedir </> verdir)
-- | See 'ghcupToolParser'.
parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
parseGHCupGHCDir (toFilePath -> f) = do
fp <- throwEither $ E.decodeUtf8' f
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir (T.pack -> fp) =
throwEither $ MP.parse ghcTargetVerP "" fp
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
let fp = T.unpack $ decUTF8Safe tmpdir
tmpdir <- liftIO getCanonicalTemporaryDirectory
let minSpace = 5000 -- a rough guess, aight?
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace fp
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
when (maybe False (toBytes minSpace >) space) $ do
$(logWarn) [i|Possibly insufficient disk space on #{fp}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
$(logWarn) [i|Possibly insufficient disk space on #{tmpdir}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
$(logWarn)
"...waiting for 10 seconds before continuing anyway, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
parseAbs tmp
liftIO $ createTempDirectory tmpdir "ghcup"
where
toBytes mb = mb * 1024 * 1024
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
@@ -256,8 +241,8 @@ mkGhcupTmpDir = do
where t = 10^n
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) deleteDirRecursive)
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) removeDirectoryRecursive)
@@ -267,29 +252,19 @@ withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir
--------------
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv "HOME"
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
useXDG :: IO Bool
useXDG = isJust <$> getEnv "GHCUP_USE_XDG_DIRS"
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
relativeSymlink :: Path Abs -- ^ the path in which to create the symlink
-> Path Abs -- ^ the symlink destination
-> ByteString
relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
relativeSymlink :: FilePath -- ^ the path in which to create the symlink
-> FilePath -- ^ the symlink destination
-> FilePath
relativeSymlink p1 p2 =
let d1 = splitDirectories p1
d2 = splitDirectories p2
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
cPrefix = drop (length common) d1
in joinPath (replicate (length cPrefix) "..")
<> joinPath ("/" : drop (length common) d2)
<> joinPath ([pathSeparator] : drop (length common) d2)

511
lib/GHCup/Utils/File.hs
View File

@@ -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

122
lib/GHCup/Utils/File/Common.hs Normal file
View File

@@ -0,0 +1,122 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.Utils.File.Common where
import GHCup.Utils.Prelude
import Control.Exception
import Control.Monad.Extra
import Control.Monad.Reader
import Data.Maybe
import Data.String.Interpolate
import GHC.IO.Exception
import Optics hiding ((<|), (|>))
import System.Directory
import System.FilePath
import System.IO.Error
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
import qualified Data.ByteString.Lazy as BL
data ProcessError = NonZeroExit Int FilePath [String]
| PTerminated FilePath [String]
| PStopped FilePath [String]
| NoSuchPid FilePath [String]
deriving Show
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text [i|Process "#{exe}" with arguments #{args} failed with exit code #{e}.|]
pPrint (PTerminated exe args) =
text [i|Process "#{exe}" with arguments #{args} terminated.|]
pPrint (PStopped exe args) =
text [i|Process "#{exe}" with arguments #{args} stopped.|]
pPrint (NoSuchPid exe args) =
text [i|Could not find PID for process running "#{exe}" with arguments #{args}.|]
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: BL.ByteString
, _stdErr :: BL.ByteString
}
deriving (Eq, Show)
makeLenses ''CapturedProcess
-- | Search for a file in the search paths.
--
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
searchPath paths needle = go paths
where
go [] = pure Nothing
go (x : xs) =
hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
$ do
contents <- listDirectory x
findM (isMatch x) contents >>= \case
Just _ -> pure $ Just (x </> needle)
Nothing -> go xs
isMatch basedir p = do
if p == needle
then isExecutable (basedir </> needle)
else pure False
isExecutable :: FilePath -> IO Bool
isExecutable file = executable <$> getPermissions file
-- | Check wether a binary is shadowed by another one that comes before
-- it in PATH. Returns the path to said binary, if any.
isShadowed :: FilePath -> IO (Maybe FilePath)
isShadowed p = do
let dir = takeDirectory p
let fn = takeFileName p
spaths <- liftIO getSearchPath
if dir `elem` spaths
then do
let shadowPaths = takeWhile (/= dir) spaths
searchPath shadowPaths fn
else pure Nothing
-- | Check whether the binary is in PATH. This returns only `True`
-- if the directory containing the binary is part of PATH.
isInPath :: FilePath -> IO Bool
isInPath p = do
let dir = takeDirectory p
let fn = takeFileName p
spaths <- liftIO getSearchPath
if dir `elem` spaths
then isJust <$> searchPath [dir] fn
else pure False
findFiles :: FilePath -> Regex -> IO [FilePath]
findFiles path regex = do
contents <- listDirectory path
pure $ filter (match regex) contents
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink fp = do
try (pathIsSymbolicLink fp) >>= \case
Right True -> do
let symDir = takeDirectory fp
tfp <- getSymbolicLinkTarget fp
not <$> doesPathExist
-- this drops 'symDir' if 'tfp' is absolute
(symDir </> tfp)
Right b -> pure b
Left e | isDoesNotExistError e -> pure False
| otherwise -> throwIO e

368
lib/GHCup/Utils/File/Posix.hs Normal file
View File

@@ -0,0 +1,368 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File.Posix
Description : File and unix APIs
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File.Posix where
import GHCup.Utils.File.Common
import GHCup.Utils.Prelude
import GHCup.Types
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString )
import Data.Foldable
import Data.IORef
import Data.Sequence ( Seq, (|>) )
import Data.String.Interpolate
import Data.List
import Data.Word8
import GHC.IO.Exception
import System.Console.Pretty hiding ( Pretty )
import System.Console.Regions
import System.IO.Error
import System.FilePath
import System.Posix.Directory
import System.Posix.Files
import System.Posix.IO
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types
import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.Posix.Process as SPP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: FilePath -- ^ command as filename, e.g. 'ls'
-> [String] -- ^ arguments to the command
-> Maybe FilePath -- ^ chdir to this path
-> IO CapturedProcess
executeOut path args chdir = captureOutStreams $ do
maybe (pure ()) changeWorkingDirectory chdir
SPP.executeFile path True args Nothing
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
let logfile = logsDir </> lfile <> ".log"
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
closeFd
(action verbose)
where
action verbose fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout
pState <- newEmptyMVar
done <- newEmptyMVar
void
$ forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ EX.finally
(if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState
)
(putMVar done ())
-- fork the subprocess
pid <- SPP.forkProcess $ do
void $ dupTo stdoutWrite stdOutput
void $ dupTo stdoutWrite stdError
closeFd stdoutRead
closeFd stdoutWrite
-- execute the action
maybe (pure ()) changeWorkingDirectory chdir
void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
closeFd stdoutWrite
-- wait for the subprocess to finish
e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid
putMVar pState (either (const False) (const True) e)
void $ race (takeMVar done) (threadDelay (1000000 * 3))
closeFd stdoutRead
pure e
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readTilEOF lineAction fdIn
where
lineAction :: ByteString -> IO ()
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
printToRegion fileFd fdIn size pState = do
void $ displayConsoleRegions $ do
rs <-
liftIO
. fmap Sq.fromList
. sequence
. replicate size
. openConsoleRegion
$ Linear
flip runStateT mempty
$ handle
(\(ex :: SomeException) -> do
ps <- liftIO $ takeMVar pState
when ps (forM_ rs (liftIO . closeConsoleRegion))
throw ex
)
$ readTilEOF (lineAction rs) fdIn
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction :: (MonadMask m, MonadIO m)
=> Seq ConsoleRegion
-> ByteString
-> StateT (Seq ByteString) m ()
lineAction rs = \bs' -> do
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
modify (swapRegs bs')
regs <- get
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
$ bs
swapRegs :: a -> Seq a -> Seq a
swapRegs bs = \regs -> if
| Sq.length regs < size -> regs |> bs
| otherwise -> Sq.drop 1 regs |> bs
-- trim output line to terminal width
trim :: Int -> ByteString -> ByteString
trim w = \bs -> if
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
| otherwise -> bs
-- Consecutively read from Fd in 512 chunks until we hit
-- newline or EOF.
readLine :: MonadIO m
=> Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = go
where
go inBs = do
-- if buffer is not empty, process it first
mbs <- if BS.length inBs == 0
-- otherwise attempt read
then liftIO
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
$ fmap Just
$ SPIB.fdRead fd 512
else pure $ Just inBs
case mbs of
Nothing -> pure ("", "", True)
Just bs -> do
-- split on newline
let (line, rest) = BS.span (/= _lf) bs
if
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-- if rest is empty, then there was no newline, process further
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readTilEOF ~action' fd' = go mempty
where
go bs' = do
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else void (action' bs) >> go rest
-- | Capture the stdout and stderr of the given action, which
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
-- ^ the action to execute in a subprocess
-> IO CapturedProcess
captureOutStreams action = do
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
pid <- SPP.forkProcess $ do
-- dup stdout
void $ dupTo childStdoutWrite stdOutput
closeFd childStdoutWrite
closeFd parentStdoutRead
-- dup stderr
void $ dupTo childStderrWrite stdError
closeFd childStderrWrite
closeFd parentStderrRead
-- execute the action
a <- action
void $ evaluate a
-- close everything we don't need
closeFd childStdoutWrite
closeFd childStderrWrite
-- start thread that writes the output
refOut <- newIORef BL.empty
refErr <- newIORef BL.empty
done <- newEmptyMVar
_ <-
forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ writeStds parentStdoutRead parentStderrRead refOut refErr
status <- SPP.getProcessStatus True True pid
void $ race (takeMVar done) (threadDelay (1000000 * 3))
case status of
-- readFd will take care of closing the fd
Just (SPP.Exited es) -> do
stdout' <- readIORef refOut
stderr' <- readIORef refErr
pure $ CapturedProcess { _exitCode = es
, _stdOut = stdout'
, _stdErr = stderr'
}
_ -> throwIO $ userError ("No such PID " ++ show pid)
where
writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
writeStds pout perr rout rerr = do
doneOut <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneOut ())
$ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout
doneErr <- newEmptyMVar
void
$ forkIO
$ hideError eofErrorType
$ flip EX.finally (putMVar doneErr ())
$ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr
takeMVar doneOut
takeMVar doneErr
readTilEOF ~action' fd' = do
bs <- SPIB.fdRead fd' 512
void $ action' bs
readTilEOF action' fd'
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
actionWithPipes a =
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
cleanup :: [Fd] -> IO ()
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-- | Create a new regular file in write-only mode. The file must not exist.
createRegularFileFd :: FileMode -> FilePath -> IO Fd
createRegularFileFd fm dest =
openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }
-- | Thin wrapper around `executeFile`.
exec :: String -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> IO (Either ProcessError ())
exec exe args chdir env = do
pid <- SPP.forkProcess $ do
maybe (pure ()) changeWorkingDirectory chdir
SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid
toProcessError :: FilePath
-> [String]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
Just (SPP.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
chmod_755 :: (MonadLogger m, MonadIO m) => FilePath -> m ()
chmod_755 fp = do
let exe_mode =
nullFileMode
`unionFileModes` ownerExecuteMode
`unionFileModes` ownerReadMode
`unionFileModes` ownerWriteMode
`unionFileModes` groupExecuteMode
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
$(logDebug) [i|chmod 755 #{fp}|]
liftIO $ setFileMode fp exe_mode
-- |Default permissions for a new file.
newFilePerms :: FileMode
newFilePerms =
ownerWriteMode
`unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode
`unionFileModes` groupReadMode
`unionFileModes` otherWriteMode
`unionFileModes` otherReadMode

202
lib/GHCup/Utils/File/Windows.hs Normal file
View File

@@ -0,0 +1,202 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-|
Module : GHCup.Utils.File.Windows
Description : File and windows APIs
Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : Windows
This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File.Windows where
import GHCup.Utils.File.Common
import GHCup.Types
import Control.Concurrent
import Control.DeepSeq
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Foreign.C.Error
import GHC.IO.Exception
import GHC.IO.Handle
import System.Directory
import System.FilePath
import System.IO
import System.Process
import qualified Control.Exception as EX
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
toProcessError :: FilePath
-> [FilePath]
-> ExitCode
-> Either ProcessError ()
toProcessError exe args exitcode = case exitcode of
(ExitFailure xi) -> Left $ NonZeroExit xi exe args
ExitSuccess -> Right ()
-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it
-- lets you pass 'CreateProcess' giving better flexibility.
--
-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
-- record will be ignored.
--
-- @since 1.2.3.0
readCreateProcessWithExitCodeBS
:: CreateProcess
-> BL.ByteString
-> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr
readCreateProcessWithExitCodeBS cp input = do
let cp_opts = cp {
std_in = CreatePipe,
std_out = CreatePipe,
std_err = CreatePipe
}
withCreateProcess_ "readCreateProcessWithExitCode" cp_opts $
\mb_inh mb_outh mb_errh ph ->
case (mb_inh, mb_outh, mb_errh) of
(Just inh, Just outh, Just errh) -> do
out <- BS.hGetContents outh
err <- BS.hGetContents errh
-- fork off threads to start consuming stdout & stderr
withForkWait (EX.evaluate $ rnf out) $ \waitOut ->
withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do
-- now write any input
unless (BL.null input) $
ignoreSigPipe $ BL.hPut inh input
-- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
ignoreSigPipe $ hClose inh
-- wait on the output
waitOut
waitErr
hClose outh
hClose errh
-- wait on the process
ex <- waitForProcess ph
return (ex, BL.fromStrict out, BL.fromStrict err)
(Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."
(_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."
(_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."
where
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = EX.handle $ \e -> case e of
IOError { ioe_type = ResourceVanished
, ioe_errno = Just ioe }
| Errno ioe == ePIPE -> return ()
_ -> throwIO e
-- wrapper so we can get exceptions with the appropriate function name.
withCreateProcess_
:: String
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess_ fun c action =
EX.bracketOnError (createProcess_ fun c) cleanupProcess
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
-- | Fork a thread while doing something else, but kill it if there's an
-- exception.
--
-- This is important in the cases above because we want to kill the thread
-- that is holding the Handle lock, because when we clean up the process we
-- try to close that handle, which could otherwise deadlock.
--
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait async' body = do
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
mask $ \restore -> do
tid <- forkIO $ try (restore async') >>= putMVar waitVar
let wait' = takeMVar waitVar >>= either throwIO return
restore (body wait') `EX.onException` killThread tid
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: FilePath -- ^ command as filename, e.g. 'ls'
-> [String] -- ^ arguments to the command
-> Maybe FilePath -- ^ chdir to this path
-> IO CapturedProcess
executeOut path args chdir = do
(exit, out, err) <- readCreateProcessWithExitCodeBS (proc path args){ cwd = chdir } ""
pure $ CapturedProcess exit out err
execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
=> FilePath -- ^ thing to execute
-> [String] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> FilePath -- ^ log filename (opened in append mode)
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execLogged exe args chdir lfile env = do
AppState { dirs = Dirs {..} } <- ask
let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
stderrLogfile = logsDir </> lfile <> ".stderr.log"
fmap (toProcessError exe args)
$ liftIO
$ withCreateProcess
(proc exe args){ cwd = chdir
, env = env
, std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
$ \_ mout merr ph ->
case (mout, merr) of
(Just cStdout, Just cStderr) -> do
withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
waitOut
waitErr
waitForProcess ph
_ -> fail "Could not acquire out/err handle"
where
tee :: FilePath -> Handle -> IO ()
tee logFile handle' = go
where
go = do
some <- BS.hGetSome handle' 512
if BS.null some
then pure ()
else do
void $ BS.appendFile logFile some
void $ BS.hPut stdout some
go
-- | Thin wrapper around `executeFile`.
exec :: FilePath -- ^ thing to execute
-> [FilePath] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> IO (Either ProcessError ())
exec exe args chdir env = do
exit_code <- withCreateProcess
(proc exe args) { cwd = chdir, env = env } $ \_ _ _ p ->
waitForProcess p
pure $ toProcessError exe args exit_code
chmod_755 :: MonadIO m => FilePath -> m ()
chmod_755 fp =
let perm = setOwnerWritable True emptyPermissions
in liftIO $ setPermissions fp perm

18
lib/GHCup/Utils/Logger.hs
View File

@@ -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

7
lib/GHCup/Utils/MegaParsec.hs
View File

@@ -8,7 +8,7 @@ Copyright : (c) Julian Ospald, 2020
License : LGPL-3.0
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
Portability : portable
-}
module GHCup.Utils.MegaParsec where
@@ -23,6 +23,7 @@ import Data.Maybe
import Data.Text ( Text )
import Data.Versions
import Data.Void
import System.FilePath
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
@@ -117,3 +118,7 @@ verP suffix = do
v <- versioning'
MP.setInput rest
pure v
pathSep :: MP.Parsec Void Text Char
pathSep = MP.oneOf pathSeparators

14
lib/GHCup/Utils/Prelude.hs
View File

@@ -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

2
lib/GHCup/Utils/String/QQ.hs
View File

@@ -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.

2
lib/GHCup/Utils/Version/QQ.hs
View File

@@ -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

2
lib/GHCup/Version.hs
View File

@@ -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