From 48aee1e76ccafacf1b46339e792e84d740d922f7 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 12 May 2022 17:58:40 +0200 Subject: [PATCH] [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. --- .hlint.yaml | 1 + app/ghcup/BrickMain.hs | 3 +- app/ghcup/GHCup/OptParse/Compile.hs | 2 + app/ghcup/GHCup/OptParse/GC.hs | 4 +- app/ghcup/GHCup/OptParse/Install.hs | 7 +- app/ghcup/GHCup/OptParse/Nuke.hs | 2 +- app/ghcup/GHCup/OptParse/Rm.hs | 2 +- app/ghcup/GHCup/OptParse/Run.hs | 2 + ghcup.cabal | 4 +- lib/GHCup.hs | 208 +++++++++++++++---------- lib/GHCup/Errors.hs | 7 + lib/GHCup/Types.hs | 1 + lib/GHCup/Utils.hs | 85 +++++++++- lib/GHCup/Utils/Dirs.hs | 25 ++- lib/GHCup/Utils/File.hs | 86 ++++++++++ lib/GHCup/Utils/File/Common.hs | 8 +- lib/GHCup/Utils/File/Posix.hs | 168 +++++++++++++++++++- lib/GHCup/Utils/File/Posix/Foreign.hsc | 77 +++++++++ lib/GHCup/Utils/File/Windows.hs | 18 ++- lib/GHCup/Utils/Prelude.hs | 26 +++- lib/GHCup/Utils/Prelude/Posix.hs | 2 +- stack.yaml | 7 +- 22 files changed, 628 insertions(+), 117 deletions(-) create mode 100644 lib/GHCup/Utils/File/Posix/Foreign.hsc diff --git a/.hlint.yaml b/.hlint.yaml index 3540f0e..e7fea9c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -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"} diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index de367e8..19499ca 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index 6989af9..f15793f 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -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 ] diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs index f8a1310..b3a28f7 100644 --- a/app/ghcup/GHCup/OptParse/GC.hs +++ b/app/ghcup/GHCup/OptParse/GC.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 363ce51..4c3d5b1 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -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, ()) diff --git a/app/ghcup/GHCup/OptParse/Nuke.hs b/app/ghcup/GHCup/OptParse/Nuke.hs index 75537de..43bcc7c 100644 --- a/app/ghcup/GHCup/OptParse/Nuke.hs +++ b/app/ghcup/GHCup/OptParse/Nuke.hs @@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay) --------------------------- -type NukeEffects = '[ NotInstalled ] +type NukeEffects = '[ NotInstalled, UninstallFailed ] runNuke :: AppState diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs index 591840e..d91faef 100644 --- a/app/ghcup/GHCup/OptParse/Rm.hs +++ b/app/ghcup/GHCup/OptParse/Rm.hs @@ -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)) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 7f95021..78393f8 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -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 diff --git a/ghcup.cabal b/ghcup.cabal index 64889bc..6a12eca 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index be7c681..c8c6c4a 100644 --- a/lib/GHCup.hs +++ b/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-\@ 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 diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index df72bd2..33c8332 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 93b985e..6286347 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index e142cc9..37f7444 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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')) + + diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index b2fb7eb..6a060b0 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -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 { .. } diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 9f74867..a08c981 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -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 diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index 4818fa9..f72e38c 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -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 + + diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index ac60b3c..94c023b 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -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) diff --git a/lib/GHCup/Utils/File/Posix/Foreign.hsc b/lib/GHCup/Utils/File/Posix/Foreign.hsc new file mode 100644 index 0000000..59cbe74 --- /dev/null +++ b/lib/GHCup/Utils/File/Posix/Foreign.hsc @@ -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 +#include +#include +#include +#include +#include + +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 #-} diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Utils/File/Windows.hs index 5942531..4d70422 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Utils/File/Windows.hs @@ -31,12 +31,13 @@ import Data.List import Foreign.C.Error import GHC.IO.Exception import GHC.IO.Handle -import System.Directory +import System.Directory hiding ( copyFile ) import System.Environment import System.FilePath import System.IO import System.Process - + +import qualified System.Win32.File as WS import qualified Control.Exception as EX import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL @@ -269,3 +270,16 @@ isBrokenSymlink fp = do -- this drops 'symDir' if 'tfp' is absolute (takeDirectory fp tfp) else pure False + + +copyFile :: FilePath -- ^ source file + -> FilePath -- ^ destination file + -> Bool -- ^ fail if file exists + -> IO () +copyFile = WS.copyFile + +deleteFile :: FilePath -> IO () +deleteFile = WS.deleteFile + +install :: FilePath -> FilePath -> Bool -> IO () +install = copyFile diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index db2fbdc..40ae60d 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -58,7 +58,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) import System.IO.Error import System.IO.Temp import System.IO.Unsafe -import System.Directory +import System.Directory hiding ( copyFile ) import System.FilePath import Control.Retry @@ -412,7 +412,7 @@ copyDirectoryRecursive srcDir destDir doCopy = do copyFilesWith targetDir srcFiles = do -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + let dirs = map (targetDir ) . nub . map takeDirectory $ fmap snd srcFiles traverse_ (createDirectoryIfMissing True) dirs -- Copy all the files @@ -428,6 +428,7 @@ copyDirectoryRecursive srcDir destDir doCopy = do -- parent directories. The list is generated lazily so is not well defined if -- the source directory structure changes before the list is used. -- +-- TODO: use streamly getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive topdir = recurseDirectories [""] where @@ -549,10 +550,6 @@ recover action = (\_ -> action) -copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m () -copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from - - -- | Gathering monoidal values -- -- >>> traverseFold (pure . (:["0"])) ["1","2"] @@ -763,3 +760,20 @@ breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack) breakOn _ [] = ([], []) breakOn needle (x:xs) = first (x:) $ breakOn needle xs + +-- |Like `bracket`, but allows to have different clean-up +-- actions depending on whether the in-between computation +-- has raised an exception or not. +bracketeer :: IO a -- ^ computation to run first + -> (a -> IO b) -- ^ computation to run last, when + -- no exception was raised + -> (a -> IO b) -- ^ computation to run last, + -- when an exception was raised + -> (a -> IO c) -- ^ computation to run in-between + -> IO c +bracketeer before after afterEx thing = + mask $ \restore -> do + a <- before + r <- restore (thing a) `onException` afterEx a + _ <- after a + return r diff --git a/lib/GHCup/Utils/Prelude/Posix.hs b/lib/GHCup/Utils/Prelude/Posix.hs index 22ae3cb..f677a68 100644 --- a/lib/GHCup/Utils/Prelude/Posix.hs +++ b/lib/GHCup/Utils/Prelude/Posix.hs @@ -17,4 +17,4 @@ moveFilePortable :: FilePath -> FilePath -> IO () moveFilePortable from to = do copyFile from to removeFile from - + diff --git a/stack.yaml b/stack.yaml index 14c8bbf..6357d4f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -26,7 +26,7 @@ extra-deps: - hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179 - http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582 - libarchive-3.0.3.0 - - libyaml-streamly-0.2.0 + - libyaml-streamly-0.2.1 - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308 - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568 - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995 @@ -35,10 +35,11 @@ extra-deps: - os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716 - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728 - regex-posix-clib-2.7 - - streamly-0.8.0@sha256:9784c80ee1ada51477520cabc4e92a0c76a6bb265f968a188f2fce818e7398e0,19654 + - streamly-0.8.2@sha256:ec521b7c1c4db068501c35804af77f40b7d34232f5e29d9b99e722229040eb80,23500 + - unicode-data-0.3.0@sha256:0545e079705a5381d0893f8fe8daaa08fc9174baeab269b9cf651817d8eadbc6,5123 - strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248 - xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243 - - yaml-streamly-0.12.0 + - yaml-streamly-0.12.1 flags: http-io-streams: