hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'issue-978'

Browse Source
This commit is contained in:
Julian Ospald 2024-01-21 16:34:31 +08:00
commit 9a7eb11c73
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
15 changed files with 98 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/scripts/common.sh vendored
View File

@ -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

1
.github/scripts/test.sh vendored
View File

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

4
.github/workflows/release.yaml vendored
View File

@ -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

1
.gitignore vendored
View File

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

4
cabal.project
View File

@ -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

4
cabal.project.release
View File

@ -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

2
ghcup.cabal
View File

@ -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

9
lib-opt/GHCup/OptParse/Common.hs
View File

@ -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')

5
lib/GHCup/Download.hs
View File

@ -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

5
lib/GHCup/Download/IOStreams.hs
View File

@ -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

5
lib/GHCup/Types/JSON.hs
View File

@ -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

4
lib/GHCup/Utils.hs
View File

@ -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

49
lib/GHCup/Utils/URI.hs Normal file
View File

@ -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

4
test/ghcup-test/golden/windows/GHCupInfo.json
View File

@ -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"
}

16
test/optparse-test/CompileTest.hs
View File

@ -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"]})