From 326bf510c99594466bb0c12592ae7158b8d0eb7f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 31 Aug 2020 13:03:12 +0200 Subject: [PATCH 1/2] Fix Error when ~/.ghcup is a valid symlink Fixes #49 --- app/ghcup/Main.hs | 2 +- lib/GHCup.hs | 8 ++++---- lib/GHCup/Download.hs | 6 +++--- lib/GHCup/Utils.hs | 24 +++++++++++++++++++++++- lib/GHCup/Utils/Logger.hs | 3 ++- 5 files changed, 33 insertions(+), 10 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 9116ae8..31d8ab7 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -910,7 +910,7 @@ Report bugs at |] settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt -- create ~/.ghcup dir - createDirRecursive newDirPerms baseDir + createDirRecursive' baseDir -- logger interpreter logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|] diff --git a/lib/GHCup.hs b/lib/GHCup.hs index c78b22c..79cd48e 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -273,7 +273,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do installCabal' path inst = do lift $ $(logInfo) "Installing cabal" let cabalFile = [rel|cabal|] - liftIO $ createDirRecursive newDirPerms inst + liftIO $ createDirRecursive' inst destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver) let destPath = inst destFileName handleIO (throwE . CopyError . show) $ liftIO $ copyFile @@ -352,7 +352,7 @@ setGHC ver sghc = do -- symlink destination Settings { dirs = Dirs {..} } <- lift ask - liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir + liftIO $ createDirRecursive' binDir -- first delete the old symlinks (this fixes compatibility issues -- with old ghcup) @@ -424,7 +424,7 @@ setCabal ver = do -- symlink destination Settings {dirs = Dirs {..}} <- lift ask - liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir + liftIO $ createDirRecursive' binDir whenM (liftIO $ fmap not $ doesFileExist (binDir targetFile)) $ throwE @@ -1024,7 +1024,7 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do ] tmp <- lift withGHCupTmpDir - liftIO $ createDirRecursive newDirPerms (tmp [rel|bin|]) + liftIO $ createDirRecursive' (tmp [rel|bin|]) newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv) lift $ $(logDebug) [i|Environment: #{newEnv}|] diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index ea59551..af8aa16 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -226,7 +226,7 @@ getDownloads urlSource = do else -- access in less than 5 minutes, re-use file liftIO $ readFile json_file else do - liftIO $ createDirRecursive newDirPerms cacheDir + liftIO $ createDirRecursive' cacheDir getModTime >>= \case Just modTime -> dlWithMod modTime json_file Nothing -> do @@ -330,7 +330,7 @@ download dli dest mfn scheme = view (dlUri % uriSchemeL' % schemeBSL') dli cp = do -- destination dir must exist - liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest + liftIO $ createDirRecursive' dest destFile <- getDestFile fromFile <- parseAbs path liftIO $ copyFile fromFile destFile Strict @@ -340,7 +340,7 @@ download dli dest mfn lift $ $(logInfo) [i|downloading: #{uri'}|] -- destination dir must exist - liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest + liftIO $ createDirRecursive' dest destFile <- getDestFile -- download diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index e06e876..ea88dcb 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -36,7 +36,7 @@ import GHCup.Utils.Prelude import GHCup.Utils.String.QQ #if !defined(TAR) -import Codec.Archive +import Codec.Archive hiding ( Directory ) #endif import Control.Applicative import Control.Exception.Safe @@ -621,3 +621,25 @@ runBuildAction bdir instdir action = do when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive bdir pure v + + +-- | More permissive version of 'createDirRecursive'. This doesn't +-- error when the destination is a symlink to a directory. +createDirRecursive' :: Path b -> IO () +createDirRecursive' p = + handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e) + . createDirRecursive newDirPerms + $ p + + where + isSymlinkDir e = do + ft <- getFileType p + case ft of + SymbolicLink -> do + rp <- canonicalizePath p + rft <- getFileType rp + case rft of + Directory -> pure () + _ -> throwIO e + _ -> throwIO e + diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 0ff0004..5dece20 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -15,6 +15,7 @@ Here we define our main logger. module GHCup.Utils.Logger where import GHCup.Types +import GHCup.Utils import Control.Monad import Control.Monad.IO.Class @@ -69,7 +70,7 @@ initGHCupFileLogging context = do Settings {dirs = Dirs {..}} <- ask let logfile = logsDir context liftIO $ do - createDirRecursive newDirPerms logsDir + createDirRecursive' logsDir hideError doesNotExistErrorType $ deleteFile logfile createRegularFile newFilePerms logfile pure logfile From 7ec9d90aabe4c65bc046ed6a62f1dd940927f2b1 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 1 Sep 2020 16:00:28 +0200 Subject: [PATCH 2/2] Fix build with libarchive-3.0.0.0 --- cabal.project | 2 +- ghcup.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 8412ed7..d182f0d 100644 --- a/cabal.project +++ b/cabal.project @@ -19,6 +19,6 @@ package ghcup constraints: http-io-streams -brotli package libarchive - flags: +static + flags: -system-libarchive allow-newer: base, ghc-prim, template-haskell diff --git a/ghcup.cabal b/ghcup.cabal index 120723e..89a51ce 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -112,7 +112,7 @@ common io-streams build-depends: io-streams >=1.5 common libarchive - build-depends: libarchive >= 2.2.5.0 + build-depends: libarchive >= 3.0.0.0 common lzma build-depends: lzma >=0.0.0.3