Skip to content
Permalink
Browse files

Merge pull request #4423 from bradrn/fix-4394

Fix handling of GitHub and URL templates on Windows
  • Loading branch information...
snoyberg committed Jan 7, 2019
2 parents ed47427 + e6006db commit 9900d99114967698223f43c84e4cedecc24cea97
Showing with 23 additions and 20 deletions.
  1. +2 −0 ChangeLog.md
  2. +5 −5 src/Stack/New.hs
  3. +5 −4 src/Stack/Types/TemplateName.hs
  4. +11 −11 src/test/Stack/Types/TemplateNameSpec.hs
@@ -106,6 +106,8 @@ Bug fixes:
by symlinks, while GCC will produce the object files in the original
directory. See
[#4402](https://github.com/commercialhaskell/stack/pull/4402)
* Fix handling of GitHub and URL templates on Windows. See
[commercialhaskell/stack#4394](https://github.com/commercialhaskell/stack/issues/4394)

## v1.9.3

@@ -117,13 +117,13 @@ loadTemplate name logIt = do
case templatePath name of
AbsPath absFile -> logIt LocalTemp >> loadLocalFile absFile
UrlPath s -> downloadFromUrl s templateDir
RelPath relFile ->
RelPath rawParam relFile ->
catch
(do f <- loadLocalFile relFile
logIt LocalTemp
return f)
(\(e :: NewException) ->
case relRequest relFile of
case relRequest rawParam of
Just req -> downloadTemplate req
(templateDir </> relFile)
Nothing -> throwM e
@@ -141,9 +141,9 @@ loadTemplate name logIt = do
if exists
then readFileUtf8 (toFilePath path)
else throwM (FailedToLoadTemplate name (toFilePath path))
relRequest :: Path Rel File -> Maybe Request
relRequest rel = do
rtp <- parseRepoPathWithService defaultRepoService (T.pack (toFilePath rel))
relRequest :: String -> Maybe Request
relRequest req = do
rtp <- parseRepoPathWithService defaultRepoService (T.pack req)
let url = urlFromRepoTemplatePath rtp
parseRequest (T.unpack url)
downloadFromUrl :: String -> Path Abs Dir -> RIO env Text
@@ -30,9 +30,11 @@ data TemplateName = TemplateName !Text !TemplatePath

data TemplatePath = AbsPath (Path Abs File)
-- ^ an absolute path on the filesystem
| RelPath (Path Rel File)
| RelPath String (Path Rel File)
-- ^ a relative path on the filesystem, or relative to
-- the template repository
-- the template repository. To avoid path separator conversion
-- on Windows, the raw command-line parameter passed is also
-- given as the first field (possibly with @.hsfiles@ appended).
| UrlPath String
-- ^ a full URL
| RepoPath RepoTemplatePath
@@ -91,7 +93,7 @@ parseTemplateNameFromString fname =
[ TemplateName prefix . RepoPath <$> parseRepoPath hsf
, TemplateName (T.pack orig) . UrlPath <$> (parseRequest orig *> Just orig)
, TemplateName prefix . AbsPath <$> parseAbsFile hsf
, TemplateName prefix . RelPath <$> parseRelFile hsf
, TemplateName prefix . RelPath hsf <$> parseRelFile hsf
]
expected = "Expected a template like: foo or foo.hsfiles or\
\ https://example.com/foo.hsfiles or github:user/foo"
@@ -133,4 +135,3 @@ parseRepoPathWithService service path =
repoUser <- defaultRepoUserForService service
Just $ RepoTemplatePath service repoUser name
_ -> Nothing

@@ -21,19 +21,19 @@ spec =
pathOf "http://www.com/file" `shouldBe` UrlPath "http://www.com/file"
pathOf "https://www.com/file" `shouldBe` UrlPath "https://www.com/file"

pathOf "name" `shouldBe` (RelPath $ Path "name.hsfiles")
pathOf "name.hsfile" `shouldBe` (RelPath $ Path "name.hsfile.hsfiles")
pathOf "name.hsfiles" `shouldBe` (RelPath $ Path "name.hsfiles")
pathOf "" `shouldBe` (RelPath $ Path ".hsfiles")
pathOf "name" `shouldBe` (RelPath "name.hsfiles" $ Path "name.hsfiles")
pathOf "name.hsfile" `shouldBe` (RelPath "name.hsfile.hsfiles" $ Path "name.hsfile.hsfiles")
pathOf "name.hsfiles" `shouldBe` (RelPath "name.hsfiles" $ Path "name.hsfiles")
pathOf "" `shouldBe` (RelPath ".hsfiles" $ Path ".hsfiles")

if os == "mingw32"
then do
pathOf "//home/file" `shouldBe` (AbsPath $ Path "\\\\home\\file.hsfiles")
pathOf "/home/file" `shouldBe` (RelPath $ Path "\\home\\file.hsfiles")
pathOf "/home/file.hsfiles" `shouldBe` (RelPath $ Path "\\home\\file.hsfiles")
pathOf "/home/file" `shouldBe` (RelPath "/home/file.hsfiles" $ Path "\\home\\file.hsfiles")
pathOf "/home/file.hsfiles" `shouldBe` (RelPath "/home/file.hsfiles" $ Path "\\home\\file.hsfiles")

pathOf "c:\\home\\file" `shouldBe` (AbsPath $ Path "C:\\home\\file.hsfiles")
pathOf "with/slash" `shouldBe` (RelPath $ Path "with\\slash.hsfiles")
pathOf "c:\\home\\file" `shouldBe` (AbsPath $ Path "C:\\home\\file.hsfiles")
pathOf "with/slash" `shouldBe` (RelPath "with/slash.hsfiles" $ Path "with\\slash.hsfiles")

let colonAction =
do
@@ -45,7 +45,7 @@ spec =
pathOf "/home/file" `shouldBe` (AbsPath $ Path "/home/file.hsfiles")
pathOf "/home/file.hsfiles" `shouldBe` (AbsPath $ Path "/home/file.hsfiles")

pathOf "c:\\home\\file" `shouldBe` (RelPath $ Path "c:\\home\\file.hsfiles")
pathOf "with/slash" `shouldBe` (RelPath $ Path "with/slash.hsfiles")
pathOf "with:colon" `shouldBe` (RelPath $ Path "with:colon.hsfiles")
pathOf "c:\\home\\file" `shouldBe` (RelPath "c:\\home\\file.hsfiles" $ Path "c:\\home\\file.hsfiles")
pathOf "with/slash" `shouldBe` (RelPath "with/slash.hsfiles" $ Path "with/slash.hsfiles")
pathOf "with:colon" `shouldBe` (RelPath "with:colon.hsfiles" $ Path "with:colon.hsfiles")

0 comments on commit 9900d99

Please sign in to comment.
You can’t perform that action at this time.