Browse Source

Merge branch 'fix-symlink-support' into master

master
Julian Ospald 3 years ago
parent
commit
46f3da1a94
No known key found for this signature in database GPG Key ID: 511B62C09D50CD28
7 changed files with 35 additions and 12 deletions
  1. +1
    -1
      app/ghcup/Main.hs
  2. +1
    -1
      cabal.project
  3. +1
    -1
      ghcup.cabal
  4. +4
    -4
      lib/GHCup.hs
  5. +3
    -3
      lib/GHCup/Download.hs
  6. +23
    -1
      lib/GHCup/Utils.hs
  7. +2
    -1
      lib/GHCup/Utils/Logger.hs

+ 1
- 1
app/ghcup/Main.hs View File

@@ -910,7 +910,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt

-- create ~/.ghcup dir
createDirRecursive newDirPerms baseDir
createDirRecursive' baseDir

-- logger interpreter
logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|]


+ 1
- 1
cabal.project View File

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

+ 1
- 1
ghcup.cabal View File

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


+ 4
- 4
lib/GHCup.hs View File

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



+ 3
- 3
lib/GHCup/Download.hs View File

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


+ 23
- 1
lib/GHCup/Utils.hs View File

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


+ 2
- 1
lib/GHCup/Utils/Logger.hs View File

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

Loading…
Cancel
Save