From e6006db2e8ae491416ad709abbc3029ff4c0f0e4 Mon Sep 17 00:00:00 2001 From: Brad Neimann Date: Thu, 29 Nov 2018 11:20:03 +1100 Subject: [PATCH] Fix #4394 --- ChangeLog.md | 2 ++ src/Stack/New.hs | 10 +++++----- src/Stack/Types/TemplateName.hs | 9 +++++---- src/test/Stack/Types/TemplateNameSpec.hs | 22 +++++++++++----------- 4 files changed, 23 insertions(+), 20 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index fef5c5da00..ef56520960 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -102,6 +102,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.1 diff --git a/src/Stack/New.hs b/src/Stack/New.hs index 1c8fd13392..6b87fdd8cc 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -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 diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs index ed802faa85..bf74cfee3c 100644 --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -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 - diff --git a/src/test/Stack/Types/TemplateNameSpec.hs b/src/test/Stack/Types/TemplateNameSpec.hs index 5667a5c4b9..6b2929cddd 100644 --- a/src/test/Stack/Types/TemplateNameSpec.hs +++ b/src/test/Stack/Types/TemplateNameSpec.hs @@ -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")