Make GHCup isolate installs non-overwriting by default

This commit is contained in:
Arjun Kathuria 2021-08-23 20:18:45 +05:30
parent a0c2a5ccec
commit 8c486e8d46
2 changed files with 38 additions and 9 deletions

View File

@ -483,6 +483,10 @@ installCabalUnpacked path inst mver' = do
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver' <> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> exeExt <> exeExt
let destPath = inst </> destFileName let destPath = inst </> destFileName
whenM (checkFileAlreadyExists destPath)
(throwE $ FileAlreadyExistsError destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile <> exeExt) (path </> cabalFile <> exeExt)
destPath destPath
@ -556,6 +560,7 @@ installHLSBindist :: ( MonadMask m
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
, FileAlreadyExistsError
] ]
m 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 the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install -> Maybe Version -- ^ Nothing for isolated install
-> Excepts '[CopyError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpacked path inst mver' = do installHLSUnpacked path inst mver' = do
lift $ $(logInfo) "Installing HLS" lift $ $(logInfo) "Installing HLS"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
@ -619,20 +624,34 @@ installHLSUnpacked path inst mver' = do
let toF = dropSuffix exeExt f let toF = dropSuffix exeExt f
<> maybe "" (("~" <>) . T.unpack . prettyVer) mver' <> maybe "" (("~" <>) . T.unpack . prettyVer) mver'
<> exeExt <> exeExt
let srcPath = path </> f
let destPath = inst </> toF
whenM (checkFileAlreadyExists destPath)
(throwE $ FileAlreadyExistsError destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> f) srcPath
(inst </> toF) destPath
lift $ chmod_755 (inst </> toF) lift $ chmod_755 destPath
-- install haskell-language-server-wrapper -- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper" let wrapper = "haskell-language-server-wrapper"
toF = wrapper toF = wrapper
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver' <> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> exeExt <> exeExt
srcWrapperPath = path </> wrapper <> exeExt
destWrapperPath = inst </> toF
whenM (checkFileAlreadyExists destWrapperPath)
(throwE $ FileAlreadyExistsError destWrapperPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper <> exeExt) srcWrapperPath
(inst </> toF) destWrapperPath
lift $ chmod_755 (inst </> toF)
lift $ chmod_755 destWrapperPath
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@ -- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
@ -663,6 +682,7 @@ installHLSBin :: ( MonadMask m
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
, FileAlreadyExistsError
] ]
m m
() ()
@ -701,6 +721,7 @@ installStackBin :: ( MonadMask m
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
, FileAlreadyExistsError
] ]
m m
() ()
@ -738,6 +759,7 @@ installStackBindist :: ( MonadMask m
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
, FileAlreadyExistsError
] ]
m 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 the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated installs -> Maybe Version -- ^ Nothing for isolated installs
-> Excepts '[CopyError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path inst mver' = do installStackUnpacked path inst mver' = do
lift $ $(logInfo) "Installing stack" lift $ $(logInfo) "Installing stack"
let stackFile = "stack" let stackFile = "stack"
@ -791,7 +813,11 @@ installStackUnpacked path inst mver' = do
let destFileName = stackFile let destFileName = stackFile
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver' <> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> exeExt <> exeExt
let destPath = inst </> destFileName destPath = inst </> destFileName
whenM (checkFileAlreadyExists destPath)
(throwE $ FileAlreadyExistsError destPath)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile <> exeExt) (path </> stackFile <> exeExt)
destPath destPath

View File

@ -104,3 +104,6 @@ findFiles path regex = do
contents <- listDirectory path contents <- listDirectory path
pure $ filter (match regex) contents pure $ filter (match regex) contents
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
checkFileAlreadyExists fp = liftIO $ doesFileExist fp