Merge branch 'issue-978'

.github/scripts/common.sh

@@ -44,7 +44,7 @@ raw_eghcup() {
 
 eghcup() {
 	if [ "${OS}" = "Windows" ] ; then
-		"$GHCUP_BIN/ghcup${ext}" -c -s "file:/$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$@"
+		"$GHCUP_BIN/ghcup${ext}" -c -s "file:${GITHUB_WORKSPACE//\\//}/data/metadata/ghcup-${JSON_VERSION}.yaml" "$@"
 	else
 		"$GHCUP_BIN/ghcup${ext}" -c -s "file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$@"
 	fi

.github/scripts/test.sh

@@ -11,6 +11,7 @@ else
 	GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
 fi
 
+env
 git_describe
 
 rm -rf "${GHCUP_DIR}"

.github/workflows/release.yaml

@@ -178,7 +178,7 @@ jobs:
             ARCH: 64
           - os: windows-latest
             ARTIFACT: "x86_64-mingw64-ghcup"
-            GHC_VER: 9.2.8
+            GHC_VER: 9.4.8
             ARCH: 64
     steps:
       - name: Checkout code
@@ -414,7 +414,7 @@ jobs:
             DISTRO: na
           - os: windows-latest
             ARTIFACT: "x86_64-mingw64-ghcup"
-            GHC_VER: 9.2.8
+            GHC_VER: 9.4.8
             ARCH: 64
             DISTRO: na
 

.gitignore

@@ -4,6 +4,7 @@ codex.tags
 dist-newstyle/
 cabal.project.local
 .stack-work/
+.hiefiles/
 bin/
 /*.prof
 /*.ps

cabal.project

@@ -12,6 +12,10 @@ else
 constraints: http-io-streams -brotli,
              any.aeson >= 2.0.1.0
 
+if os(mingw32)
+  if impl(ghc >= 9.4)
+    constraints: language-c >= 0.9.3
+
 source-repository-package
   type: git
   location: https://github.com/haskell/tar.git

cabal.project.release

@@ -18,7 +18,9 @@ elif os(mingw32)
   constraints: zlib +bundled-c-zlib,
                lzma +static,
                text -simdutf,
-			   vty-windows >=0.1.0.3
+               vty-windows >=0.1.0.3
+  if impl(ghc >= 9.4)
+    constraints: language-c >= 0.9.3
 elif os(freebsd)
   constraints: zlib +bundled-c-zlib,
                zip +disable-zstd

ghcup.cabal

@@ -142,6 +142,7 @@ library
     GHCup.Utils.Dirs
     GHCup.Utils.Tar
     GHCup.Utils.Tar.Types
+    GHCup.Utils.URI
     GHCup.Version
 
   hs-source-dirs:     lib
@@ -184,6 +185,7 @@ library
     , disk-free-space       ^>=0.1.0.1
     , exceptions            ^>=0.10
     , filepath              ^>=1.4.2.1
+    , file-uri              ^>=0.1.0.0
     , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  ^>=3.3
     , lzma-static           ^>=5.2.5.3

lib-opt/GHCup/OptParse/Common.hs

@@ -17,6 +17,7 @@ import           GHCup.Platform
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
+import           GHCup.Utils.URI
 import           GHCup.Prelude
 import           GHCup.Prelude.Process
 import           GHCup.Prelude.Logger
@@ -59,7 +60,7 @@ import           Safe
 import           System.Process                  ( readProcess )
 import           System.FilePath
 import           Text.HTML.TagSoup       hiding ( Tag )
-import           URI.ByteString
+import           URI.ByteString          hiding (parseURI)
 
 import qualified Data.ByteString.UTF8          as UTF8
 import qualified Data.Map.Strict               as M
@@ -215,7 +216,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
 
 
 uriParser :: String -> Either String URI
-uriParser = first show . parseURI strictURIParserOptions . UTF8.fromString
+uriParser = first show . parseURI . UTF8.fromString
 
 
 absolutePathParser :: FilePath -> Either String FilePath
@@ -834,11 +835,11 @@ parseUrlSource :: String -> Either String URLSource
 parseUrlSource "GHCupURL" = pure GHCupURL
 parseUrlSource "StackSetupURL" = pure StackSetupURL
 parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')
-            <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')
+            <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI .UTF8.fromString $ s')
 
 parseNewUrlSource :: String -> Either String NewURLSource
 parseNewUrlSource "GHCupURL" = pure NewGHCupURL
 parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL
 parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')
-            <|> (fmap NewURI . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')
+            <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s')
 

lib/GHCup/Download.hs

@@ -34,6 +34,7 @@ import qualified GHCup.Types.Stack                as Stack
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.Dirs
+import           GHCup.Utils.URI
 import           GHCup.Platform
 import           GHCup.Prelude
 import           GHCup.Prelude.File
@@ -77,7 +78,7 @@ import           System.Exit
 import           System.FilePath
 import           System.IO.Error
 import           System.IO.Temp
-import           URI.ByteString
+import           URI.ByteString          hiding (parseURI)
 
 import qualified Crypto.Hash.SHA256            as SHA256
 import qualified Data.ByteString               as B
@@ -178,7 +179,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
 
     fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo
     fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do
-      url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI strictURIParserOptions . E.encodeUtf8 $ downloadInfoUrl
+      url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI . E.encodeUtf8 $ downloadInfoUrl
       sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256
       pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing
 

lib/GHCup/Download/IOStreams.hs

@@ -11,6 +11,7 @@ import           GHCup.Download.Utils
 import           GHCup.Errors
 import           GHCup.Types.JSON               ( )
 import           GHCup.Prelude
+import           GHCup.Utils.URI
 
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -28,7 +29,7 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           System.ProgressBar
-import           URI.ByteString
+import           URI.ByteString          hiding (parseURI)
 
 import qualified Data.ByteString               as BS
 import qualified Data.Map.Strict               as M
@@ -114,7 +115,7 @@ downloadInternal = go (5 :: Int)
             | otherwise -> throwE $ HTTPStatusError scode (getHeaderMap r)
         )
 
-    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+    followRedirectURL bs = case parseURI bs of
       Right uri' -> do
         (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
         go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders eCSize

lib/GHCup/Types/JSON.hs

@@ -26,6 +26,7 @@ import           GHCup.Types.Stack (SetupInfo)
 import           GHCup.Types.JSON.Utils
 import           GHCup.Types.JSON.Versions ()
 import           GHCup.Prelude.MegaParsec
+import           GHCup.Utils.URI
 
 import           Control.Applicative            ( (<|>) )
 import           Data.Aeson              hiding (Key)
@@ -38,7 +39,7 @@ import           Data.Text.Encoding            as E
 import           Data.Foldable
 import           Data.Versions
 import           Data.Void
-import           URI.ByteString
+import           URI.ByteString hiding (parseURI)
 import           Text.Casing
 
 import qualified Data.List.NonEmpty            as NE
@@ -95,7 +96,7 @@ instance ToJSON URI where
 
 instance FromJSON URI where
   parseJSON = withText "URL" $ \t ->
-    case parseURI strictURIParserOptions (encodeUtf8 t) of
+    case parseURI (encodeUtf8 t) of
       Right x -> pure x
       Left  e -> fail . show $ e
 

lib/GHCup/Utils.hs

@@ -23,6 +23,7 @@ module GHCup.Utils
   ( module GHCup.Utils.Dirs
   , module GHCup.Utils.Tar
   , module GHCup.Utils
+  , module GHCup.Utils.URI
 #if defined(IS_WINDOWS)
   , module GHCup.Prelude.Windows
 #else
@@ -44,6 +45,7 @@ import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.Dirs
 import           GHCup.Utils.Tar
+import           GHCup.Utils.URI
 import           GHCup.Version
 import           GHCup.Prelude
 import           GHCup.Prelude.File
@@ -78,7 +80,7 @@ import           System.FilePath
 import           System.IO.Error
 import           Text.Regex.Posix
 import           Text.PrettyPrint.HughesPJClass (prettyShow)
-import           URI.ByteString
+import           URI.ByteString hiding (parseURI)
 
 import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T

lib/GHCup/Utils/URI.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE OverloadedStrings     #-}
+
+{-|
+Module      : GHCup.Utils.URI
+Description : GHCup domain specific URI utilities
+Copyright   : (c) Julian Ospald, 2024
+License     : LGPL-3.0
+Maintainer  : hasufell@hasufell.de
+Stability   : experimental
+Portability : portable
+
+This module contains GHCup helpers specific to
+URI handling.
+-}
+module GHCup.Utils.URI where
+
+import           Data.ByteString
+import           URI.ByteString hiding (parseURI)
+import           System.URI.File
+
+import qualified URI.ByteString                as URI
+
+
+    -----------
+    --[ URI ]--
+    -----------
+
+
+parseURI :: ByteString -> Either URIParseError (URIRef Absolute)
+parseURI bs = case parseFile bs of
+                Left _ -> case URI.parseURI strictURIParserOptions bs of
+                            Right (URI { uriScheme = (Scheme "file") }) ->
+#if defined(IS_WINDOWS)
+                              Left (OtherError "Invalid file URI. File URIs must be absolute (start with a drive letter or UNC path) and not contain backslashes.")
+#else
+                              Left (OtherError "Invalid file URI. File URIs must be absolute.")
+#endif
+                            o -> o
+                Right (FileURI (Just _) _) -> Left $ OtherError "File URIs with auth part are not supported!"
+                Right (FileURI _ fp) -> Right $ URI (Scheme "file") Nothing fp (Query []) Nothing
+ where
+  parseFile
+#if defined(IS_WINDOWS)
+    = parseFileURI ExtendedWindows
+#else
+    = parseFileURI ExtendedPosix
+#endif
+

test/ghcup-test/golden/windows/GHCupInfo.json

@@ -845,7 +845,7 @@
                                         "dlHash": "et",
                                         "dlOutput": "𥗚%󲔐ဖ-\u000e",
                                         "dlSubdir": {
-                                            "RegexDir": "BP!a⠀􏀨"
+                                            "RegexDir": "BP!a𖫈􏀨"
                                         },
                                         "dlUri": "https:"
                                     },
@@ -17546,7 +17546,7 @@
                                         "dlHash": "knn",
                                         "dlOutput": "",
                                         "dlSubdir": {
-                                            "RegexDir": "𢹂􄝹 "
+                                            "RegexDir": "𐞳􄝹 "
                                         },
                                         "dlUri": "http:qlay"
                                     }

test/optparse-test/CompileTest.hs

@@ -80,7 +80,11 @@ compileGhcCheckList = mapSecond CompileGHC
   , (baseCmd <> "--jobs 10", baseOptions{GHC.jobs = Just 10})
   , (baseCmd <> "-c build.mk", baseOptions{GHC.buildConfig = Just "build.mk"})
   , (baseCmd <> "--config build.mk", baseOptions{GHC.buildConfig = Just "build.mk"})
+#ifdef IS_WINDOWS
+  , (baseCmd <> "--patch file:c:/example.patch", baseOptions{GHC.patches = Just $ Right [[uri|file:c:/example.patch|]]})
+#else
   , (baseCmd <> "--patch file:///example.patch", baseOptions{GHC.patches = Just $ Right [[uri|file:///example.patch|]]})
+#endif
   , (baseCmd <> "-p patch_dir", baseOptions{GHC.patches = Just (Left "patch_dir")})
   , (baseCmd <> "--patchdir patch_dir", baseOptions{GHC.patches = Just (Left "patch_dir")})
   , (baseCmd <> "-x armv7-unknown-linux-gnueabihf", baseOptions{GHC.crossTarget = Just "armv7-unknown-linux-gnueabihf"})
@@ -164,10 +168,22 @@ compileHlsCheckList = mapSecond CompileHLS
   , (baseCmd <> "-i /tmp/out_dir", baseOptions{HLS.isolateDir = Just "/tmp/out_dir"})
   , (baseCmd <> "--isolate /tmp/out_dir", baseOptions{HLS.isolateDir = Just "/tmp/out_dir"})
 #endif
+#ifdef IS_WINDOWS
+  , (baseCmd <> "--cabal-project file:c:/tmp/cabal.project", baseOptions{HLS.cabalProject = Just $ Right [uri|file:c:/tmp/cabal.project|]})
+#else
   , (baseCmd <> "--cabal-project file:///tmp/cabal.project", baseOptions{HLS.cabalProject = Just $ Right [uri|file:///tmp/cabal.project|]})
+#endif
   , (baseCmd <> "--cabal-project cabal.ghc8107.project", baseOptions{HLS.cabalProject = Just $ Left "cabal.ghc8107.project"})
+#ifdef IS_WINDOWS
+  , (baseCmd <> "--cabal-project-local file:c:/tmp/cabal.project.local", baseOptions{HLS.cabalProjectLocal = Just [uri|file:c:/tmp/cabal.project.local|]})
+#else
   , (baseCmd <> "--cabal-project-local file:///tmp/cabal.project.local", baseOptions{HLS.cabalProjectLocal = Just [uri|file:///tmp/cabal.project.local|]})
+#endif
+#ifdef IS_WINDOWS
+  , (baseCmd <> "--patch file:c:/example.patch", baseOptions{HLS.patches = Just $ Right [[uri|file:c:/example.patch|]]})
+#else
   , (baseCmd <> "--patch file:///example.patch", baseOptions{HLS.patches = Just $ Right [[uri|file:///example.patch|]]})
+#endif
   , (baseCmd <> "-p patch_dir", baseOptions{HLS.patches = Just (Left "patch_dir")})
   , (baseCmd <> "--patchdir patch_dir", baseOptions{HLS.patches = Just (Left "patch_dir")})
   , (baseCmd <> "-- --enable-tests", baseOptions{HLS.cabalArgs = ["--enable-tests"]})