diff --git a/src/Path/IO.hs b/src/Path/IO.hs index c1241e1e3a..ca1bed9999 100644 --- a/src/Path/IO.hs +++ b/src/Path/IO.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} -- | IO actions that might be put in a package at some point. @@ -30,7 +31,9 @@ module Path.IO ,copyFileIfExists ,copyDirectoryRecursive ,createTree - ,dropRoot) + ,dropRoot + ,parseCollapsedAbsFile + ,parseCollapsedAbsDir) where import Control.Exception hiding (catch) @@ -123,6 +126,44 @@ resolveFileMaybe :: (MonadIO m,MonadThrow m) => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File)) resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile +-- | Collapse intermediate "." and ".." directories from path, then parse +-- it with 'parseAbsFile'. +-- (probably should be moved to the Path module) +parseCollapsedAbsFile :: MonadThrow m => FilePath -> m (Path Abs File) +parseCollapsedAbsFile = parseAbsFile . collapseFilePath + +-- | Collapse intermediate "." and ".." directories from path, then parse +-- it with 'parseAbsDir'. +-- (probably should be moved to the Path module) +parseCollapsedAbsDir :: MonadThrow m => FilePath -> m (Path Abs Dir) +parseCollapsedAbsDir = parseAbsDir . collapseFilePath + +-- | Collapse intermediate "." and ".." directories from a path. +-- +-- > collapseFilePath "./foo" == "foo" +-- > collapseFilePath "/bar/../baz" == "/baz" +-- > collapseFilePath "/../baz" == "/../baz" +-- > collapseFilePath "parent/foo/baz/../bar" == "parent/foo/bar" +-- > collapseFilePath "parent/foo/baz/../../bar" == "parent/bar" +-- > collapseFilePath "parent/foo/.." == "parent" +-- > collapseFilePath "/parent/foo/../../bar" == "/bar" +-- +-- (borrowed from @Text.Pandoc.Shared@) +collapseFilePath :: FilePath -> FilePath +collapseFilePath = FP.joinPath . reverse . foldl go [] . FP.splitDirectories + where + go rs "." = rs + go r@(p:rs) ".." = case p of + ".." -> ("..":r) + (checkPathSeperator -> Just True) -> ("..":r) + _ -> rs + go _ (checkPathSeperator -> Just True) = [[FP.pathSeparator]] + go rs x = x:rs + isSingleton [] = Nothing + isSingleton [x] = Just x + isSingleton _ = Nothing + checkPathSeperator = fmap FP.isPathSeparator . isSingleton + -- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted. listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File]) listDirectory dir = diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index ffc550b929..6fa261378f 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -817,15 +817,22 @@ findCandidate dirs exts name = do -> IO [Either ResolveException (Path Abs File)] makeDirCandidates dir = case name of - Right fp -> liftM return (try (resolveFile dir fp)) + Right fp -> liftM return (try (resolveFile' dir fp)) Left mn -> mapM (\ext -> try - (resolveFile + (resolveFile' dir (Cabal.toFilePath mn ++ "." ++ ext))) (map T.unpack exts) + resolveFile' :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath.FilePath -> m (Path Abs File) + resolveFile' x y = do + p <- parseCollapsedAbsFile (toFilePath x FilePath. y) + exists <- fileExists p + if exists + then return p + else throwM $ ResolveFileFailed x y (toFilePath p) -- | Warn the user that multiple candidates are available for an -- entry, but that we picked one anyway and continued. diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs index 3274646679..e0170c6e17 100644 --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -66,3 +66,8 @@ doesFileOrDirExist fp = do if isDir then return (Right ("Directory exists: " ++ fp)) else return (Left ()) + +copy :: FilePath -> FilePath -> IO () +copy src dest = do + putStrLn ("Copy " ++ show src ++ " to " ++ show dest) + System.Directory.copyFile src dest diff --git a/test/integration/tests/32-unlisted-module/Main.hs b/test/integration/tests/32-unlisted-module/Main.hs new file mode 100644 index 0000000000..1559b530c7 --- /dev/null +++ b/test/integration/tests/32-unlisted-module/Main.hs @@ -0,0 +1,25 @@ +import Control.Concurrent +import StackTest + +main :: IO () +main = do + copy "src/Unlisted_OK.hs" "src/Unlisted.hs" + copy "embed_OK.txt" "embed.txt" + stack ["build"] + pause + copy "src/Unlisted_FAIL.hs" "src/Unlisted.hs" + stackErr ["build"] + pause + copy "src/Unlisted_OK.hs" "src/Unlisted.hs" + stack ["build"] + stack ["exec", "files-exe"] + pause + copy "embed_FAIL.txt" "embed.txt" + stack ["build"] + stackErr ["exec", "files-exe"] + pause + copy "embed_OK.txt" "embed.txt" + stack ["build"] + stack ["exec", "files-exe"] + +pause = threadDelay 1000000 diff --git a/test/integration/tests/32-unlisted-module/files/embed_FAIL.txt b/test/integration/tests/32-unlisted-module/files/embed_FAIL.txt new file mode 100644 index 0000000000..94e1707e85 --- /dev/null +++ b/test/integration/tests/32-unlisted-module/files/embed_FAIL.txt @@ -0,0 +1 @@ +FAIL diff --git a/test/integration/tests/32-unlisted-module/files/embed_OK.txt b/test/integration/tests/32-unlisted-module/files/embed_OK.txt new file mode 100644 index 0000000000..d86bac9de5 --- /dev/null +++ b/test/integration/tests/32-unlisted-module/files/embed_OK.txt @@ -0,0 +1 @@ +OK diff --git a/test/integration/tests/32-unlisted-module/files/files.cabal b/test/integration/tests/32-unlisted-module/files/files.cabal new file mode 100644 index 0000000000..f57bbd28a4 --- /dev/null +++ b/test/integration/tests/32-unlisted-module/files/files.cabal @@ -0,0 +1,16 @@ +name: files +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: http://github.com/githubuser/files#readme +license: BSD3 +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +executable files-exe + hs-source-dirs: src/../src + main-is: Main.hs + build-depends: base >= 4.7 && < 5 + , file-embed + default-language: Haskell2010 diff --git a/test/integration/tests/32-unlisted-module/files/src/Main.hs b/test/integration/tests/32-unlisted-module/files/src/Main.hs new file mode 100644 index 0000000000..9e2d2e6532 --- /dev/null +++ b/test/integration/tests/32-unlisted-module/files/src/Main.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.FileEmbed +import Unlisted + +main :: IO () +main = do + putStrLn ("main " ++ show foo ++ " " ++ show embedded) + if embedded == "FAIL\n" + then error "embedded contains FAIL" + else return () + +embedded = $(embedFile "embed.txt") diff --git a/test/integration/tests/32-unlisted-module/files/src/Unlisted_FAIL.hs b/test/integration/tests/32-unlisted-module/files/src/Unlisted_FAIL.hs new file mode 100644 index 0000000000..b15130820b --- /dev/null +++ b/test/integration/tests/32-unlisted-module/files/src/Unlisted_FAIL.hs @@ -0,0 +1,5 @@ +-- | Version of Unlisted with different export that causes failure to compile. +module Unlisted where + +fooRenamed :: String +fooRenamed = "foo" diff --git a/test/integration/tests/32-unlisted-module/files/src/Unlisted_OK.hs b/test/integration/tests/32-unlisted-module/files/src/Unlisted_OK.hs new file mode 100644 index 0000000000..73caa00bcc --- /dev/null +++ b/test/integration/tests/32-unlisted-module/files/src/Unlisted_OK.hs @@ -0,0 +1,4 @@ +module Unlisted where + +foo :: String +foo = "foo" diff --git a/test/integration/tests/32-unlisted-module/files/src/main/Main.hs b/test/integration/tests/32-unlisted-module/files/src/main/Main.hs new file mode 100644 index 0000000000..b768742deb --- /dev/null +++ b/test/integration/tests/32-unlisted-module/files/src/main/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = do putStrLn "Hello, world." diff --git a/test/integration/tests/32-unlisted-module/files/stack.yaml b/test/integration/tests/32-unlisted-module/files/stack.yaml new file mode 100644 index 0000000000..8130c99efa --- /dev/null +++ b/test/integration/tests/32-unlisted-module/files/stack.yaml @@ -0,0 +1,5 @@ +flags: {} +packages: +- '.' +extra-deps: [] +resolver: lts-3.0