From c7439d3c89a273e66d10edf766d15c1ccbc49a9f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 25 Oct 2023 00:35:41 +0800 Subject: [PATCH] Improve stack metadata support wrt #892 --- app/ghcup/BrickMain.hs | 8 +- app/ghcup/Main.hs | 17 ++- data/config.yaml | 74 ++++++------ docs/guide.md | 32 ++--- lib-opt/GHCup/OptParse.hs | 21 ++-- lib-opt/GHCup/OptParse/Common.hs | 41 +++++-- lib-opt/GHCup/OptParse/Config.hs | 48 ++------ lib-opt/GHCup/OptParse/Install.hs | 32 ++--- lib-opt/GHCup/OptParse/Prefetch.hs | 8 +- lib/GHCup/Download.hs | 181 +++++++++++------------------ lib/GHCup/Errors.hs | 26 ++++- lib/GHCup/GHC.hs | 10 +- lib/GHCup/Platform.hs | 4 +- lib/GHCup/Prelude.hs | 26 +++++ lib/GHCup/Types.hs | 51 ++++---- lib/GHCup/Types/JSON.hs | 114 ++++++++++++++++-- lib/GHCup/Utils.hs | 25 +--- test/optparse-test/ConfigTest.hs | 9 +- test/optparse-test/InstallTest.hs | 54 +++------ 19 files changed, 410 insertions(+), 371 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 133035a..7143f52 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index b5b25a0..6f92e6c 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 |] 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 |] , 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 |] cmp' tool instVer ver = do (v, _) <- liftE $ fromVersion instVer tool pure (v == ver) + diff --git a/data/config.yaml b/data/config.yaml index 1710a44..024c377 100644 --- a/data/config.yaml +++ b/data/config.yaml @@ -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: diff --git a/docs/guide.md b/docs/guide.md index 73445c1..930dde3 100644 --- a/docs/guide.md +++ b/docs/guide.md @@ -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: diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index e9afba4..43e36b6 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -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 diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index a085b59..597b9d7 100644 --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -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') + diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index b69fce6..97cf23d 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -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 "") <*> 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 diff --git a/lib-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs index f3a8d30..7ad5005 100644 --- a/lib-opt/GHCup/OptParse/Install.hs +++ b/lib-opt/GHCup/OptParse/Install.hs @@ -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 diff --git a/lib-opt/GHCup/OptParse/Prefetch.hs b/lib-opt/GHCup/OptParse/Prefetch.hs index 0839dd0..803457d 100644 --- a/lib-opt/GHCup/OptParse/Prefetch.hs +++ b/lib-opt/GHCup/OptParse/Prefetch.hs @@ -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 diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 3ef3e54..5c833ac 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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 diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 7d56b6b..367b23a 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -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) ]-- diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index 979e671..ddf84a0 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -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 diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index c855039..2017e78 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -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 diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs index 1de047b..36ef6ca 100644 --- a/lib/GHCup/Prelude.hs +++ b/lib/GHCup/Prelude.hs @@ -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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 2023531..974a9ab 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 6eaaeb8..2dfc73b 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index c669aaa..d717ecd 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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 ]-- ----------- diff --git a/test/optparse-test/ConfigTest.hs b/test/optparse-test/ConfigTest.hs index 6f8f658..3ec3607 100644 --- a/test/optparse-test/ConfigTest.hs +++ b/test/optparse-test/ConfigTest.hs @@ -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")) ] diff --git a/test/optparse-test/InstallTest.hs b/test/optparse-test/InstallTest.hs index 3e050d0..020f2f1 100644 --- a/test/optparse-test/InstallTest.hs +++ b/test/optparse-test/InstallTest.hs @@ -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