Merge branch 'improve-stack-setup-use'

This commit is contained in:
Julian Ospald 2023-10-25 15:01:04 +08:00
commit d85accb08e
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
19 changed files with 410 additions and 371 deletions

View File

@ -11,7 +11,7 @@ module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types.Optics ( getDirs )
import GHCup.Types.Optics ( getDirs, getPlatformReq )
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils
import GHCup.OptParse.Common (logGHCPostRm)
@ -660,8 +660,10 @@ getGHCupInfo = do
r <-
flip runReaderT settings
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE getDownloadsF
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
$ do
pfreq <- lift getPlatformReq
liftE $ getDownloadsF pfreq
case r of
VRight a -> pure $ Right a

View File

@ -42,7 +42,6 @@ import Data.Aeson.Encode.Pretty ( encodePretty )
import Data.Either
import Data.Functor
import Data.Maybe
import Data.Versions
import GHC.IO.Encoding
import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH
@ -85,13 +84,11 @@ toSettings options = do
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
urlSource = fromMaybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) optUrlSource
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors
stackSetupSource = fromMaybe (Types.stackSetupSource defaultSettings) uStackSetupSource
stackSetup = fromMaybe (Types.stackSetup defaultSettings) uStackSetup
in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
@ -213,10 +210,9 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
exitWith (ExitFailure 2)
ghcupInfo <-
( flip runReaderT leanAppstate
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE getDownloadsF
)
( flip runReaderT leanAppstate . runE @'[ContentLengthError, DigestError, DistroNotFound, DownloadFailed, FileDoesNotExistError, GPGError, JSONError, NoCompatibleArch, NoCompatiblePlatform, NoDownload, GHCup.Errors.ParseError, ProcessError, UnsupportedSetupCombo, StackPlatformDetectError] $ do
liftE $ getDownloadsF pfreq
)
>>= \case
VRight r -> pure r
VLeft e -> do
@ -341,8 +337,8 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
, NextVerNotFound
, NoToolVersionSet
] m Bool
alreadyInstalling (Install (Right InstallGHCOptions{..})) (GHC, ver) = cmp' GHC instVer ver
alreadyInstalling (Install (Left (InstallGHC InstallGHCOptions{..}))) (GHC, ver) = cmp' GHC instVer ver
alreadyInstalling (Install (Right InstallOptions{..})) (GHC, ver) = cmp' GHC instVer ver
alreadyInstalling (Install (Left (InstallGHC InstallOptions{..}))) (GHC, ver) = cmp' GHC instVer ver
alreadyInstalling (Install (Left (InstallCabal InstallOptions{..}))) (Cabal, ver) = cmp' Cabal instVer ver
alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver
alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver
@ -380,3 +376,4 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
cmp' tool instVer ver = do
(v, _) <- liftE $ fromVersion instVer tool
pure (v == ver)

View File

@ -51,53 +51,45 @@ meta-cache: 300 # in seconds
# 2. Strict: fail hard
meta-mode: Lax # Strict | Lax
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
# check the 'URLSource' type in the code.
# Where to get GHC/cabal/hls download info/versions from. This is a list that performs
# union over tool versions, preferring the later entries.
url-source:
## Use the internal download uri, this is the default
GHCupURL: []
- GHCupURL
## Example 1: Read download info from this location instead
## Accepts file/http/https scheme
## Can also be an array of URLs or an array of 'Either GHCupInfo URL', in
## which case they are merged right-biased (overwriting duplicate versions).
# OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
## Prefer stack supplied metadata (will still use GHCup metadata for versions not existing in stack metadata)
# - StackSetupURL
## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions.
## Can also be an array of 'Either GHCupInfo URL', also see Example 3.
# AddSource:
# Left:
# globalTools: {}
# toolRequirements: {}
# ghcupDownloads:
# GHC:
# 9.10.2:
# viTags: []
# viArch:
# A_64:
# Linux_UnknownLinux:
# unknown_versioning:
# dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2
# dlSubdir: ghc-7.10.3
# dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
## Add pre-release channel
# - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
## Add nightly channel
# - https://ghc.gitlab.haskell.org/ghcup-metadata/ghcup-nightlies-0.0.7.yaml
## Add cross compiler channel
# - https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-cross-0.0.8.yaml
## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate
## versions).
# AddSource:
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
# For stack's setup-info, this works similar, e.g.:
# stack-setup-source:
# AddSource:
# - Left:
# ghc:
# linux64-tinfo6:
# 9.4.7:
# url: "https://downloads.haskell.org/~ghc/9.4.7/ghc-9.4.7-x86_64-fedora27-linux.tar.xz"
# content-length: 179117892
# sha256: 216b76b7c6383e6ad9ba82533f323f8550e52893a8b9fa33c7b9dc4201ac766a
## Use dwarf bindist for 9.4.7 for ghcup metadata
# - ghcup-info:
# ghcupDownloads:
# GHC:
# 9.4.7:
# viTags: []
# viArch:
# A_64:
# Linux_UnknownLinux:
# unknown_versioning:
# dlUri: https://downloads.haskell.org/ghc/9.4.7/ghc-9.4.7-x86_64-deb10-linux-dwarf.tar.xz
# dlSubdir:
# RegexDir: "ghc-.*"
# dlHash: b261b3438ba455e3cf757f9c8dc3a06fdc061ea8ec287a65b7809e25fe18bad4
## for stack metadata and the linux64-tinfo6 bindists, use static alpine for 9.8.1
# - setup-info:
# ghc:
# linux64-tinfo6:
# 9.8.1:
# url: "https://downloads.haskell.org/~ghc/9.8.1/ghc-9.8.1-x86_64-alpine3_12-linux-static.tar.xz"
# content-length: 229037440
# sha256: b48f3d3a508d0c140d1c801e04afc65e80c0d25e7e939a8a41edb387b26b81b3
# This is a way to override platform detection, e.g. when you're running
# a Ubuntu derivate based on 18.04, you could do:

View File

@ -153,8 +153,7 @@ To use a mirror, set the following option in `~/.ghcup/config.yaml`:
```yml
url-source:
# Accepts file/http/https scheme
OwnSource: "https://some-url/ghcup-0.0.6.yaml"
- https://some-url/ghcup-0.0.6.yaml
```
See [config.yaml](https://github.com/haskell/ghcup-hs/blob/master/data/config.yaml)
@ -184,8 +183,8 @@ This will result in `~/.ghcup/config.yaml` to contain this record:
```yml
url-source:
AddSource:
- Right: https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
- GHCupURL
- https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml
```
You can add as many channels as you like. They are combined under *Last*, so versions from the prerelease channel
@ -195,14 +194,13 @@ To remove the channel, delete the entire `url-source` section or set it back to
```yml
url-source:
GHCupURL: []
- GHCupURL
```
If you want to combine your release channel with a mirror, you'd do it like so:
```yml
url-source:
OwnSource:
# base metadata
- "https://mirror.sjtu.edu.cn/ghcup/yaml/ghcup/data/ghcup-0.0.6.yaml"
# prerelease channel
@ -249,24 +247,32 @@ stack config set system-ghc true --global
### Using stack's setup-info metadata to install GHC
You can now use stack's [setup-info metadata](https://github.com/commercialhaskell/stackage-content/blob/master/stack/stack-setup-2.yaml)
to install GHC. For that, you can invoke ghcup like so:
to install GHC. For that, you can invoke ghcup like so as a shorthand:
```sh
ghcup install ghc --stack-setup 9.4.7
# ghcup will only see GHC now
ghcup -s StackSetupURL install ghc 9.4.7
# this combines both ghcup and stack metadata
ghcup -s '["GHCupURL", "StackSetupURL"]' install ghc 9.4.7
```
To make this permanent, you can add the following to you `~/.ghcup/config.yaml`:
To make this permanent and combine it with the GHCup metadata, you can add the following to your `~/.ghcup/config.yaml`:
```yaml
stack-setup: true
url-source:
- GHCupURL
# stack versions take precedence
# you'll still have access to GHCup provided versions and tools in case they don't exist in stack metadata
- StackSetupURL
```
You can customize or add sections to the setup-info similar to how the [stack documentation](https://docs.haskellstack.org/en/stable/yaml_configuration/#setup-info) explains it. E.g. to change the 9.4.7 bindist, you might do:
```yaml
stack-setup-source:
AddSource:
- Left:
url-source:
- GHCupURL
- StackSetupURL
- setup-info:
ghc:
linux64-tinfo6:
9.4.7:

View File

@ -57,16 +57,13 @@ import GHCup.Types
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Data.Bifunctor
import Data.Either
import Data.Functor
import Data.Maybe
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8
data Options = Options
@ -77,18 +74,19 @@ data Options = Options
, optMetaCache :: Maybe Integer
, optMetaMode :: Maybe MetaMode
, optPlatform :: Maybe PlatformRequest
, optUrlSource :: Maybe URI
, optUrlSource :: Maybe URLSource
, optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader
, optNoNetwork :: Maybe Bool
, optGpg :: Maybe GPGSetting
, optStackSetup :: Maybe Bool
-- commands
, optCommand :: Command
}
data Command
= Install (Either InstallCommand InstallGHCOptions)
= Install (Either InstallCommand InstallOptions)
| Test TestCommand
| InstallCabalLegacy InstallOptions
| Set (Either SetCommand SetOptions)
@ -134,13 +132,13 @@ opts =
)
<*> optional
(option
(eitherReader parseUri)
(eitherReader parseUrlSource)
( short 's'
<> long "url-source"
<> metavar "URL"
<> help "Alternative ghcup download info url"
<> metavar "URL_SOURCE"
<> help "Alternative ghcup download info"
<> internal
<> completer fileUri
<> completer urlSourceCompleter
)
)
<*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
@ -178,10 +176,9 @@ opts =
"GPG verification (default: none)"
<> completer (listCompleter ["strict", "lax", "none"])
))
<*> invertableSwitch "stack-setup" (Just 's') False (help "Use stack's setup info for discovering and installing GHC versions")
<*> com
where
parseUri s' =
first show $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command

View File

@ -64,6 +64,8 @@ import URI.ByteString
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as LE
import qualified Data.Text.Lazy as LT
import qualified Text.Megaparsec as MP
import qualified System.FilePath.Posix as FP
import GHCup.Version
@ -322,6 +324,15 @@ toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]
gitFileUri :: [String] -> Completer
gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)
urlSourceCompleter :: Completer
urlSourceCompleter = mkCompleter $ urlSourceCompleter' []
urlSourceCompleter' :: [String] -> String -> IO [String]
urlSourceCompleter' add str' = do
let static = ["GHCupURL", "StackSetupURL"]
file <- fileUri' add str'
pure $ static ++ file
fileUri :: Completer
fileUri = mkCompleter $ fileUri' []
@ -450,13 +461,15 @@ tagCompleter tool add = listIOCompleter $ do
defaultKeyBindings
loggerConfig
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
case mGhcUpInfo of
VRight ghcupInfo -> do
let allTags = filter (/= Old)
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
mpFreq <- flip runReaderT appState . runE $ platformRequest
forFold mpFreq $ \pfreq -> do
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF pfreq
case mGhcUpInfo of
VRight ghcupInfo -> do
let allTags = filter (/= Old)
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
versionCompleter :: [ListCriteria] -> Tool -> Completer
versionCompleter criteria tool = versionCompleter' criteria tool (const True)
@ -477,8 +490,8 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do
defaultKeyBindings
loggerConfig
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \pfreq -> do
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF pfreq
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
settings
@ -817,3 +830,15 @@ logGHCPostRm ghcVer = do
let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))
logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir
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')
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')

View File

@ -32,7 +32,6 @@ import Options.Applicative hiding ( style, ParseError )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
import qualified Data.ByteString.UTF8 as UTF8
@ -51,7 +50,7 @@ data ConfigCommand
= ShowConfig
| SetConfig String (Maybe String)
| InitConfig
| AddReleaseChannel Bool URI
| AddReleaseChannel Bool NewURLSource
deriving (Eq, Show)
@ -75,8 +74,8 @@ configP = subparser
showP = info (pure ShowConfig) (progDesc "Show current config (default)")
setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
(progDesc "Add a release channel from a URI")
addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader parseNewUrlSource) (metavar "URL_SOURCE" <> completer urlSourceCompleter))
(progDesc "Add a release channel, e.g. from a URI")
@ -135,9 +134,7 @@ updateSettings usl usr =
gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
mirrors' = uMirrors usl <|> uMirrors usr
stackSetupSource' = uStackSetupSource usl <|> uStackSetupSource usr
stackSetup' = uStackSetup usl <|> uStackSetup usr
in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' stackSetupSource' stackSetup'
in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'
where
updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
updateKeyBindings Nothing Nothing = Nothing
@ -209,27 +206,15 @@ config configCommand settings userConf keybindings runLogger = case configComman
pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65
AddReleaseChannel force uri -> do
AddReleaseChannel force new -> do
r <- runE @'[DuplicateReleaseChannel] $ do
case urlSource settings of
AddSource xs -> do
case checkDuplicate xs (Right uri) of
Duplicate
| not force -> throwE (DuplicateReleaseChannel uri)
DuplicateLast -> pure ()
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) })
GHCupURL -> do
lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
pure ()
OwnSource xs -> do
case checkDuplicate xs (Right uri) of
Duplicate
| not force -> throwE (DuplicateReleaseChannel uri)
DuplicateLast -> pure ()
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) })
OwnSpec spec -> do
lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] })
pure ()
let oldSources = fromURLSource (urlSource settings)
let merged = oldSources ++ [new]
case checkDuplicate oldSources new of
Duplicate
| not force -> throwE (DuplicateReleaseChannel new)
DuplicateLast -> pure ()
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ SimpleList merged })
case r of
VRight _ -> do
pure ExitSuccess
@ -244,15 +229,6 @@ config configCommand settings userConf keybindings runLogger = case configComman
| a `elem` xs = Duplicate
| otherwise = NoDuplicate
-- appends the element to the end of the list, but also removes it from the existing list
appendUnique :: Eq a => [a] -> a -> [a]
appendUnique xs' e = go xs'
where
go [] = [e]
go (x:xs)
| x == e = go xs -- skip
| otherwise = x : go xs
doConfig :: MonadIO m => UserSettings -> m ()
doConfig usersettings = do
let settings' = updateSettings usersettings userConf

View File

@ -50,7 +50,7 @@ import qualified Data.Text as T
----------------
data InstallCommand = InstallGHC InstallGHCOptions
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
| InstallHLS InstallOptions
| InstallStack InstallOptions
@ -63,16 +63,6 @@ data InstallCommand = InstallGHC InstallGHCOptions
--[ Options ]--
---------------
data InstallGHCOptions = InstallGHCOptions
{ instVer :: Maybe ToolVersion
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
, forceInstall :: Bool
, addConfArgs :: [T.Text]
, useStackSetup :: Maybe Bool
} deriving (Eq, Show)
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instBindist :: Maybe URI
@ -102,14 +92,14 @@ installCabalFooter = [s|Discussion:
--[ Parsers ]--
---------------
installParser :: Parser (Either InstallCommand InstallGHCOptions)
installParser :: Parser (Either InstallCommand InstallOptions)
installParser =
(Left <$> subparser
( command
"ghc"
( InstallGHC
<$> info
(installGHCOpts <**> helper)
(installOpts (Just GHC) <**> helper)
( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter)
)
@ -143,7 +133,7 @@ installParser =
)
)
)
<|> (Right <$> installGHCOpts)
<|> (Right <$> installOpts (Just GHC))
where
installHLSFooter :: String
installHLSFooter = [s|Discussion:
@ -219,12 +209,6 @@ installOpts tool =
Just GHC -> False
Just _ -> True
installGHCOpts :: Parser InstallGHCOptions
installGHCOpts =
(\InstallOptions{..} b -> let useStackSetup = b in InstallGHCOptions{..})
<$> installOpts (Just GHC)
<*> invertableSwitch "stack-setup" (Just 's') False (help "Set as active version after install")
@ -328,7 +312,7 @@ runInstGHC appstate' =
-------------------
install :: Either InstallCommand InstallGHCOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
install installCommand settings getAppState' runLogger = case installCommand of
(Right iGHCopts) -> do
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
@ -338,11 +322,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
(Left (InstallHLS iopts)) -> installHLS iopts
(Left (InstallStack iopts)) -> installStack iopts
where
installGHC :: InstallGHCOptions -> IO ExitCode
installGHC InstallGHCOptions{..} = do
installGHC :: InstallOptions -> IO ExitCode
installGHC InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstGHC s'{ settings = maybe settings (\b -> settings {stackSetup = b}) useStackSetup } $ do
Nothing -> runInstGHC s' $ do
(v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin
v

View File

@ -14,6 +14,7 @@ module GHCup.OptParse.Prefetch where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Prelude.File
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
@ -157,7 +158,9 @@ type PrefetchEffects = '[ TagNotFound
, GPGError
, DownloadFailed
, JSONError
, FileDoesNotExistError ]
, FileDoesNotExistError
, StackPlatformDetectError
]
runPrefetch :: MonadUnliftIO m
@ -210,7 +213,8 @@ prefetch prefetchCommand runAppState runLogger =
(v, _) <- liftE $ fromVersion mt Stack
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
PrefetchMetadata -> do
_ <- liftE getDownloadsF
pfreq <- lift getPlatformReq
_ <- liftE $ getDownloadsF pfreq
pure ""
) >>= \case
VRight _ -> do

View File

@ -31,10 +31,10 @@ import GHCup.Download.Utils
import GHCup.Errors
import GHCup.Types
import qualified GHCup.Types.Stack as Stack
import GHCup.Types.Stack (downloadInfoUrl, downloadInfoSha256)
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Platform
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger.Internal
@ -56,6 +56,7 @@ import Data.ByteString ( ByteString )
import Data.CaseInsensitive ( mk )
#endif
import Data.Maybe
import Data.Either
import Data.List
import Data.Time.Clock
import Data.Time.Clock.POSIX
@ -113,24 +114,71 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadFail m
, MonadMask m
)
=> Excepts
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
=> PlatformRequest
-> Excepts
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
m
GHCupInfo
getDownloadsF = do
getDownloadsF pfreq@(PlatformRequest arch plat _) = do
Settings { urlSource } <- lift getSettings
case urlSource of
GHCupURL -> liftE $ getBase ghcupURL
(OwnSource exts) -> do
ext <- liftE $ mapM (either pure getBase) exts
mergeGhcupInfo ext
(OwnSpec av) -> pure av
(AddSource exts) -> do
base <- liftE $ getBase ghcupURL
ext <- liftE $ mapM (either pure getBase) exts
mergeGhcupInfo (base:ext)
let newUrlSources = fromURLSource urlSource
infos <- liftE $ mapM dl' newUrlSources
keys <- if any isRight infos
then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
else pure []
ghcupInfos <- fmap catMaybes $ forM infos $ \case
Left gi -> pure (Just gi)
Right si -> pure $ fromStackSetupInfo si keys
mergeGhcupInfo ghcupInfos
where
dl' :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadReader env m
, HasSettings env
, HasDirs env
, MonadIO m
, MonadCatch m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> NewURLSource
-> Excepts
'[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError]
m (Either GHCupInfo Stack.SetupInfo)
dl' NewGHCupURL = fmap Left $ liftE $ getBase @GHCupInfo ghcupURL
dl' NewStackSetupURL = fmap Right $ liftE $ getBase @Stack.SetupInfo stackSetupURL
dl' (NewGHCupInfo gi) = pure (Left gi)
dl' (NewSetupInfo si) = pure (Right si)
dl' (NewURI uri) = catchE @JSONError (\(JSONDecodeError _) -> Right <$> getBase @Stack.SetupInfo uri)
$ fmap Left $ getBase @GHCupInfo uri
fromStackSetupInfo :: MonadThrow m
=> Stack.SetupInfo
-> [String]
-> m GHCupInfo
fromStackSetupInfo (Stack.siGHCs -> ghcDli) keys = do
let ghcVersionsPerKey = (`M.lookup` ghcDli) <$> (T.pack <$> keys)
ghcVersions = fromMaybe mempty . listToMaybe . catMaybes $ ghcVersionsPerKey
(ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
pure (GHCupInfo mempty ghcupDownloads' mempty)
where
fromDownloadInfo :: DownloadInfo -> VersionInfo
fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing
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
sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256
pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing
mergeGhcupInfo :: MonadFail m
=> [GHCupInfo]
-> m GHCupInfo
@ -142,6 +190,7 @@ getDownloadsF = do
in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
yamlFromCache uri = do
Dirs{..} <- getDirs
@ -152,7 +201,7 @@ etagsFile :: FilePath -> FilePath
etagsFile = (<.> "etags")
getBase :: ( MonadReader env m
getBase :: forall j m env . ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadFail m
@ -327,106 +376,6 @@ getDownloadInfo' t v = do
_ -> with_distro <|> without_distro_ver <|> without_distro
)
getStackDownloadInfo :: ( MonadReader env m
, HasDirs env
, HasGHCupInfo env
, HasLog env
, HasPlatformReq env
, HasSettings env
, MonadCatch m
, MonadFail m
, MonadIO m
, MonadMask m
, MonadThrow m
)
=> StackSetupURLSource
-> [String]
-> Tool
-> GHCTargetVersion
-- ^ tool version
-> Excepts
'[NoDownload, DownloadFailed]
m
DownloadInfo
getStackDownloadInfo stackSetupSource keys@(_:_) GHC tv@(GHCTargetVersion Nothing v) =
case stackSetupSource of
StackSetupURL -> do
(dli :: Stack.SetupInfo) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getBase stackSetupURL
sDli <- liftE $ stackDownloadInfo dli
lift $ fromStackDownloadInfo sDli
(SOwnSource exts) -> do
(dlis :: [Stack.SetupInfo]) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ mapM (either pure getBase) exts
dli <- lift $ mergeSetupInfo dlis
sDli <- liftE $ stackDownloadInfo dli
lift $ fromStackDownloadInfo sDli
(SOwnSpec si) -> do
sDli <- liftE $ stackDownloadInfo si
lift $ fromStackDownloadInfo sDli
(SAddSource exts) -> do
base :: Stack.SetupInfo <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getBase stackSetupURL
(dlis :: [Stack.SetupInfo]) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ mapM (either pure getBase) exts
dli <- lift $ mergeSetupInfo (base:dlis)
sDli <- liftE $ stackDownloadInfo dli
lift $ fromStackDownloadInfo sDli
where
stackDownloadInfo :: MonadIO m => Stack.SetupInfo -> Excepts '[NoDownload] m Stack.DownloadInfo
stackDownloadInfo dli@Stack.SetupInfo{} = do
let siGHCs = Stack.siGHCs dli
ghcVersionsPerKey = (`M.lookup` siGHCs) <$> (T.pack <$> keys)
ghcVersions <- (listToMaybe . catMaybes $ ghcVersionsPerKey) ?? NoDownload tv GHC Nothing
(Stack.gdiDownloadInfo <$> M.lookup v ghcVersions) ?? NoDownload tv GHC Nothing
mergeSetupInfo :: MonadFail m
=> [Stack.SetupInfo]
-> m Stack.SetupInfo
mergeSetupInfo [] = fail "mergeSetupInfo: internal error: need at least one SetupInfo"
mergeSetupInfo xs@(Stack.SetupInfo{}: _) =
let newSevenzExe = Stack.siSevenzExe $ last xs
newSevenzDll = Stack.siSevenzDll $ last xs
newMsys2 = M.unionsWith (\_ a2 -> a2 ) (Stack.siMsys2 <$> xs)
newGHCs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (Stack.siGHCs <$> xs)
newStack = M.unionsWith (M.unionWith (\_ b2 -> b2)) (Stack.siStack <$> xs)
in pure $ Stack.SetupInfo newSevenzExe newSevenzDll newMsys2 newGHCs newStack
fromStackDownloadInfo :: MonadThrow m => Stack.DownloadInfo -> m DownloadInfo
fromStackDownloadInfo Stack.DownloadInfo{..} = do
url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI strictURIParserOptions . E.encodeUtf8 $ downloadInfoUrl
sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256
pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing
getStackDownloadInfo _ _ t v = throwE $ NoDownload v t Nothing
{--
data SetupInfo = SetupInfo
{ siSevenzExe :: Maybe DownloadInfo
, siSevenzDll :: Maybe DownloadInfo
, siMsys2 :: Map Text VersionedDownloadInfo
, siGHCs :: Map Text (Map Version GHCDownloadInfo)
, siStack :: Map Text (Map Version DownloadInfo)
data VersionedDownloadInfo = VersionedDownloadInfo
{ vdiVersion :: Version
, vdiDownloadInfo :: DownloadInfo
}
}
data DownloadInfo = DownloadInfo
{ downloadInfoUrl :: Text
-- ^ URL or absolute file path
, downloadInfoContentLength :: Maybe Int
, downloadInfoSha1 :: Maybe ByteString
, downloadInfoSha256 :: Maybe ByteString
}
data GHCDownloadInfo = GHCDownloadInfo
{ gdiConfigureOpts :: [Text]
, gdiConfigureEnv :: Map Text Text
, gdiDownloadInfo :: DownloadInfo
}
--}
-- | Tries to download from the given http or https url

View File

@ -676,18 +676,18 @@ instance HFErrorProject ContentLengthError where
eBase _ = 340
eDesc _ = "File content length verification failed"
data DuplicateReleaseChannel = DuplicateReleaseChannel URI
data DuplicateReleaseChannel = DuplicateReleaseChannel NewURLSource
deriving Show
instance HFErrorProject DuplicateReleaseChannel where
eBase _ = 350
eDesc _ = "Duplicate release channel detected when adding URI.\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."
eDesc _ = "Duplicate release channel detected when adding new source.\nGiving up. You can use '--force' to remove and append the duplicate source (this may change order/semantics)."
instance Pretty DuplicateReleaseChannel where
pPrint (DuplicateReleaseChannel uri) =
pPrint (DuplicateReleaseChannel source) =
text $ "Duplicate release channel detected when adding: \n "
<> (T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri
<> "\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."
<> show source
<> "\nGiving up. You can use '--force' to remove and append the duplicate source (this may change order/semantics)."
data UnsupportedSetupCombo = UnsupportedSetupCombo Architecture Platform
deriving Show
@ -787,6 +787,22 @@ instance HFErrorProject GHCupSetError where
eNum (GHCupSetError xs) = 9000 + eNum xs
eDesc _ = "Setting the current version failed."
-- | Executing stacks platform detection failed.
data StackPlatformDetectError = forall es . (ToVariantMaybe StackPlatformDetectError es, PopVariant StackPlatformDetectError es, Show (V es), Pretty (V es), HFErrorProject (V es)) => StackPlatformDetectError (V es)
instance Pretty StackPlatformDetectError where
pPrint (StackPlatformDetectError reason) =
case reason of
VMaybe (_ :: StackPlatformDetectError) -> pPrint reason
_ -> text "Running stack platform detection logic failed:" <+> pPrint reason
deriving instance Show StackPlatformDetectError
instance HFErrorProject StackPlatformDetectError where
eBase _ = 6000
eNum (StackPlatformDetectError xs) = 6000 + eNum xs
eDesc _ = "Running stack platform detection logic failed."
---------------------------------------------
--[ True Exceptions (e.g. for MonadThrow) ]--

View File

@ -26,7 +26,6 @@ import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Platform
import GHCup.Prelude
import GHCup.Prelude.File
import GHCup.Prelude.Logger
@ -547,14 +546,7 @@ installGHCBin :: ( MonadFail m
m
()
installGHCBin tver installDir forceInstall addConfArgs = do
Settings{ stackSetupSource, stackSetup } <- lift getSettings
dlinfo <- if stackSetup
then do
lift $ logInfo "Using stack's setup-info to install GHC"
pfreq <- lift getPlatformReq
keys <- liftE $ getStackPlatformKey pfreq
liftE $ getStackDownloadInfo stackSetupSource keys GHC tver
else liftE $ getDownloadInfo' GHC tver
dlinfo <- liftE $ getDownloadInfo' GHC tver
liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs

View File

@ -23,7 +23,7 @@ import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils
import GHCup.Utils.Dirs
import GHCup.Prelude
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
@ -348,7 +348,7 @@ getStackOSKey PlatformRequest { .. } =
(A_ARM64, FreeBSD) -> pure "freebsd-aarch64"
(arch', os') -> throwE $ UnsupportedSetupCombo arch' os'
getStackPlatformKey :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
getStackPlatformKey :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> PlatformRequest
-> Excepts '[UnsupportedSetupCombo, ParseError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound, ProcessError] m [String]
getStackPlatformKey pfreq@PlatformRequest{..} = do

View File

@ -43,6 +43,10 @@ import Control.Monad.Reader
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass ( Pretty )
import qualified Data.Text as T
import System.Environment (getEnvironment)
import qualified Data.Map.Strict as Map
import System.FilePath
import Data.List (intercalate)
@ -88,3 +92,25 @@ throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excep
{-# INLINABLE throwSomeE #-}
throwSomeE = Excepts . pure . VLeft . liftVariant
#endif
addToPath :: [FilePath]
-> Bool -- ^ if False will prepend
-> IO [(String, String)]
addToPath paths append = do
cEnv <- getEnvironment
return $ addToPath' cEnv paths append
addToPath' :: [(String, String)]
-> [FilePath]
-> Bool -- ^ if False will prepend
-> [(String, String)]
addToPath' cEnv' newPaths append =
let cEnv = Map.fromList cEnv'
paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
{- HLINT ignore "Redundant bracket" -}
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
pathVar = if isWindows then "Path" else "PATH"
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
in envWithNewPath

View File

@ -201,7 +201,7 @@ instance Pretty Tag where
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
pPrint (UnknownTag t ) = text t
pPrint LatestPrerelease = text "latest-prerelease"
pPrint LatestNightly = text "latest-prerelease"
pPrint LatestNightly = text "latest-prerelease"
pPrint Old = mempty
data Architecture = A_64
@ -342,18 +342,35 @@ instance Pretty TarDir where
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource [Either GHCupInfo URI] -- ^ complete source list
| OwnSpec GHCupInfo
| AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
deriving (GHC.Generic, Show)
| StackSetupURL
| OwnSource [Either (Either GHCupInfo SetupInfo) URI] -- ^ complete source list
| OwnSpec (Either GHCupInfo SetupInfo)
| AddSource [Either (Either GHCupInfo SetupInfo) URI] -- ^ merge with GHCupURL
| SimpleList [NewURLSource]
deriving (Eq, GHC.Generic, Show)
data StackSetupURLSource = StackSetupURL
| SOwnSource [Either SetupInfo URI] -- ^ complete source list
| SOwnSpec SetupInfo
| SAddSource [Either SetupInfo URI] -- ^ merge with GHCupURL
deriving (Show, Eq, GHC.Generic)
data NewURLSource = NewGHCupURL
| NewStackSetupURL
| NewGHCupInfo GHCupInfo
| NewSetupInfo SetupInfo
| NewURI URI
deriving (Eq, GHC.Generic, Show)
instance NFData StackSetupURLSource
instance NFData NewURLSource
fromURLSource :: URLSource -> [NewURLSource]
fromURLSource GHCupURL = [NewGHCupURL]
fromURLSource StackSetupURL = [NewStackSetupURL]
fromURLSource (OwnSource arr) = convert' <$> arr
fromURLSource (AddSource arr) = NewGHCupURL:(convert' <$> arr)
fromURLSource (SimpleList arr) = arr
fromURLSource (OwnSpec (Left gi)) = [NewGHCupInfo gi]
fromURLSource (OwnSpec (Right si)) = [NewSetupInfo si]
convert' :: Either (Either GHCupInfo SetupInfo) URI -> NewURLSource
convert' (Left (Left gi)) = NewGHCupInfo gi
convert' (Left (Right si)) = NewSetupInfo si
convert' (Right uri) = NewURI uri
instance NFData URLSource
instance NFData (URIRef Absolute) where
@ -380,13 +397,11 @@ data UserSettings = UserSettings
, uGPGSetting :: Maybe GPGSetting
, uPlatformOverride :: Maybe PlatformRequest
, uMirrors :: Maybe DownloadMirrors
, uStackSetupSource :: Maybe StackSetupURLSource
, uStackSetup :: Maybe Bool
}
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing =
@ -404,8 +419,6 @@ fromSettings Settings{..} Nothing =
, uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
, uMirrors = Just mirrors
, uStackSetupSource = Just stackSetupSource
, uStackSetup = Just stackSetup
}
fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings
@ -433,8 +446,6 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
, uMirrors = Just mirrors
, uStackSetupSource = Just stackSetupSource
, uStackSetup = Just stackSetup
}
data UserKeyBindings = UserKeyBindings
@ -523,8 +534,6 @@ data Settings = Settings
, noColor :: Bool -- this also exists in LoggerConfig
, platformOverride :: Maybe PlatformRequest
, mirrors :: DownloadMirrors
, stackSetupSource :: StackSetupURLSource
, stackSetup :: Bool
}
deriving (Show, GHC.Generic)
@ -532,7 +541,7 @@ defaultMetaCache :: Integer
defaultMetaCache = 300 -- 5 minutes
defaultSettings :: Settings
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) StackSetupURL False
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty)
instance NFData Settings

View File

@ -22,6 +22,7 @@ Portability : portable
module GHCup.Types.JSON where
import GHCup.Types
import GHCup.Types.Stack (SetupInfo)
import GHCup.Types.JSON.Utils
import GHCup.Types.JSON.Versions ()
import GHCup.Prelude.MegaParsec
@ -32,7 +33,9 @@ import Data.Aeson.TH
import Data.Aeson.Types hiding (Key)
import Data.ByteString ( ByteString )
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe
import Data.Text.Encoding as E
import Data.Foldable
import Data.Versions
import Data.Void
import URI.ByteString
@ -278,13 +281,29 @@ instance FromJSONKey (Maybe VersionRange) where
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, constructorTagModifier = \str' -> if str' == "StackSetupURL" then str' else maybe str' T.unpack . T.stripPrefix (T.pack "S") . T.pack $ str' } ''StackSetupURLSource
instance FromJSON GHCupInfo where
parseJSON = withObject "GHCupInfo" $ \o -> do
toolRequirements' <- o .:? "toolRequirements"
globalTools' <- o .:? "globalTools"
ghcupDownloads' <- o .: "ghcupDownloads"
pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' (fromMaybe mempty globalTools'))
deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
instance ToJSON NewURLSource where
toJSON NewGHCupURL = String "GHCupURL"
toJSON NewStackSetupURL = String "StackSetupURL"
toJSON (NewGHCupInfo gi) = object [ "ghcup-info" .= gi ]
toJSON (NewSetupInfo si) = object [ "setup-info" .= si ]
toJSON (NewURI uri) = toJSON uri
instance ToJSON URLSource where
toJSON = toJSON . fromURLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
@ -297,13 +316,29 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downlo
instance FromJSON URLSource where
parseJSON v =
parseGHCupURL v
<|> parseStackURL v
<|> parseOwnSourceLegacy v
<|> parseOwnSourceNew1 v
<|> parseOwnSourceNew2 v
<|> parseOwnSpec v
<|> legacyParseAddSource v
<|> newParseAddSource v
-- new since Stack SetupInfo
<|> parseOwnSpecNew v
<|> parseOwnSourceNew3 v
<|> newParseAddSource2 v
-- more lenient versions
<|> parseOwnSpecLenient v
<|> parseOwnSourceLenient v
<|> parseAddSourceLenient v
-- simplified list
<|> parseNewUrlSource v
<|> parseNewUrlSource' v
where
convert'' :: Either GHCupInfo URI -> Either (Either GHCupInfo SetupInfo) URI
convert'' (Left gi) = Left (Left gi)
convert'' (Right uri) = Right uri
parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
r :: URI <- o .: "OwnSource"
pure (OwnSource [Right r])
@ -312,20 +347,85 @@ instance FromJSON URLSource where
pure (OwnSource (fmap Right r))
parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "OwnSource"
pure (OwnSource r)
pure (OwnSource (convert'' <$> r))
parseOwnSpec = withObject "URLSource" $ \o -> do
r :: GHCupInfo <- o .: "OwnSpec"
pure (OwnSpec r)
pure (OwnSpec $ Left r)
parseGHCupURL = withObject "URLSource" $ \o -> do
_ :: [Value] <- o .: "GHCupURL"
pure GHCupURL
parseStackURL = withObject "URLSource" $ \o -> do
_ :: [Value] <- o .: "StackSetupURL"
pure StackSetupURL
legacyParseAddSource = withObject "URLSource" $ \o -> do
r :: Either GHCupInfo URI <- o .: "AddSource"
pure (AddSource [r])
pure (AddSource [convert'' r])
newParseAddSource = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "AddSource"
pure (AddSource (convert'' <$> r))
-- new since Stack SetupInfo
parseOwnSpecNew = withObject "URLSource" $ \o -> do
r :: Either GHCupInfo SetupInfo <- o .: "OwnSpec"
pure (OwnSpec r)
parseOwnSourceNew3 = withObject "URLSource" $ \o -> do
r :: [Either (Either GHCupInfo SetupInfo) URI] <- o .: "OwnSource"
pure (OwnSource r)
newParseAddSource2 = withObject "URLSource" $ \o -> do
r :: [Either (Either GHCupInfo SetupInfo) URI] <- o .: "AddSource"
pure (AddSource r)
-- more lenient versions
parseOwnSpecLenient = withObject "URLSource" $ \o -> do
spec :: Object <- o .: "OwnSpec"
OwnSpec <$> lenientInfoParser spec
parseOwnSourceLenient = withObject "URLSource" $ \o -> do
mown :: Array <- o .: "OwnSource"
OwnSource . toList <$> mapM lenientInfoUriParser mown
parseAddSourceLenient = withObject "URLSource" $ \o -> do
madd :: Array <- o .: "AddSource"
AddSource . toList <$> mapM lenientInfoUriParser madd
-- simplified
parseNewUrlSource = withArray "URLSource" $ \a -> do
SimpleList . toList <$> mapM parseJSON a
parseNewUrlSource' v' = SimpleList .(:[]) <$> parseJSON v'
lenientInfoUriParser :: Value -> Parser (Either (Either GHCupInfo SetupInfo) URI)
lenientInfoUriParser (Object o) = Left <$> lenientInfoParser o
lenientInfoUriParser v@(String _) = Right <$> parseJSON v
lenientInfoUriParser _ = fail "Unexpected json in lenientInfoUriParser"
lenientInfoParser :: Object -> Parser (Either GHCupInfo SetupInfo)
lenientInfoParser o = do
setup_info :: Maybe Object <- o .:? "setup-info"
case setup_info of
Nothing -> do
r <- parseJSON (Object o)
pure $ Left r
Just setup_info' -> do
r <- parseJSON (Object setup_info')
pure $ Right r
instance FromJSON NewURLSource where
parseJSON v = uri v <|> url v <|> gi v <|> si v
where
uri = withText "NewURLSource" $ \t -> NewURI <$> parseJSON (String t)
url = withText "NewURLSource" $ \t -> case T.unpack t of
"GHCupURL" -> pure NewGHCupURL
"StackSetupURL" -> pure NewStackSetupURL
t' -> fail $ "Unexpected text value in NewURLSource: " <> t'
gi = withObject "NewURLSource" $ \o -> do
ginfo :: GHCupInfo <- o .: "ghcup-info"
pure $ NewGHCupInfo ginfo
si = withObject "NewURLSource" $ \o -> do
sinfo :: SetupInfo <- o .: "setup-info"
pure $ NewSetupInfo sinfo
instance FromJSON KeyCombination where
parseJSON v = proper v <|> simple v
where

View File

@ -89,9 +89,9 @@ import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
import qualified Data.List.NonEmpty as NE
import qualified Streamly.Prelude as S
import Control.DeepSeq (force)
import GHC.IO (evaluate)
import System.Environment (getEnvironment)
import Data.Time (Day(..), diffDays, addDays)
@ -1320,29 +1320,6 @@ warnAboutHlsCompatibility = do
addToPath :: [FilePath]
-> Bool -- ^ if False will prepend
-> IO [(String, String)]
addToPath paths append = do
cEnv <- getEnvironment
return $ addToPath' cEnv paths append
addToPath' :: [(String, String)]
-> [FilePath]
-> Bool -- ^ if False will prepend
-> [(String, String)]
addToPath' cEnv' newPaths append =
let cEnv = Map.fromList cEnv'
paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
{- HLINT ignore "Redundant bracket" -}
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
pathVar = if isWindows then "Path" else "PATH"
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
in envWithNewPath
-----------
--[ Git ]--
-----------

View File

@ -5,6 +5,7 @@ module ConfigTest where
import Test.Tasty
import Test.Tasty.HUnit
import GHCup.OptParse
import GHCup.Types (NewURLSource(..))
import Utils
import Control.Monad.IO.Class
import URI.ByteString.QQ
@ -23,7 +24,13 @@ checkList =
, ("config init", InitConfig)
, ("config show", ShowConfig)
, ("config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml"
, AddReleaseChannel False [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml|]
, AddReleaseChannel False (NewURI [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml|])
)
, ("config add-release-channel GHCupURL"
, AddReleaseChannel False NewGHCupURL
)
, ("config add-release-channel StackSetupURL"
, AddReleaseChannel False NewStackSetupURL
)
, ("config set cache true", SetConfig "cache" (Just "true"))
]

View File

@ -2,9 +2,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
module InstallTest where
@ -16,8 +13,6 @@ import Data.Versions
import Data.List.NonEmpty (NonEmpty ((:|)))
import GHCup.OptParse.Install as Install
import URI.ByteString.QQ
import URI.ByteString
import Data.Text (Text)
-- Some interests:
-- install ghc *won't* select `set as activate version` as default
@ -31,52 +26,37 @@ installTests = testGroup "install"
(buildTestTree installParseWith)
[ ("old-style", oldStyleCheckList)
, ("ghc", installGhcCheckList)
, ("cabal", (fmap . fmap . fmap) toGHCOptions installCabalCheckList)
, ("hls", (fmap . fmap . fmap) toGHCOptions installHlsCheckList)
, ("stack", (fmap . fmap . fmap) toGHCOptions installStackCheckList)
, ("cabal", installCabalCheckList)
, ("hls", installHlsCheckList)
, ("stack", installStackCheckList)
]
toGHCOptions :: InstallOptions -> InstallGHCOptions
toGHCOptions InstallOptions{..}
= InstallGHCOptions instVer
instBindist
instSet
isolateDir
forceInstall
addConfArgs
Nothing
defaultOptions :: InstallOptions
defaultOptions = InstallOptions Nothing Nothing False Nothing False []
defaultGHCOptions :: InstallGHCOptions
defaultGHCOptions = InstallGHCOptions Nothing Nothing False Nothing False [] Nothing
-- | Don't set as active version
mkInstallOptions :: ToolVersion -> InstallGHCOptions
mkInstallOptions ver = InstallGHCOptions (Just ver) Nothing False Nothing False [] Nothing
mkInstallOptions :: ToolVersion -> InstallOptions
mkInstallOptions ver = InstallOptions (Just ver) Nothing False Nothing False []
-- | Set as active version
mkInstallOptions' :: ToolVersion -> InstallOptions
mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False []
oldStyleCheckList :: [(String, Either InstallCommand InstallGHCOptions)]
oldStyleCheckList :: [(String, Either InstallCommand InstallOptions)]
oldStyleCheckList =
("install", Right defaultGHCOptions)
: ("install --set", Right (defaultGHCOptions{instSet = True} :: InstallGHCOptions))
: ("install --force", Right (defaultGHCOptions{forceInstall = True} :: InstallGHCOptions))
("install", Right defaultOptions)
: ("install --set", Right defaultOptions{instSet = True})
: ("install --force", Right defaultOptions{forceInstall = True})
#ifdef IS_WINDOWS
: ("install -i C:\\\\", Right (defaultGHCOptions{Install.isolateDir = Just "C:\\\\"} :: InstallGHCOptions))
: ("install -i C:\\\\", Right defaultOptions{Install.isolateDir = Just "C:\\\\"})
#else
: ("install -i /", Right (defaultGHCOptions{Install.isolateDir = Just "/"} :: InstallGHCOptions))
: ("install -i /", Right defaultOptions{Install.isolateDir = Just "/"})
#endif
: ("install -u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz head"
, Right (defaultGHCOptions
, Right defaultOptions
{ instBindist = Just [uri|https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz|]
, instVer = Just $ GHCVersion $ GHCTargetVersion Nothing $(versionQ "head")
} :: InstallGHCOptions)
}
)
: mapSecond
(Right . mkInstallOptions)
@ -128,9 +108,9 @@ oldStyleCheckList =
)
]
installGhcCheckList :: [(String, Either InstallCommand InstallGHCOptions)]
installGhcCheckList :: [(String, Either InstallCommand InstallOptions)]
installGhcCheckList =
("install ghc", Left $ InstallGHC defaultGHCOptions)
("install ghc", Left $ InstallGHC defaultOptions)
: mapSecond (Left . InstallGHC . mkInstallOptions)
[ ("install ghc 9.2", GHCVersion
$ GHCTargetVersion
@ -171,7 +151,7 @@ installGhcCheckList =
installCabalCheckList :: [(String, Either InstallCommand InstallOptions)]
installCabalCheckList =
("install cabal", Left $ InstallCabal (defaultOptions{instSet = True} :: InstallOptions))
("install cabal", Left $ InstallCabal defaultOptions{instSet = True})
: mapSecond (Left . InstallCabal . mkInstallOptions')
[ ("install cabal 3.10", ToolVersion $(versionQ "3.10"))
, ("install cabal next", ToolVersion $(versionQ "next"))
@ -217,7 +197,7 @@ installStackCheckList =
, ("install stack stack-2.9", ToolVersion $(versionQ "stack-2.9"))
]
installParseWith :: [String] -> IO (Either InstallCommand InstallGHCOptions)
installParseWith :: [String] -> IO (Either InstallCommand InstallOptions)
installParseWith args = do
Install a <- parseWith args
pure a