Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch : master
http://hackage.haskell.org/trac/ghc/changeset/1c6a57f553b2b00574e8875ef75f75f59dc1aa0c >--------------------------------------------------------------- commit 1c6a57f553b2b00574e8875ef75f75f59dc1aa0c Author: Duncan Coutts <[email protected]> Date: Sat Aug 29 00:49:59 2009 +0000 Fix calculation of paths in check for bindir symlink overwriting We were doing it wrong, but Linux realpath() C function was letting us get away with it. The Solaris realpath() is stricter. The new implementation is also simpler, relying on the fact that the canonicalizePath function will resolve symlinks. >--------------------------------------------------------------- .../Distribution/Client/InstallSymlink.hs | 29 +++++++++---------- 1 files changed, 14 insertions(+), 15 deletions(-) diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs index 7210cb6..d66dc61 100644 --- a/cabal-install/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/Distribution/Client/InstallSymlink.hs @@ -63,12 +63,12 @@ import Distribution.System ( Platform(Platform) ) import System.Posix.Files - ( getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink - , createSymbolicLink, removeLink ) + ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink + , removeLink ) import System.Directory ( canonicalizePath ) import System.FilePath - ( (</>), takeDirectory, splitPath, joinPath, isAbsolute ) + ( (</>), splitPath, joinPath, isAbsolute ) import System.IO.Error ( catch, isDoesNotExistError, ioError ) import Control.Exception @@ -178,7 +178,8 @@ symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir -- did not own. Other errors like permission errors -- just propagate as exceptions. symlinkBinary publicBindir privateBindir publicName privateName = do - ok <- targetOkToOverwrite (publicBindir </> publicName) privateBindir + ok <- targetOkToOverwrite (publicBindir </> publicName) + (privateBindir </> privateName) case ok of NotOurFile -> return False NotExists -> mkLink >> return True @@ -191,24 +192,22 @@ symlinkBinary publicBindir privateBindir publicName privateName = do -- | Check a filepath of a symlink that we would like to create to see if it -- is ok. For it to be ok to overwrite it must either not already exist yet or --- be a symlink to our private bin dir (in which case we can assume ownership). +-- be a symlink to our target (in which case we can assume ownership). -- targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private -- binary that we would like to create - -> FilePath -- ^ The canonical path of the private bin - -- directory. Use 'canonicalizePath'. + -> FilePath -- ^ The canonical path of the private binary. + -- Use 'canonicalizePath' to make this. -> IO SymlinkStatus -targetOkToOverwrite symlink privateBinDir = handleNotExist $ do +targetOkToOverwrite symlink target = handleNotExist $ do status <- getSymbolicLinkStatus symlink if not (isSymbolicLink status) then return NotOurFile - else return - . (\ok -> if ok then OkToOverwrite else NotOurFile) - . (== privateBinDir) - . takeDirectory - =<< canonicalizePath - . (symlink </>) - =<< readSymbolicLink symlink + else do target' <- canonicalizePath symlink + -- This relies on canonicalizePath handling symlinks + if target == target' + then return OkToOverwrite + else return NotOurFile where handleNotExist action = catch action $ \ioexception -> _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
