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: "Avoid lambda"}
- ignore: {name: "Use uncurry"} - ignore: {name: "Use uncurry"}
- ignore: {name: "Use replicateM"} - ignore: {name: "Use replicateM"}
- ignore: {name: "Use unless"}
- ignore: {name: "Redundant irrefutable pattern"} - ignore: {name: "Redundant irrefutable pattern"}

3
app/ghcup/BrickMain.hs
View File

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

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

@ -388,6 +388,7 @@ type GHCEffects = '[ AlreadyInstalled
, ProcessError , ProcessError
, CopyError , CopyError
, BuildFailed , BuildFailed
, UninstallFailed
] ]
type HLSEffects = '[ AlreadyInstalled type HLSEffects = '[ AlreadyInstalled
, BuildFailed , BuildFailed
@ -406,6 +407,7 @@ type HLSEffects = '[ AlreadyInstalled
, NotInstalled , NotInstalled
, DirNotEmpty , DirNotEmpty
, ArchiveResult , 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 runGC :: MonadUnliftIO m
@ -129,7 +129,7 @@ gc :: ( Monad m
-> (ReaderT LeanAppState m () -> m ()) -> (ReaderT LeanAppState m () -> m ())
-> m ExitCode -> m ExitCode
gc GCOptions{..} runAppState runLogger = runGC runAppState (do gc GCOptions{..} runAppState runLogger = runGC runAppState (do
when gcOldGHC rmOldGHC when gcOldGHC (liftE rmOldGHC)
lift $ when gcProfilingLibs rmProfilingLibs lift $ when gcProfilingLibs rmProfilingLibs
lift $ when gcShareDir rmShareDir lift $ when gcShareDir rmShareDir
liftE $ when gcHLSNoGHC rmHLSNoGHC liftE $ when gcHLSNoGHC rmHLSNoGHC

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

@ -257,6 +257,7 @@ type InstallEffects = '[ AlreadyInstalled
, NoToolVersionSet , NoToolVersionSet
, FileAlreadyExistsError , FileAlreadyExistsError
, ProcessError , ProcessError
, UninstallFailed
, (AlreadyInstalled, ()) , (AlreadyInstalled, ())
, (UnknownArchive, ()) , (UnknownArchive, ())
@ -264,9 +265,9 @@ type InstallEffects = '[ AlreadyInstalled
, (FileDoesNotExistError, ()) , (FileDoesNotExistError, ())
, (CopyError, ()) , (CopyError, ())
, (NotInstalled, ()) , (NotInstalled, ())
, (UninstallFailed, ())
, (DirNotEmpty, ()) , (DirNotEmpty, ())
, (NoDownload, ()) , (NoDownload, ())
, (NotInstalled, ())
, (BuildFailed, ()) , (BuildFailed, ())
, (TagNotFound, ()) , (TagNotFound, ())
, (DigestError, ()) , (DigestError, ())
@ -287,6 +288,7 @@ type InstallEffects = '[ AlreadyInstalled
, (DirNotEmpty, NotInstalled) , (DirNotEmpty, NotInstalled)
, (NoDownload, NotInstalled) , (NoDownload, NotInstalled)
, (NotInstalled, NotInstalled) , (NotInstalled, NotInstalled)
, (UninstallFailed, NotInstalled)
, (BuildFailed, NotInstalled) , (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled) , (TagNotFound, NotInstalled)
, (DigestError, NotInstalled) , (DigestError, NotInstalled)
@ -319,6 +321,7 @@ type InstallGHCEffects = '[ TagNotFound
, BuildFailed , BuildFailed
, DirNotEmpty , DirNotEmpty
, AlreadyInstalled , AlreadyInstalled
, UninstallFailed
, (AlreadyInstalled, NotInstalled) , (AlreadyInstalled, NotInstalled)
, (UnknownArchive, NotInstalled) , (UnknownArchive, NotInstalled)
@ -328,6 +331,7 @@ type InstallGHCEffects = '[ TagNotFound
, (NotInstalled, NotInstalled) , (NotInstalled, NotInstalled)
, (DirNotEmpty, NotInstalled) , (DirNotEmpty, NotInstalled)
, (NoDownload, NotInstalled) , (NoDownload, NotInstalled)
, (UninstallFailed, NotInstalled)
, (BuildFailed, NotInstalled) , (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled) , (TagNotFound, NotInstalled)
, (DigestError, NotInstalled) , (DigestError, NotInstalled)
@ -347,6 +351,7 @@ type InstallGHCEffects = '[ TagNotFound
, (NotInstalled, ()) , (NotInstalled, ())
, (DirNotEmpty, ()) , (DirNotEmpty, ())
, (NoDownload, ()) , (NoDownload, ())
, (UninstallFailed, ())
, (BuildFailed, ()) , (BuildFailed, ())
, (TagNotFound, ()) , (TagNotFound, ())
, (DigestError, ()) , (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 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)) 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 , NoToolVersionSet
, FileAlreadyExistsError , FileAlreadyExistsError
, ProcessError , ProcessError
, UninstallFailed
] ]
runLeanRUN :: (MonadUnliftIO m, MonadIO m) runLeanRUN :: (MonadUnliftIO m, MonadIO m)
@ -339,6 +340,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
, AlreadyInstalled , AlreadyInstalled
, FileAlreadyExistsError , FileAlreadyExistsError
, CopyError , CopyError
, UninstallFailed
] (ResourceT (ReaderT AppState m)) () ] (ResourceT (ReaderT AppState m)) ()
installToolChainFull Toolchain{..} tmp = do installToolChainFull Toolchain{..} tmp = do
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> 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 cabal-version: 3.0
name: ghcup name: ghcup
version: 0.1.17.8 version: 0.1.18.0
license: LGPL-3.0-only license: LGPL-3.0-only
license-file: LICENSE license-file: LICENSE
copyright: Julian Ospald 2020 copyright: Julian Ospald 2020
@ -127,6 +127,7 @@ library
, safe-exceptions ^>=0.1 , safe-exceptions ^>=0.1
, split ^>=0.2.3.4 , split ^>=0.2.3.4
, strict-base ^>=0.4 , strict-base ^>=0.4
, streamly ^>=0.8.2
, template-haskell >=2.7 && <2.18 , template-haskell >=2.7 && <2.18
, temporary ^>=1.3 , temporary ^>=1.3
, text ^>=1.2.4.0 , text ^>=1.2.4.0
@ -165,6 +166,7 @@ library
else else
other-modules: other-modules:
GHCup.Utils.File.Posix GHCup.Utils.File.Posix
GHCup.Utils.File.Posix.Foreign
GHCup.Utils.Posix GHCup.Utils.Posix
GHCup.Utils.Prelude.Posix GHCup.Utils.Prelude.Posix

208
lib/GHCup.hs
View File

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

7
lib/GHCup/Errors.hs
View File

@ -146,6 +146,13 @@ instance Pretty NotInstalled where
pPrint (NotInstalled tool ver) = pPrint (NotInstalled tool ver) =
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed." 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. -- | An executable was expected to be in PATH, but was not found.
data NotFoundInPATH = NotFoundInPATH FilePath data NotFoundInPATH = NotFoundInPATH FilePath
deriving Show deriving Show

1
lib/GHCup/Types.hs
View File

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

85
lib/GHCup/Utils.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -71,7 +72,7 @@ import GHC.IO.Exception
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Optics import Optics
import Safe import Safe
import System.Directory hiding ( findFiles ) import System.Directory hiding ( findFiles, copyFile )
import System.FilePath import System.FilePath
import System.IO.Error import System.IO.Error
import Text.Regex.Posix import Text.Regex.Posix
@ -86,6 +87,9 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Text.PrettyPrint.HughesPJClass (prettyShow)
import Control.DeepSeq (force)
import GHC.IO (evaluate)
-- $setup -- $setup
@ -1051,14 +1055,11 @@ runBuildAction :: ( MonadReader env m
, MonadCatch m , MonadCatch m
) )
=> FilePath -- ^ build directory (cleaned up depending on Settings) => 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
-> Excepts e m a -> Excepts e m a
runBuildAction bdir instdir action = do runBuildAction bdir action = do
Settings {..} <- lift getSettings Settings {..} <- lift getSettings
let exAction = do let exAction = do
forM_ instdir $ \dir ->
hideError doesNotExistErrorType $ recyclePathForcibly dir
when (keepDirs == Never) when (keepDirs == Never)
$ rmBDir bdir $ rmBDir bdir
v <- v <-
@ -1089,6 +1090,26 @@ cleanUpOnError bdir action = do
flip onException (lift exAction) $ onE_ exAction action 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 -- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing. -- printing other errors without crashing.
@ -1194,7 +1215,7 @@ createLink link exe
rmLink exe rmLink exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe liftIO $ copyFile shimGen exe False
liftIO $ writeFile shim shimContents liftIO $ writeFile shim shimContents
| otherwise = do | otherwise = do
logDebug $ "rm -f " <> T.pack exe logDebug $ "rm -f " <> T.pack exe
@ -1234,7 +1255,7 @@ ensureGlobalTools
-- | Ensure ghcup directory structure exists. -- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO () 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
createDirRecursive' (baseDir </> "ghc") createDirRecursive' (baseDir </> "ghc")
createDirRecursive' binDir createDirRecursive' binDir
@ -1242,6 +1263,7 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
createDirRecursive' logsDir createDirRecursive' logsDir
createDirRecursive' confDir createDirRecursive' confDir
createDirRecursive' trashDir createDirRecursive' trashDir
createDirRecursive' dbDir
pure () pure ()
@ -1272,3 +1294,52 @@ installDestSanityCheck (IsolateDirResolved isoDir) = do
contents <- liftIO $ getDirectoryContentsRecursive isoDir contents <- liftIO $ getDirectoryContentsRecursive isoDir
unless (null contents) (throwE $ DirNotEmpty isoDir) unless (null contents) (throwE $ DirNotEmpty isoDir)
installDestSanityCheck _ = pure () 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") 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'. -- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations -- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO FilePath ghcupRecycleDir :: IO FilePath
@ -195,6 +215,7 @@ getAllDirs = do
logsDir <- ghcupLogsDir logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir confDir <- ghcupConfigDir
recycleDir <- ghcupRecycleDir recycleDir <- ghcupRecycleDir
dbDir <- ghcupDbDir
pure Dirs { .. } pure Dirs { .. }

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

@ -1,6 +1,16 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Utils.File ( module GHCup.Utils.File (
mergeFileTree,
mergeFileTreeAll,
copyFileE,
module GHCup.Utils.File.Common, module GHCup.Utils.File.Common,
#if IS_WINDOWS #if IS_WINDOWS
module GHCup.Utils.File.Windows module GHCup.Utils.File.Windows
@ -15,3 +25,79 @@ import GHCup.Utils.File.Windows
#else #else
import GHCup.Utils.File.Posix import GHCup.Utils.File.Posix
#endif #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 OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -15,14 +16,11 @@ import Data.Maybe
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Void import Data.Void
import GHC.IO.Exception import GHC.IO.Exception
import Optics hiding ((<|), (|>)) import System.Directory hiding (findFiles, copyFile)
import System.Directory hiding (findFiles)
import System.FilePath import System.FilePath
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix import Text.Regex.Posix
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.ByteString.Lazy as BL
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
@ -109,3 +107,5 @@ findFiles' path parser = do
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
checkFileAlreadyExists fp = liftIO $ doesFileExist fp 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.Sequence ( Seq, (|>) )
import Data.List import Data.List
import Data.Word8 import Data.Word8
import Foreign.C.String
import Foreign.C.Types
import GHC.IO.Exception import GHC.IO.Exception
import System.IO ( stderr ) import System.IO ( stderr, hClose, hSetBinaryMode )
import System.IO.Error import System.IO.Error
import System.FilePath import System.FilePath
import System.Directory import System.Directory hiding ( copyFile )
import System.Posix.Directory import System.Posix.Directory
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
import System.Posix.Internals ( withFilePath )
import System.Posix.Files import System.Posix.Files
import System.Posix.IO import System.Posix.IO
import System.Posix.Process ( ProcessStatus(..) ) import System.Posix.Process ( ProcessStatus(..) )
@ -50,12 +54,20 @@ import qualified Control.Exception as EX
import qualified Data.Sequence as Sq import qualified Data.Sequence as Sq
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E 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.Process as SPP
import qualified System.Posix.IO as SPI
import qualified System.Console.Terminal.Size as TP import qualified System.Console.Terminal.Size as TP
import qualified System.Posix as Posix
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified "unix-bytestring" System.Posix.IO.ByteString import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB 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 Right b -> pure b
Left e | isDoesNotExistError e -> pure False Left e | isDoesNotExistError e -> pure False
| otherwise -> throwIO e | 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 Foreign.C.Error
import GHC.IO.Exception import GHC.IO.Exception
import GHC.IO.Handle import GHC.IO.Handle
import System.Directory import System.Directory hiding ( copyFile )
import System.Environment import System.Environment
import System.FilePath import System.FilePath
import System.IO import System.IO
import System.Process import System.Process
import qualified System.Win32.File as WS
import qualified Control.Exception as EX import qualified Control.Exception as EX
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
@ -269,3 +270,16 @@ isBrokenSymlink fp = do
-- this drops 'symDir' if 'tfp' is absolute -- this drops 'symDir' if 'tfp' is absolute
(takeDirectory fp </> tfp) (takeDirectory fp </> tfp)
else pure False 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.Error
import System.IO.Temp import System.IO.Temp
import System.IO.Unsafe import System.IO.Unsafe
import System.Directory import System.Directory hiding ( copyFile )
import System.FilePath import System.FilePath
import Control.Retry import Control.Retry
@ -412,7 +412,7 @@ copyDirectoryRecursive srcDir destDir doCopy = do
copyFilesWith targetDir srcFiles = do copyFilesWith targetDir srcFiles = do
-- Create parent directories for everything -- 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 traverse_ (createDirectoryIfMissing True) dirs
-- Copy all the files -- 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 -- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used. -- the source directory structure changes before the list is used.
-- --
-- TODO: use streamly
getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""] getDirectoryContentsRecursive topdir = recurseDirectories [""]
where where
@ -549,10 +550,6 @@ recover action =
(\_ -> 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 -- | Gathering monoidal values
-- --
-- >>> traverseFold (pure . (:["0"])) ["1","2"] -- >>> traverseFold (pure . (:["0"])) ["1","2"]
@ -763,3 +760,20 @@ breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
breakOn _ [] = ([], []) breakOn _ [] = ([], [])
breakOn needle (x:xs) = first (x:) $ breakOn needle xs 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 - hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
- http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582 - http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
- libarchive-3.0.3.0 - libarchive-3.0.3.0
- libyaml-streamly-0.2.0 - libyaml-streamly-0.2.1
- lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308 - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
- optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568 - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
- optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995 - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
@ -35,10 +35,11 @@ extra-deps:
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716 - os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
- primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728 - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
- regex-posix-clib-2.7 - 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 - strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243 - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
- yaml-streamly-0.12.0 - yaml-streamly-0.12.1
flags: flags:
http-io-streams: http-io-streams: