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

[WIP] Prototype of recording installed files

Browse Source 
This also installs makefile based build system via DESTDIR
into a temporary directory and then merges it into the filesystem.
This commit is contained in:
Julian Ospald 2022-05-12 17:58:40 +02:00
parent e60b8ee238
commit 48aee1e76c
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
22 changed files with 628 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.hlint.yaml
View File

@ -20,6 +20,7 @@
- ignore: {name: "Avoid lambda"}
- ignore: {name: "Use uncurry"}
- ignore: {name: "Use replicateM"}
- ignore: {name: "Use unless"}
- ignore: {name: "Redundant irrefutable pattern"}

3
app/ghcup/BrickMain.hs
View File

@ -438,6 +438,7 @@ install' _ (_, ListResult {..}) = do
, FileAlreadyExistsError
, ProcessError
, GHCupShadowed
, UninstallFailed
]
run (do
@ -512,7 +513,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif
del' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let run = runE @'[NotInstalled]
let run = runE @'[NotInstalled, UninstallFailed]
run (do
let vi = getVersionInfo lVer lTool dls

2
app/ghcup/GHCup/OptParse/Compile.hs
View File

@ -388,6 +388,7 @@ type GHCEffects = '[ AlreadyInstalled
, ProcessError
, CopyError
, BuildFailed
, UninstallFailed
]
type HLSEffects = '[ AlreadyInstalled
, BuildFailed
@ -406,6 +407,7 @@ type HLSEffects = '[ AlreadyInstalled
, NotInstalled
, DirNotEmpty
, ArchiveResult
, UninstallFailed
]

4
app/ghcup/GHCup/OptParse/GC.hs
View File

@ -98,7 +98,7 @@ gcFooter = [s|Discussion:
---------------------------
type GCEffects = '[ NotInstalled ]
type GCEffects = '[ NotInstalled, UninstallFailed ]
runGC :: MonadUnliftIO m
@ -129,7 +129,7 @@ gc :: ( Monad m
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
gc GCOptions{..} runAppState runLogger = runGC runAppState (do
when gcOldGHC rmOldGHC
when gcOldGHC (liftE rmOldGHC)
lift $ when gcProfilingLibs rmProfilingLibs
lift $ when gcShareDir rmShareDir
liftE $ when gcHLSNoGHC rmHLSNoGHC

7
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -257,6 +257,7 @@ type InstallEffects = '[ AlreadyInstalled
, NoToolVersionSet
, FileAlreadyExistsError
, ProcessError
, UninstallFailed
, (AlreadyInstalled, ())
, (UnknownArchive, ())
@ -264,9 +265,9 @@ type InstallEffects = '[ AlreadyInstalled
, (FileDoesNotExistError, ())
, (CopyError, ())
, (NotInstalled, ())
, (UninstallFailed, ())
, (DirNotEmpty, ())
, (NoDownload, ())
, (NotInstalled, ())
, (BuildFailed, ())
, (TagNotFound, ())
, (DigestError, ())
@ -287,6 +288,7 @@ type InstallEffects = '[ AlreadyInstalled
, (DirNotEmpty, NotInstalled)
, (NoDownload, NotInstalled)
, (NotInstalled, NotInstalled)
, (UninstallFailed, NotInstalled)
, (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled)
, (DigestError, NotInstalled)
@ -319,6 +321,7 @@ type InstallGHCEffects = '[ TagNotFound
, BuildFailed
, DirNotEmpty
, AlreadyInstalled
, UninstallFailed
, (AlreadyInstalled, NotInstalled)
, (UnknownArchive, NotInstalled)
@ -328,6 +331,7 @@ type InstallGHCEffects = '[ TagNotFound
, (NotInstalled, NotInstalled)
, (DirNotEmpty, NotInstalled)
, (NoDownload, NotInstalled)
, (UninstallFailed, NotInstalled)
, (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled)
, (DigestError, NotInstalled)
@ -347,6 +351,7 @@ type InstallGHCEffects = '[ TagNotFound
, (NotInstalled, ())
, (DirNotEmpty, ())
, (NoDownload, ())
, (UninstallFailed, ())
, (BuildFailed, ())
, (TagNotFound, ())
, (DigestError, ())

2
app/ghcup/GHCup/OptParse/Nuke.hs
View File

@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay)
---------------------------
type NukeEffects = '[ NotInstalled ]
type NukeEffects = '[ NotInstalled, UninstallFailed ]
runNuke :: AppState

2
app/ghcup/GHCup/OptParse/Rm.hs
View File

@ -127,7 +127,7 @@ rmFooter = [s|Discussion:
---------------------------
type RmEffects = '[ NotInstalled ]
type RmEffects = '[ NotInstalled, UninstallFailed ]
runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))

2
app/ghcup/GHCup/OptParse/Run.hs
View File

@ -176,6 +176,7 @@ type RunEffects = '[ AlreadyInstalled
, NoToolVersionSet
, FileAlreadyExistsError
, ProcessError
, UninstallFailed
]
runLeanRUN :: (MonadUnliftIO m, MonadIO m)
@ -339,6 +340,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
, AlreadyInstalled
, FileAlreadyExistsError
, CopyError
, UninstallFailed
] (ResourceT (ReaderT AppState m)) ()
installToolChainFull Toolchain{..} tmp = do
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do

4
ghcup.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.17.8
version: 0.1.18.0
license: LGPL-3.0-only
license-file: LICENSE
copyright: Julian Ospald 2020
@ -127,6 +127,7 @@ library
, safe-exceptions ^>=0.1
, split ^>=0.2.3.4
, strict-base ^>=0.4
, streamly ^>=0.8.2
, template-haskell >=2.7 && <2.18
, temporary ^>=1.3
, text ^>=1.2.4.0
@ -165,6 +166,7 @@ library
else
other-modules:
GHCup.Utils.File.Posix
GHCup.Utils.File.Posix.Foreign
GHCup.Utils.Posix
GHCup.Utils.Prelude.Posix

184
lib/GHCup.hs
View File

@ -77,7 +77,7 @@ import Prelude hiding ( abs
, writeFile
)
import Safe hiding ( at )
import System.Directory hiding ( findFiles )
import System.Directory hiding ( findFiles, copyFile )
import System.Environment
import System.FilePath
import System.IO.Error
@ -202,6 +202,7 @@ installGHCBindist :: ( MonadFail m
, DirNotEmpty
, ArchiveResult
, ProcessError
, UninstallFailed
]
m
()
@ -269,6 +270,7 @@ installPackedGHC :: ( MonadMask m
, MonadIO m
, MonadUnliftIO m
, MonadFail m
, MonadResource m
)
=> FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive
@ -300,12 +302,7 @@ installPackedGHC dl msubdir inst ver forceInstall = do
msubdir
liftE $ runBuildAction tmpUnpack
(case inst of
IsolateDirResolved _ -> Nothing -- don't clean up for isolated installs, since that'd potentially delete other
-- user files if '--force' is supplied
GHCupDir d -> Just d
)
(installUnpackedGHC workdir inst ver)
(installUnpackedGHC workdir inst ver forceInstall)
-- | Install an unpacked GHC distribution. This only deals with the GHC
@ -319,21 +316,27 @@ installUnpackedGHC :: ( MonadReader env m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
, MonadResource m
, MonadFail m
)
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> InstallDirResolved -- ^ Path to install to
-> Version -- ^ The GHC version
-> Bool -- ^ Force install
-> Excepts '[ProcessError] m ()
installUnpackedGHC path (fromInstallDir -> inst) ver
installUnpackedGHC path inst ver forceInstall
| isWindows = do
lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
-- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
fs <- lift $ withRunInIO $ \_ -> mergeFileTreeAll path (fromInstallDir inst) $ \source dest -> do
mtime <- getModificationTime source
moveFilePortable source dest
setModificationTime dest mtime
case inst of
IsolateDirResolved _ -> pure ()
_ -> recordInstalledFiles fs GHC (mkTVer ver)
| otherwise = do
PlatformRequest {..} <- lift getPlatformReq
@ -345,13 +348,21 @@ installUnpackedGHC path (fromInstallDir -> inst) ver
lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst)
("./configure" : ("--prefix=" <> fromInstallDir inst)
: alpineArgs
)
(Just path)
"ghc-configure"
Nothing
lEM $ make ["install"] (Just path)
tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> tmpInstallDest, "install"] (Just path)
lift $ logInfo $ "Merging file tree from \"" <> T.pack tmpInstallDest <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\""
fs <- mergeFileTreeAll (tmpInstallDest </> dropDrive (fromInstallDir inst))
(fromInstallDir inst)
(\f t -> liftIO $ install f t (not forceInstall))
case inst of
IsolateDirResolved _ -> pure ()
_ -> recordInstalledFiles fs GHC (mkTVer ver)
pure ()
@ -389,6 +400,7 @@ installGHCBin :: ( MonadFail m
, DirNotEmpty
, ArchiveResult
, ProcessError
, UninstallFailed
]
m
()
@ -493,12 +505,10 @@ installCabalUnpacked path inst ver forceInstall = do
<> exeExt
let destPath = fromInstallDir inst </> destFileName
unless forceInstall -- Overwrite it when it IS a force install
(liftE $ throwIfFileAlreadyExists destPath)
copyFileE
(path </> cabalFile <> exeExt)
destPath
(not forceInstall)
lift $ chmod_755 destPath
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
@ -572,6 +582,7 @@ installHLSBindist :: ( MonadMask m
, FileAlreadyExistsError
, ProcessError
, DirNotEmpty
, UninstallFailed
]
m
()
@ -620,15 +631,15 @@ installHLSBindist dlinfo ver installDir forceInstall = do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
if legacy
then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall
else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver
else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do
if legacy
then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall
else do
inst <- ghcupHLSDir ver
liftE $ runBuildAction tmpUnpack (Just inst)
$ installHLSUnpacked workdir (GHCupDir inst) ver
liftE $ runBuildAction tmpUnpack
$ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall
liftE $ setHLS ver SetHLS_XYZ Nothing
@ -638,15 +649,32 @@ isLegacyHLSBindist path = do
not <$> doesFileExist (path </> "GNUmakefile")
-- | Install an unpacked hls distribution.
installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m)
installHLSUnpacked :: ( MonadMask m
, MonadUnliftIO m
, MonadReader env m
, MonadFail m
, HasLog env
, HasDirs env
, HasSettings env
, MonadCatch m
, MonadIO m
, MonadResource m
)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> InstallDirResolved -- ^ Path to install to
-> Version
-> Bool
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
installHLSUnpacked path (fromInstallDir -> inst) _ = do
installHLSUnpacked path inst ver forceInstall = do
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
lEM $ make ["PREFIX=" <> inst, "install"] (Just path)
tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)
fs <- mergeFileTreeAll (tmpInstallDest </> dropDrive (fromInstallDir inst))
(fromInstallDir inst)
(\f t -> liftIO $ install f t (not forceInstall))
case inst of
IsolateDirResolved _ -> pure ()
_ -> recordInstalledFiles fs HLS (mkTVer ver)
-- | Install an unpacked hls distribution (legacy).
installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
@ -677,12 +705,10 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do
let srcPath = path </> f
let destPath = fromInstallDir installDir </> toF
unless forceInstall -- if it is a force install, overwrite it.
(liftE $ throwIfFileAlreadyExists destPath)
copyFileE
srcPath
destPath
(not forceInstall)
lift $ chmod_755 destPath
-- install haskell-language-server-wrapper
@ -696,12 +722,10 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do
srcWrapperPath = path </> wrapper <> exeExt
destWrapperPath = fromInstallDir installDir </> toF
unless forceInstall
(liftE $ throwIfFileAlreadyExists destWrapperPath)
copyFileE
srcWrapperPath
destWrapperPath
(not forceInstall)
lift $ chmod_755 destWrapperPath
@ -739,6 +763,7 @@ installHLSBin :: ( MonadMask m
, FileAlreadyExistsError
, ProcessError
, DirNotEmpty
, UninstallFailed
]
m
()
@ -850,7 +875,6 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
liftE $ runBuildAction
workdir
Nothing
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
let tmpInstallDir = workdir </> "out"
liftIO $ createDirRecursive' tmpInstallDir
@ -862,19 +886,19 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
cp <- case cabalProject of
Just (Left cp)
| isAbsolute cp -> do
copyFileE cp (workdir </> "cabal.project")
copyFileE cp (workdir </> "cabal.project") False
pure "cabal.project"
| otherwise -> pure (takeFileName cp)
Just (Right uri) -> do
tmpUnpack <- lift withGHCupTmpDir
cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False
copyFileE cp (workdir </> "cabal.project")
copyFileE cp (workdir </> "cabal.project") False
pure "cabal.project"
Nothing -> pure "cabal.project"
forM_ cabalProjectLocal $ \uri -> do
tmpUnpack <- lift withGHCupTmpDir
cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
copyFileE cpl (workdir </> cp <.> "local")
copyFileE cpl (workdir </> cp <.> "local") False
artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
liftIO $ createDirRecursive' tmpInstallDir
@ -1049,12 +1073,10 @@ installStackUnpacked path installDir ver forceInstall = do
<> exeExt
destPath = fromInstallDir installDir </> destFileName
unless forceInstall
(liftE $ throwIfFileAlreadyExists destPath)
copyFileE
(path </> stackFile <> exeExt)
destPath
(not forceInstall)
lift $ chmod_755 destPath
@ -1754,12 +1776,11 @@ rmGHCVer :: ( MonadReader env m
, MonadUnliftIO m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
-> Excepts '[NotInstalled, UninstallFailed] m ()
rmGHCVer ver = do
isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver)
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))
dir <- lift $ ghcupGHCDir ver
-- this isn't atomic, order matters
when isSetGHC $ do
@ -1774,7 +1795,18 @@ rmGHCVer ver = do
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver
-- then fix them (e.g. with an earlier version)
lift $ logInfo $ "Removing directory recursively: " <> T.pack dir
dir <- lift $ ghcupGHCDir ver
lift (getInstalledFiles GHC ver) >>= \case
Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack dir
forM_ files (liftIO . deleteFile . (\f -> dir </> dropDrive f))
f <- recordedInstallationFile GHC ver
liftIO $ deleteFile f
removeEmptyDirsRecursive dir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir
when (not (null survivors)) $ throwE $ UninstallFailed dir survivors
Nothing -> do
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir
lift $ recyclePathForcibly dir
v' <-
@ -1834,23 +1866,37 @@ rmHLSVer :: ( MonadMask m
, MonadUnliftIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
-> Excepts '[NotInstalled, UninstallFailed] m ()
rmHLSVer ver = do
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
isHlsSet <- lift hlsSet
liftE $ rmMinorHLSSymlinks ver
hlsDir <- ghcupHLSDir ver
recyclePathForcibly hlsDir
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
rmPlainHLS
liftE rmPlainHLS
hlsDir <- ghcupHLSDir ver
lift (getInstalledFiles HLS (mkTVer ver)) >>= \case
Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir
forM_ files (liftIO . deleteFile . (\f -> hlsDir </> dropDrive f))
f <- recordedInstallationFile HLS (mkTVer ver)
liftIO $ deleteFile f
removeEmptyDirsRecursive hlsDir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir
when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
Nothing -> do
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
recyclePathForcibly hlsDir
when (Just ver == isHlsSet) $ do
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
Just latestver -> setHLS latestver SetHLSOnly Nothing
Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing
Nothing -> pure ()
@ -1946,15 +1992,15 @@ rmTool :: ( MonadReader env m
, MonadMask m
, MonadUnliftIO m)
=> ListResult
-> Excepts '[NotInstalled ] m ()
-> Excepts '[NotInstalled, UninstallFailed] m ()
rmTool ListResult {lVer, lTool, lCross} = do
case lTool of
GHC ->
let ghcTargetVersion = GHCTargetVersion lCross lVer
in rmGHCVer ghcTargetVersion
HLS -> rmHLSVer lVer
Cabal -> rmCabalVer lVer
Stack -> rmStackVer lVer
Cabal -> liftE $ rmCabalVer lVer
Stack -> liftE $ rmStackVer lVer
GHCup -> lift rmGhcup
@ -2005,12 +2051,12 @@ rmGhcupDirs = do
rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile enFilePath = do
logInfo "Removing Ghcup Environment File"
hideErrorDef [permissionErrorType] () $ deleteFile enFilePath
hideErrorDef [permissionErrorType] () $ deleteFile' enFilePath
rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmConfFile confFilePath = do
logInfo "removing Ghcup Config File"
hideErrorDef [permissionErrorType] () $ deleteFile confFilePath
hideErrorDef [permissionErrorType] () $ deleteFile' confFilePath
rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmDir dir =
@ -2020,7 +2066,7 @@ rmGhcupDirs = do
hideErrorDef [doesNotExistErrorType] () $ do
logInfo $ "removing " <> T.pack dir
contents <- liftIO $ getDirectoryContentsRecursive dir
forM_ contents (deleteFile . (dir </>))
forM_ contents (deleteFile' . (dir </>))
rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmBinDir binDir
@ -2049,24 +2095,17 @@ rmGhcupDirs = do
compareFn :: FilePath -> FilePath -> Ordering
compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeEmptyDirsRecursive fp = do
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs removeEmptyDirsRecursive
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
-- we expect only files inside cache/log dir
-- we report remaining files/dirs later,
-- hence the force/quiet mode in these delete functions below.
-- we expect only files inside cache/log dir
-- we report remaining files/dirs later,
-- hence the force/quiet mode in these delete functions below.
deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
deleteFile filepath = do
deleteFile' :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
deleteFile' filepath = do
hideError doesNotExistErrorType
$ hideError InappropriateType $ rmFile filepath
removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeDirIfEmptyOrIsSymlink filepath =
removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeDirIfEmptyOrIsSymlink filepath =
hideError UnsatisfiedConstraints $
handleIO' InappropriateType
(handleIfSym filepath)
@ -2075,9 +2114,14 @@ rmGhcupDirs = do
handleIfSym fp e = do
isSym <- liftIO $ pathIsSymbolicLink fp
if isSym
then deleteFile fp
then deleteFile' fp
else liftIO $ ioError e
removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeEmptyDirsRecursive fp = do
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs removeEmptyDirsRecursive
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
------------------
@ -2161,6 +2205,7 @@ compileGHC :: ( MonadMask m
, ProcessError
, CopyError
, BuildFailed
, UninstallFailed
]
m
GHCTargetVersion
@ -2252,7 +2297,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
(mBindist, bmk) <- liftE $ runBuildAction
tmpUnpack
Nothing
(do
b <- if hadrian
then compileHadrianBindist tver workdir ghcdir
@ -2387,7 +2431,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
Just bc -> liftIOException
doesNotExistErrorType
(FileDoesNotExistError bc)
(liftIO $ copyFile bc (build_mk workdir))
(liftIO $ copyFile bc (build_mk workdir) False)
Nothing ->
liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
@ -2453,8 +2497,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
<> ".tar"
<> takeExtension tar)
let tarPath = cacheDir </> tarName
copyFileE (workdir </> tar)
tarPath
copyFileE (workdir </> tar) tarPath False
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
pure tarPath
@ -2637,8 +2680,7 @@ upgradeGHCup mtarget force' fatal = do
lift $ logDebug $ "rm -f " <> T.pack destFile
lift $ hideError NoSuchThing $ recycleFile destFile
lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
copyFileE p
destFile
copyFileE p destFile False
lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> unless b $
@ -2793,7 +2835,7 @@ rmOldGHC :: ( MonadReader env m
, MonadMask m
, MonadUnliftIO m
)
=> Excepts '[NotInstalled] m ()
=> Excepts '[NotInstalled, UninstallFailed] m ()
rmOldGHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls
@ -2859,7 +2901,7 @@ rmHLSNoGHC :: ( MonadReader env m
, MonadFail m
, MonadUnliftIO m
)
=> Excepts '[NotInstalled] m ()
=> Excepts '[NotInstalled, UninstallFailed] m ()
rmHLSNoGHC = do
Dirs {..} <- getDirs
ghcs <- fmap rights getInstalledGHCs

7
lib/GHCup/Errors.hs
View File

@ -146,6 +146,13 @@ instance Pretty NotInstalled where
pPrint (NotInstalled tool ver) =
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
data UninstallFailed = UninstallFailed FilePath [FilePath]
deriving Show
instance Pretty UninstallFailed where
pPrint (UninstallFailed dir files) =
text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."
-- | An executable was expected to be in PATH, but was not found.
data NotFoundInPATH = NotFoundInPATH FilePath
deriving Show

1
lib/GHCup/Types.hs
View File

@ -443,6 +443,7 @@ data Dirs = Dirs
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
, dbDir :: FilePath
, recycleDir :: FilePath -- mainly used on windows
}
deriving (Show, GHC.Generic)

85
lib/GHCup/Utils.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
@ -71,7 +72,7 @@ import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts
import Optics
import Safe
import System.Directory hiding ( findFiles )
import System.Directory hiding ( findFiles, copyFile )
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
@ -86,6 +87,9 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
import qualified Data.List.NonEmpty as NE
import Text.PrettyPrint.HughesPJClass (prettyShow)
import Control.DeepSeq (force)
import GHC.IO (evaluate)
-- $setup
@ -1051,14 +1055,11 @@ runBuildAction :: ( MonadReader env m
, MonadCatch m
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a
-> Excepts e m a
runBuildAction bdir instdir action = do
runBuildAction bdir action = do
Settings {..} <- lift getSettings
let exAction = do
forM_ instdir $ \dir ->
hideError doesNotExistErrorType $ recyclePathForcibly dir
when (keepDirs == Never)
$ rmBDir bdir
v <-
@ -1089,6 +1090,26 @@ cleanUpOnError bdir action = do
flip onException (lift exAction) $ onE_ exAction action
-- | Clean up the given directory if the action fails,
-- depending on the Settings.
cleanFinally :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, HasLog env
, MonadUnliftIO m
, MonadFail m
, MonadCatch m
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
-> Excepts e m a
-> Excepts e m a
cleanFinally bdir action = do
Settings {..} <- lift getSettings
let exAction = when (keepDirs == Never) $ rmBDir bdir
flip finally (lift exAction) $ onE_ exAction action
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing.
@ -1194,7 +1215,7 @@ createLink link exe
rmLink exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe
liftIO $ copyFile shimGen exe False
liftIO $ writeFile shim shimContents
| otherwise = do
logDebug $ "rm -f " <> T.pack exe
@ -1234,7 +1255,7 @@ ensureGlobalTools
-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do
createDirRecursive' baseDir
createDirRecursive' (baseDir </> "ghc")
createDirRecursive' binDir
@ -1242,6 +1263,7 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
createDirRecursive' logsDir
createDirRecursive' confDir
createDirRecursive' trashDir
createDirRecursive' dbDir
pure ()
@ -1272,3 +1294,52 @@ installDestSanityCheck (IsolateDirResolved isoDir) = do
contents <- liftIO $ getDirectoryContentsRecursive isoDir
unless (null contents) (throwE $ DirNotEmpty isoDir)
installDestSanityCheck _ = pure ()
-- | Write installed files into database.
recordInstalledFiles :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadFail m
)
=> [FilePath]
-> Tool
-> GHCTargetVersion
-> m ()
recordInstalledFiles files tool v' = do
dest <- recordedInstallationFile tool v'
liftIO $ createDirectoryIfMissing True (takeDirectory dest)
-- TODO: what if the filepath has newline? :)
let contents = unlines files
liftIO $ writeFile dest contents
pure ()
-- | Returns 'Nothing' for legacy installs.
getInstalledFiles :: ( MonadIO m
, MonadCatch m
, MonadReader env m
, HasDirs env
, MonadFail m
)
=> Tool
-> GHCTargetVersion
-> m (Maybe [FilePath])
getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do
f <- recordedInstallationFile t v'
(force -> !c) <- liftIO
(readFile f >>= evaluate)
pure (Just $ lines c)
recordedInstallationFile :: ( MonadReader env m
, HasDirs env
)
=> Tool
-> GHCTargetVersion
-> m FilePath
recordedInstallationFile t v' = do
Dirs {..} <- getDirs
pure (dbDir </> prettyShow t </> T.unpack (tVerToText v'))

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

@ -180,6 +180,26 @@ ghcupLogsDir
else ghcupBaseDir <&> (</> "logs")
-- | Defaults to '~/.ghcup/db.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
ghcupDbDir :: IO FilePath
ghcupDbDir
| isWindows = ghcupBaseDir <&> (</> "db")
| otherwise = do
xdg <- useXDG
if xdg
then do
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "db")
else ghcupBaseDir <&> (</> "db")
-- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO FilePath
@ -195,6 +215,7 @@ getAllDirs = do
logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
recycleDir <- ghcupRecycleDir
dbDir <- ghcupDbDir
pure Dirs { .. }

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

@ -1,6 +1,16 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Utils.File (
mergeFileTree,
mergeFileTreeAll,
copyFileE,
module GHCup.Utils.File.Common,
#if IS_WINDOWS
module GHCup.Utils.File.Windows
@ -15,3 +25,79 @@ import GHCup.Utils.File.Windows
#else
import GHCup.Utils.File.Posix
#endif
import GHCup.Errors
import GHCup.Utils.Prelude
import GHC.IO ( evaluate )
import Control.Exception.Safe
import Haskus.Utils.Variant.Excepts
import Control.Monad.Reader
import System.Directory hiding (findFiles, copyFile)
import System.FilePath
import Data.List (nub)
import Data.Foldable (traverse_)
import Control.DeepSeq (force)
-- | Like 'mergeFileTree', except reads the entire source base dir to determine files to copy recursively.
mergeFileTreeAll :: MonadIO m
=> FilePath -- ^ source base directory from which to install findFiles
-> FilePath -- ^ destination base dir
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> m [FilePath]
mergeFileTreeAll sourceBase destBase copyOp = do
(force -> !sourceFiles) <- liftIO
(getDirectoryContentsRecursive sourceBase >>= evaluate)
mergeFileTree sourceBase sourceFiles destBase copyOp
pure sourceFiles
mergeFileTree :: MonadIO m
=> FilePath -- ^ source base directory from which to install findFiles
-> [FilePath] -- ^ relative filepaths from source base directory
-> FilePath -- ^ destination base dir
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> m ()
mergeFileTree sourceBase sources destBase copyOp = do
-- These checks are not atomic, but we perform them to have
-- the opportunity to abort before copying has started.
--
-- The actual copying might still fail.
liftIO baseCheck
liftIO destCheck
liftIO sourcesCheck
-- finally copy
copy
where
copy = do
let dirs = map (destBase </>) . nub . fmap takeDirectory $ sources
traverse_ (liftIO . createDirectoryIfMissing True) dirs
forM_ sources $ \source -> do
let dest = destBase </> source
src = sourceBase </> source
copyOp src dest
baseCheck = do
when (isRelative sourceBase)
$ throwIO $ userError ("mergeFileTree: source base directory " <> sourceBase <> " is not absolute!")
whenM (not <$> doesDirectoryExist sourceBase)
$ throwIO $ userError ("mergeFileTree: source base directory " <> sourceBase <> " does not exist!")
destCheck = do
when (isRelative destBase)
$ throwIO $ userError ("mergeFileTree: destination base directory " <> destBase <> " is not absolute!")
whenM (doesDirectoryExist destBase)
$ throwIO $ userError ("mergeFileTree: destination base directory " <> destBase <> " does already exist!")
sourcesCheck =
forM_ sources $ \source -> do
-- TODO: use Excepts or HPath
when (isAbsolute source)
$ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!")
whenM (not <$> doesFileExist (sourceBase </> source))
$ throwIO $ userError ("mergeFileTree: source file " <> (sourceBase </> source) <> " does not exist!")
copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to

8
lib/GHCup/Utils/File/Common.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
@ -15,14 +16,11 @@ import Data.Maybe
import Data.Text ( Text )
import Data.Void
import GHC.IO.Exception
import Optics hiding ((<|), (|>))
import System.Directory hiding (findFiles)
import System.Directory hiding (findFiles, copyFile)
import System.FilePath
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
import qualified Data.Text as T
import qualified Data.ByteString.Lazy as BL
import qualified Text.Megaparsec as MP
@ -109,3 +107,5 @@ findFiles' path parser = do
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
checkFileAlreadyExists fp = liftIO $ doesFileExist fp

168
lib/GHCup/Utils/File/Posix.hs
View File

@ -34,12 +34,16 @@ import Data.IORef
import Data.Sequence ( Seq, (|>) )
import Data.List
import Data.Word8
import Foreign.C.String
import Foreign.C.Types
import GHC.IO.Exception
import System.IO ( stderr )
import System.IO ( stderr, hClose, hSetBinaryMode )
import System.IO.Error
import System.FilePath
import System.Directory
import System.Directory hiding ( copyFile )
import System.Posix.Directory
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
import System.Posix.Internals ( withFilePath )
import System.Posix.Files
import System.Posix.IO
import System.Posix.Process ( ProcessStatus(..) )
@ -50,12 +54,20 @@ 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.Files as PF
import qualified System.Posix.Process as SPP
import qualified System.Posix.IO as SPI
import qualified System.Console.Terminal.Size as TP
import qualified System.Posix as Posix
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.FileSystem.Handle
as IFH
import qualified Streamly.Prelude as S
import qualified GHCup.Utils.File.Posix.Foreign as FD
@ -399,3 +411,155 @@ isBrokenSymlink fp = do
Right b -> pure b
Left e | isDoesNotExistError e -> pure False
| otherwise -> throwIO e
copyFile :: FilePath -- ^ source file
-> FilePath -- ^ destination file
-> Bool -- ^ fail if file exists
-> IO ()
copyFile from to fail' = do
bracket
(do
fd <- openFd' from SPI.ReadOnly [FD.oNofollow] Nothing
handle' <- SPI.fdToHandle fd
pure (fd, handle')
)
(\(_, handle') -> hClose handle')
$ \(fromFd, fH) -> do
sourceFileMode <- fileMode
<$> getFdStatus fromFd
let dflags =
[ FD.oNofollow
, case fail' of
True -> FD.oExcl
False -> FD.oTrunc
]
bracketeer
(do
fd <- openFd' to SPI.WriteOnly dflags $ Just sourceFileMode
handle' <- SPI.fdToHandle fd
pure (fd, handle')
)
(\(_, handle') -> hClose handle')
(\(_, handle') -> do
hClose handle'
case fail' of
-- if we created the file and copying failed, it's
-- safe to clean up
True -> PF.removeLink to
False -> pure ()
)
$ \(_, tH) -> do
hSetBinaryMode fH True
hSetBinaryMode tH True
streamlyCopy (fH, tH)
where
streamlyCopy (fH, tH) =
S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH
foreign import ccall unsafe "open"
c_open :: CString -> CInt -> Posix.CMode -> IO CInt
open_ :: CString
-> Posix.OpenMode
-> [FD.Flags]
-> Maybe Posix.FileMode
-> IO Posix.Fd
open_ str how optional_flags maybe_mode = do
fd <- c_open str all_flags mode_w
return (Posix.Fd fd)
where
all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat
(creat, mode_w) = case maybe_mode of
Nothing -> ([],0)
Just x -> ([FD.oCreat], x)
open_mode = case how of
Posix.ReadOnly -> FD.oRdonly
Posix.WriteOnly -> FD.oWronly
Posix.ReadWrite -> FD.oRdwr
-- |Open and optionally create this file. See 'System.Posix.Files'
-- for information on how to use the 'FileMode' type.
--
-- Note that passing @Just x@ as the 4th argument triggers the
-- `oCreat` status flag, which must be set when you pass in `oExcl`
-- to the status flags. Also see the manpage for @open(2)@.
openFd' :: FilePath
-> Posix.OpenMode
-> [FD.Flags] -- ^ status flags of @open(2)@
-> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist.
-> IO Posix.Fd
openFd' name how optional_flags maybe_mode =
withFilePath name $ \str ->
throwErrnoPathIfMinus1Retry "openFd" name $
open_ str how optional_flags maybe_mode
-- |Deletes the given file. Raises `eISDIR`
-- if run on a directory. Does not follow symbolic links.
--
-- Throws:
--
-- - `InappropriateType` for wrong file type (directory)
-- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if the directory cannot be read
--
-- Notes: calls `unlink`
deleteFile :: FilePath -> IO ()
deleteFile = removeLink
-- |Recreate a symlink.
--
-- In `Overwrite` copy mode only files and empty directories are deleted.
--
-- Safety/reliability concerns:
--
-- * `Overwrite` mode is inherently non-atomic
--
-- Throws:
--
-- - `InvalidArgument` if source file is wrong type (not a symlink)
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `SameFile` if source and destination are the same file
-- (`HPathIOException`)
--
--
-- Throws in `Strict` mode only:
--
-- - `AlreadyExists` if destination already exists
--
-- Throws in `Overwrite` mode only:
--
-- - `UnsatisfiedConstraints` if destination file is non-empty directory
--
-- Notes:
--
-- - calls `symlink`
recreateSymlink :: FilePath -- ^ the old symlink file
-> FilePath -- ^ destination file
-> Bool -- ^ fail if destination file exists
-> IO ()
recreateSymlink symsource newsym fail' = do
sympoint <- readSymbolicLink symsource
case fail' of
True -> pure ()
False ->
hideError doesNotExistErrorType $ deleteFile newsym
createSymbolicLink sympoint newsym
-- copys files, recreates symlinks, fails on all other types
install :: FilePath -> FilePath -> Bool -> IO ()
install from to fail' = do
fs <- PF.getSymbolicLinkStatus from
decide fs
where
decide fs | PF.isRegularFile fs = copyFile from to fail'
| PF.isSymbolicLink fs = recreateSymlink from to fail'
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)

77
lib/GHCup/Utils/File/Posix/Foreign.hsc Normal file
View File

@ -0,0 +1,77 @@
{-# LANGUAGE PatternSynonyms #-}
module GHCup.Utils.File.Posix.Foreign where
import Data.Bits
import Data.List (foldl')
import Foreign.C.Types
#include <limits.h>
#include <stdlib.h>
#include <dirent.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
newtype DirType = DirType Int deriving (Eq, Show)
data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show)
unFlags :: Flags -> Int
unFlags (Flags i) = i
unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform")
-- |Returns @True@ if posix-paths was compiled with support for the provided
-- flag. (As of this writing, the only flag for which this check may be
-- necessary is 'oCloexec'; all other flags will always yield @True@.)
isSupported :: Flags -> Bool
isSupported (Flags _) = True
isSupported _ = False
-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use
-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was
-- compiled into your version of posix-paths. (If not, using @oCloexec@ will
-- throw an exception.)
oCloexec :: Flags
#ifdef O_CLOEXEC
oCloexec = Flags #{const O_CLOEXEC}
#else
{-# WARNING oCloexec
"This version of posix-paths was compiled without @O_CLOEXEC@ support." #-}
oCloexec = UnsupportedFlag "O_CLOEXEC"
#endif
-- If these enum declarations occur earlier in the file, haddock
-- gets royally confused about the above doc comments.
-- Probably http://trac.haskell.org/haddock/ticket/138
#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN}
#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC}
pathMax :: Int
pathMax = #{const PATH_MAX}
unionFlags :: [Flags] -> CInt
unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0
pattern DtBlk :: DirType
pattern DtBlk <- dtBlk
pattern DtChr :: DirType
pattern DtChr <- dtChr
pattern DtDir :: DirType
pattern DtDir <- dtdir
pattern DtFifo :: DirType
pattern DtFifo <- dtFifo
pattern DtLnk :: DirType
pattern DtLnk <- dtLnk
pattern DtReg :: DirType
pattern DtReg <- dtReg
pattern DtSock :: DirType
pattern DtSock <- dtSock
pattern DtUnknown :: DirType
pattern DtUnknown <- dtUnknown
{-# COMPLETE DtBlk, DtChr, DtDir, DtFifo, DtLnk, DtReg, DtSock, DtUnknown #-}

16
lib/GHCup/Utils/File/Windows.hs
View File

@ -31,12 +31,13 @@ import Data.List
import Foreign.C.Error
import GHC.IO.Exception
import GHC.IO.Handle
import System.Directory
import System.Directory hiding ( copyFile )
import System.Environment
import System.FilePath
import System.IO
import System.Process
import qualified System.Win32.File as WS
import qualified Control.Exception as EX
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
@ -269,3 +270,16 @@ isBrokenSymlink fp = do
-- this drops 'symDir' if 'tfp' is absolute
(takeDirectory fp </> tfp)
else pure False
copyFile :: FilePath -- ^ source file
-> FilePath -- ^ destination file
-> Bool -- ^ fail if file exists
-> IO ()
copyFile = WS.copyFile
deleteFile :: FilePath -> IO ()
deleteFile = WS.deleteFile
install :: FilePath -> FilePath -> Bool -> IO ()
install = copyFile

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

@ -58,7 +58,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import System.IO.Error
import System.IO.Temp
import System.IO.Unsafe
import System.Directory
import System.Directory hiding ( copyFile )
import System.FilePath
import Control.Retry
@ -412,7 +412,7 @@ copyDirectoryRecursive srcDir destDir doCopy = do
copyFilesWith targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
let dirs = map (targetDir </>) . nub . map takeDirectory $ fmap snd srcFiles
traverse_ (createDirectoryIfMissing True) dirs
-- Copy all the files
@ -428,6 +428,7 @@ copyDirectoryRecursive srcDir destDir doCopy = do
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
-- TODO: use streamly
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
where
@ -549,10 +550,6 @@ recover action =
(\_ -> action)
copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from
-- | Gathering monoidal values
--
-- >>> traverseFold (pure . (:["0"])) ["1","2"]
@ -763,3 +760,20 @@ breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
breakOn _ [] = ([], [])
breakOn needle (x:xs) = first (x:) $ breakOn needle xs
-- |Like `bracket`, but allows to have different clean-up
-- actions depending on whether the in-between computation
-- has raised an exception or not.
bracketeer :: IO a -- ^ computation to run first
-> (a -> IO b) -- ^ computation to run last, when
-- no exception was raised
-> (a -> IO b) -- ^ computation to run last,
-- when an exception was raised
-> (a -> IO c) -- ^ computation to run in-between
-> IO c
bracketeer before after afterEx thing =
mask $ \restore -> do
a <- before
r <- restore (thing a) `onException` afterEx a
_ <- after a
return r

7
stack.yaml
View File

@ -26,7 +26,7 @@ extra-deps:
- hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
- libarchive-3.0.3.0
- libyaml-streamly-0.2.0
- libyaml-streamly-0.2.1
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
- optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
- optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
@ -35,10 +35,11 @@ extra-deps:
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
- regex-posix-clib-2.7
- streamly-0.8.0@sha256:9784c80ee1ada51477520cabc4e92a0c76a6bb265f968a188f2fce818e7398e0,19654
- streamly-0.8.2@sha256:ec521b7c1c4db068501c35804af77f40b7d34232f5e29d9b99e722229040eb80,23500
- unicode-data-0.3.0@sha256:0545e079705a5381d0893f8fe8daaa08fc9174baeab269b9cf651817d8eadbc6,5123
- strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
- yaml-streamly-0.12.0
- yaml-streamly-0.12.1
flags:
http-io-streams: