[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

@@ -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"}
 
 

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

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
                   ]
 
 

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

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, ())

app/ghcup/GHCup/OptParse/Nuke.hs

@@ -42,7 +42,7 @@ import Control.Concurrent (threadDelay)
     ---------------------------
 
 
-type NukeEffects = '[ NotInstalled ]
+type NukeEffects = '[ NotInstalled, UninstallFailed ]
 
 
 runNuke :: AppState

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))

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

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
 

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
+                         (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
@@ -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-\<ver\>@ 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)
+        liftE $ runBuildAction tmpUnpack
-              $ installHLSUnpacked workdir (GHCupDir inst) ver
+              $ 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
+  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).
 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,7 +1795,18 @@ 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
+  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' <-
@@ -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
+    Cabal -> liftE $ rmCabalVer lVer
-    Stack -> rmStackVer 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,24 +2095,17 @@ 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 ()
+-- 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 ()
-    -- we expect only files inside cache/log dir
+deleteFile' filepath = do
-    -- 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 :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
-    removeDirIfEmptyOrIsSymlink filepath =
+removeDirIfEmptyOrIsSymlink filepath =
   hideError UnsatisfiedConstraints $
   handleIO' InappropriateType
         (handleIfSym filepath)
@@ -2075,9 +2114,14 @@ rmGhcupDirs = do
     handleIfSym fp e = do
       isSym <- liftIO $ pathIsSymbolicLink fp
       if isSym
-          then deleteFile fp
+      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)
+    copyFileE (workdir </> tar) tarPath False
-                                                             tarPath
     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
+  copyFileE p destFile False
-                                                           destFile
   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

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

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)

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'))
+
+

lib/GHCup/Utils/Dirs.hs

@@ -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 { .. }
 
 

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

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, copyFile)
-import           System.Directory        hiding (findFiles)
 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
+
+

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)

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 <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 #-}

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

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

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: