Merge branch 'fix-symlink-support' into master

app/ghcup/Main.hs

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

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

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

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

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

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
+

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