[WIP] Prototype of recording installed files
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:
parent
e60b8ee238
commit
48aee1e76c
@ -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"}
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
]
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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, ())
|
||||
|
@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay)
|
||||
---------------------------
|
||||
|
||||
|
||||
type NukeEffects = '[ NotInstalled ]
|
||||
type NukeEffects = '[ NotInstalled, UninstallFailed ]
|
||||
|
||||
|
||||
runNuke :: AppState
|
||||
|
@ -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))
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
208
lib/GHCup.hs
208
lib/GHCup.hs
@ -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,8 +1795,19 @@ 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
|
||||
lift $ recyclePathForcibly 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' <-
|
||||
handle
|
||||
@ -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,35 +2095,33 @@ 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.
|
||||
|
||||
deleteFile' :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
|
||||
deleteFile' filepath = do
|
||||
hideError doesNotExistErrorType
|
||||
$ hideError InappropriateType $ rmFile filepath
|
||||
|
||||
-- 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
|
||||
hideError doesNotExistErrorType
|
||||
$ hideError InappropriateType $ rmFile filepath
|
||||
|
||||
removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||
removeDirIfEmptyOrIsSymlink filepath =
|
||||
hideError UnsatisfiedConstraints $
|
||||
handleIO' InappropriateType
|
||||
(handleIfSym filepath)
|
||||
(liftIO $ rmDirectory filepath)
|
||||
where
|
||||
handleIfSym fp e = do
|
||||
isSym <- liftIO $ pathIsSymbolicLink fp
|
||||
if isSym
|
||||
then deleteFile fp
|
||||
else liftIO $ ioError e
|
||||
removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||
removeDirIfEmptyOrIsSymlink filepath =
|
||||
hideError UnsatisfiedConstraints $
|
||||
handleIO' InappropriateType
|
||||
(handleIfSym filepath)
|
||||
(liftIO $ rmDirectory filepath)
|
||||
where
|
||||
handleIfSym fp e = do
|
||||
isSym <- liftIO $ pathIsSymbolicLink fp
|
||||
if isSym
|
||||
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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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'))
|
||||
|
||||
|
||||
|
@ -53,8 +53,8 @@ import Data.Versions
|
||||
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import System.Directory
|
||||
import System.DiskSpace
|
||||
import System.Directory
|
||||
import System.DiskSpace
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO.Temp
|
||||
@ -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 { .. }
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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
77
lib/GHCup/Utils/File/Posix/Foreign.hsc
Normal 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
|
||||