diff --git a/src/Turtle/Prelude.hs b/src/Turtle/Prelude.hs index 3fb5a9e..c1ac919 100644 --- a/src/Turtle/Prelude.hs +++ b/src/Turtle/Prelude.hs @@ -130,6 +130,7 @@ module Turtle.Prelude ( #if !defined(mingw32_HOST_OS) , symlink #endif + , isNotSymbolicLink , rm , rmdir , rmtree @@ -1095,20 +1096,46 @@ symlink a b = liftIO $ createSymbolicLink (fp2fp a) (fp2fp b) #endif +{-| Returns `True` if the given `FilePath` is not a symbolic link + + This comes in handy in conjunction with `lsif`: + + > lsif isNotSymbolicLink +-} +isNotSymbolicLink :: MonadIO io => FilePath -> io Bool +isNotSymbolicLink = fmap (not . PosixCompat.isSymbolicLink) . lstat + -- | Copy a directory tree cptree :: MonadIO io => FilePath -> FilePath -> io () cptree oldTree newTree = sh (do - oldPath <- lstree oldTree + oldPath <- lsif isNotSymbolicLink oldTree + -- The `system-filepath` library treats a path like "/tmp" as a file and not -- a directory and fails to strip it as a prefix from `/tmp/foo`. Adding -- `( "")` to the end of the path makes clear that the path is a -- directory Just suffix <- return (Filesystem.stripPrefix (oldTree "") oldPath) + let newPath = newTree suffix + isFile <- testfile oldPath - if isFile - then mktree (Filesystem.directory newPath) >> cp oldPath newPath - else mktree newPath ) + + fileStatus <- lstat oldPath + + if PosixCompat.isSymbolicLink fileStatus + then do + oldTarget <- liftIO (PosixCompat.readSymbolicLink (Filesystem.encodeString oldPath)) + + mktree (Filesystem.directory newPath) + + liftIO (PosixCompat.createSymbolicLink oldTarget (Filesystem.encodeString newPath)) + else if isFile + then do + mktree (Filesystem.directory newPath) + + cp oldPath newPath + else do + mktree newPath ) -- | Remove a file rm :: MonadIO io => FilePath -> io ()