From 8c486e8d4673112e6da57e7c6dcc17bd8c35a61f Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Mon, 23 Aug 2021 20:18:45 +0530 Subject: [PATCH 1/2] Make GHCup isolate installs non-overwriting by default --- lib/GHCup.hs | 44 +++++++++++++++++++++++++++------- lib/GHCup/Utils/File/Common.hs | 3 +++ 2 files changed, 38 insertions(+), 9 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 752ef5b..ee563f6 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -483,6 +483,10 @@ installCabalUnpacked path inst mver' = do <> maybe "" (("-" <>) . T.unpack . prettyVer) mver' <> exeExt let destPath = inst destFileName + + whenM (checkFileAlreadyExists destPath) + (throwE $ FileAlreadyExistsError destPath) + handleIO (throwE . CopyError . show) $ liftIO $ copyFile (path cabalFile <> exeExt) destPath @@ -556,6 +560,7 @@ installHLSBindist :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif + , FileAlreadyExistsError ] m () @@ -603,7 +608,7 @@ installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) -> FilePath -- ^ Path to install to -> Maybe Version -- ^ Nothing for isolated install - -> Excepts '[CopyError] m () + -> Excepts '[CopyError, FileAlreadyExistsError] m () installHLSUnpacked path inst mver' = do lift $ $(logInfo) "Installing HLS" liftIO $ createDirRecursive' inst @@ -619,20 +624,34 @@ installHLSUnpacked path inst mver' = do let toF = dropSuffix exeExt f <> maybe "" (("~" <>) . T.unpack . prettyVer) mver' <> exeExt + + let srcPath = path f + let destPath = inst toF + + whenM (checkFileAlreadyExists destPath) + (throwE $ FileAlreadyExistsError destPath) + handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path f) - (inst toF) - lift $ chmod_755 (inst toF) + srcPath + destPath + lift $ chmod_755 destPath -- install haskell-language-server-wrapper let wrapper = "haskell-language-server-wrapper" toF = wrapper <> maybe "" (("-" <>) . T.unpack . prettyVer) mver' <> exeExt + srcWrapperPath = path wrapper <> exeExt + destWrapperPath = inst toF + + whenM (checkFileAlreadyExists destWrapperPath) + (throwE $ FileAlreadyExistsError destWrapperPath) + handleIO (throwE . CopyError . show) $ liftIO $ copyFile - (path wrapper <> exeExt) - (inst toF) - lift $ chmod_755 (inst toF) + srcWrapperPath + destWrapperPath + + lift $ chmod_755 destWrapperPath -- | Installs hls binaries @haskell-language-server-\@ -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. @@ -663,6 +682,7 @@ installHLSBin :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif + , FileAlreadyExistsError ] m () @@ -701,6 +721,7 @@ installStackBin :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif + , FileAlreadyExistsError ] m () @@ -738,6 +759,7 @@ installStackBindist :: ( MonadMask m #if !defined(TAR) , ArchiveResult #endif + , FileAlreadyExistsError ] m () @@ -783,7 +805,7 @@ installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) -> FilePath -- ^ Path to install to -> Maybe Version -- ^ Nothing for isolated installs - -> Excepts '[CopyError] m () + -> Excepts '[CopyError, FileAlreadyExistsError] m () installStackUnpacked path inst mver' = do lift $ $(logInfo) "Installing stack" let stackFile = "stack" @@ -791,7 +813,11 @@ installStackUnpacked path inst mver' = do let destFileName = stackFile <> maybe "" (("-" <>) . T.unpack . prettyVer) mver' <> exeExt - let destPath = inst destFileName + destPath = inst destFileName + + whenM (checkFileAlreadyExists destPath) + (throwE $ FileAlreadyExistsError destPath) + handleIO (throwE . CopyError . show) $ liftIO $ copyFile (path stackFile <> exeExt) destPath diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index cb0854e..790e734 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -104,3 +104,6 @@ findFiles path regex = do contents <- listDirectory path pure $ filter (match regex) contents + +checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool +checkFileAlreadyExists fp = liftIO $ doesFileExist fp From df758d828bf8861accb1ed424d021ae3eaff31fd Mon Sep 17 00:00:00 2001 From: Arjun Kathuria Date: Tue, 24 Aug 2021 20:39:07 +0530 Subject: [PATCH 2/2] swap checkFileAlreadyExists with throwIfFileAlreadyExists --- lib/GHCup.hs | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index ee563f6..afc6552 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -484,8 +484,7 @@ installCabalUnpacked path inst mver' = do <> exeExt let destPath = inst destFileName - whenM (checkFileAlreadyExists destPath) - (throwE $ FileAlreadyExistsError destPath) + liftE $ throwIfFileAlreadyExists destPath handleIO (throwE . CopyError . show) $ liftIO $ copyFile (path cabalFile <> exeExt) @@ -627,9 +626,8 @@ installHLSUnpacked path inst mver' = do let srcPath = path f let destPath = inst toF - - whenM (checkFileAlreadyExists destPath) - (throwE $ FileAlreadyExistsError destPath) + + liftE $ throwIfFileAlreadyExists destPath handleIO (throwE . CopyError . show) $ liftIO $ copyFile srcPath @@ -644,8 +642,7 @@ installHLSUnpacked path inst mver' = do srcWrapperPath = path wrapper <> exeExt destWrapperPath = inst toF - whenM (checkFileAlreadyExists destWrapperPath) - (throwE $ FileAlreadyExistsError destWrapperPath) + liftE $ throwIfFileAlreadyExists destWrapperPath handleIO (throwE . CopyError . show) $ liftIO $ copyFile srcWrapperPath @@ -815,8 +812,7 @@ installStackUnpacked path inst mver' = do <> exeExt destPath = inst destFileName - whenM (checkFileAlreadyExists destPath) - (throwE $ FileAlreadyExistsError destPath) + liftE $ throwIfFileAlreadyExists destPath handleIO (throwE . CopyError . show) $ liftIO $ copyFile (path stackFile <> exeExt) @@ -2380,4 +2376,10 @@ whereIsTool tool ver@GHCTargetVersion {..} = do liftIO $ canonicalizePath currentRunningExecPath +throwIfFileAlreadyExists :: ( MonadIO m ) => + FilePath -> + Excepts '[FileAlreadyExistsError] m () + +throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp) + (throwE $ FileAlreadyExistsError fp)