Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Fix cptree to handle symlinks correctly #344

Merged
merged 3 commits into from
Feb 7, 2019
Merged

Fix cptree to handle symlinks correctly #344

Changes from 1 commit
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
0170e17
Fix `cptree` to handle symlinks correctly
Gabriella439 Feb 6, 2019
6a261a1
Condense implementation of `isNotSymbolicLink`
Gabriella439 Feb 7, 2019
24b49ef
Export `isNotSymbolicLink`
Gabriella439 Feb 7, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
30 changes: 26 additions & 4 deletions src/Turtle/Prelude.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1098,17 +1098,39 @@ symlink a b = liftIO $ createSymbolicLink (fp2fp a) (fp2fp b)
-- | Copy a directory tree
cptree :: MonadIO io => FilePath -> FilePath -> io ()
cptree oldTree newTree = sh (do
oldPath <- lstree oldTree
let isNotSymbolicLink path = do
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

How about

let isNotSymbolicLink = fmap (not . PosixCompat.isSymbolicLink) . lstat

fileStatus <- lstat path

return (not (PosixCompat.isSymbolicLink fileStatus))

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)

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why not

let Just suffix = Filesystem.stripPrefix (oldTree </> "") oldPath

Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@mberndt123: They are not equivalent. The reason why is that Haskell interprets an irrefutable pattern match in a let binding differently than when binding a value in a do block.

An irrefutable pattern match in a let binding:

let Just x = foo

... is the same as:

let x = case foo of
        Just y -> y
        Nothing -> error "…: Irrefutable pattern failed for pattern Just x"

... whereas an irrefutable pattern match in the bind of a do block:

Just x <- return foo

... is the same as:

r <- return foo

x <- case r of
    Just y  -> return y
    Nothing -> fail "Pattern match failure in do expression at …"

These differ because fail might not be the same as error (in fact, it's very common for fail to not be error). For example, for any list-like Monad (including Shell), fail _ = empty so an irrefutable pattern match when binding a value in a do block actually gracefully degrades to returning a total (albeit empty) result, whereas an irrefutable pattern match in a let binding gives a partial result (i.e. error) which is not intended to be recoverable.

So that's why that codde does the whole dance of wrapping the value in return before attempting an irrefutable pattern match. Another way it could have been written is to explicitly desugar it, like this:

x <- case Filesystem.stripPrefix (oldTree </> "") oldPath of
    Nothing -> empty
    Just x  -> return x

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I see, thanks for explaining!

Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

You're welcome!

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 ()
Expand Down