Fix commercialhaskell#4394

bradrn · Nov 29, 2018 · e6006db · e6006db
1 parent 4fbd9b7
commit e6006db
Show file tree

Hide file tree

Showing 4 changed files with 23 additions and 20 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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")