From 8c486e8d4673112e6da57e7c6dcc17bd8c35a61f Mon Sep 17 00:00:00 2001
From: Arjun Kathuria <arjun.kathuria8@gmail.com>
Date: Mon, 23 Aug 2021 20:18:45 +0530
Subject: [PATCH] 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-\<ghcver\>@
 -- 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