From de231e95dfb9ccfc34f570ccd1135518a8e7f686 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 22 Oct 2023 21:50:27 +0800 Subject: [PATCH] Support stacks installation strategy and metadata wrt #892 --- app/ghcup/BrickMain.hs | 10 +- app/ghcup/Main.hs | 12 +- ghcup.cabal | 2 + lib-opt/GHCup/OptParse.hs | 2 +- lib-opt/GHCup/OptParse/Config.hs | 4 +- lib-opt/GHCup/OptParse/Install.hs | 49 +++++--- lib-opt/GHCup/OptParse/Run.hs | 16 ++- lib/GHCup/Download.hs | 125 +++++++++++--------- lib/GHCup/Errors.hs | 25 ++++ lib/GHCup/GHC.hs | 21 +++- lib/GHCup/Platform.hs | 163 ++++++++++++++++++++++++++- lib/GHCup/Prelude/MegaParsec.hs | 14 +++ lib/GHCup/Prelude/Process.hs | 1 + lib/GHCup/Prelude/Process/Posix.hs | 12 +- lib/GHCup/Prelude/Process/Windows.hs | 12 +- lib/GHCup/Types.hs | 18 ++- lib/GHCup/Types/JSON.hs | 67 +---------- lib/GHCup/Types/JSON/Versions.hs | 90 +++++++++++++++ lib/GHCup/Types/Stack.hs | 136 ++++++++++++++++++++++ lib/GHCup/Utils.hs | 34 +++--- lib/GHCup/Version.hs | 3 + 21 files changed, 650 insertions(+), 166 deletions(-) create mode 100644 lib/GHCup/Types/JSON/Versions.hs create mode 100644 lib/GHCup/Types/Stack.hs diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 969b8bf5..3445b39b 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -30,6 +30,7 @@ import Brick.Widgets.List ( listSelectedFocusedAttr , listAttr ) import Codec.Archive +import Control.Applicative import Control.Exception.Safe #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -432,7 +433,7 @@ filterVisible v t e | lInstalled e = True (lTool e `notElem` hiddenTools) -install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) +install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => BrickState -> (Int, ListResult) -> m (Either String ()) @@ -463,6 +464,11 @@ install' _ (_, ListResult {..}) = do , ToolShadowed , UninstallFailed , MergeFileTreeError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch ] run (do @@ -509,7 +515,7 @@ install' _ (_, ListResult {..}) = do <> "Also check the logs in ~/.ghcup/logs" -set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) +set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => BrickState -> (Int, ListResult) -> m (Either String ()) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 1d75c208..b5b25a04 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -90,6 +90,8 @@ toSettings options = do 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 @@ -339,11 +341,11 @@ Report bugs at |] , NextVerNotFound , NoToolVersionSet ] m Bool - 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 + alreadyInstalling (Install (Right InstallGHCOptions{..})) (GHC, ver) = cmp' GHC instVer ver + alreadyInstalling (Install (Left (InstallGHC InstallGHCOptions{..}))) (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 alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over })) (GHC, ver) = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver })) diff --git a/ghcup.cabal b/ghcup.cabal index 81aebcf2..e97d9bbd 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -117,7 +117,9 @@ library GHCup.Types GHCup.Types.JSON GHCup.Types.JSON.Utils + GHCup.Types.JSON.Versions GHCup.Types.Optics + GHCup.Types.Stack GHCup.Utils GHCup.Utils.Dirs GHCup.Version diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index 4d3ae30e..e9afba40 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -88,7 +88,7 @@ data Options = Options } data Command - = Install (Either InstallCommand InstallOptions) + = Install (Either InstallCommand InstallGHCOptions) | Test TestCommand | InstallCabalLegacy InstallOptions | Set (Either SetCommand SetOptions) diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index 6e71cd46..b69fce67 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -135,7 +135,9 @@ updateSettings usl usr = gpgSetting' = uGPGSetting usl <|> uGPGSetting usr platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr mirrors' = uMirrors usl <|> uMirrors usr - in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' + 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' where updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings updateKeyBindings Nothing Nothing = Nothing diff --git a/lib-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs index 82a839e7..02b4176a 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 InstallOptions +data InstallCommand = InstallGHC InstallGHCOptions | InstallCabal InstallOptions | InstallHLS InstallOptions | InstallStack InstallOptions @@ -63,6 +63,15 @@ data InstallCommand = InstallGHC InstallOptions --[ Options ]-- --------------- +data InstallGHCOptions = InstallGHCOptions + { instVer :: Maybe ToolVersion + , instBindist :: Maybe URI + , instSet :: Bool + , isolateDir :: Maybe FilePath + , forceInstall :: Bool + , addConfArgs :: [T.Text] + , useStackSetup :: Bool + } deriving (Eq, Show) data InstallOptions = InstallOptions { instVer :: Maybe ToolVersion @@ -93,14 +102,14 @@ installCabalFooter = [s|Discussion: --[ Parsers ]-- --------------- -installParser :: Parser (Either InstallCommand InstallOptions) +installParser :: Parser (Either InstallCommand InstallGHCOptions) installParser = (Left <$> subparser ( command "ghc" ( InstallGHC <$> info - (installOpts (Just GHC) <**> helper) + (installGHCOpts <**> helper) ( progDesc "Install GHC" <> footerDoc (Just $ text installGHCFooter) ) @@ -134,7 +143,7 @@ installParser = ) ) ) - <|> (Right <$> installOpts Nothing) + <|> (Right <$> installGHCOpts) where installHLSFooter :: String installHLSFooter = [s|Discussion: @@ -210,6 +219,13 @@ installOpts tool = Just GHC -> False Just _ -> True +installGHCOpts :: Parser InstallGHCOptions +installGHCOpts = + (\InstallOptions{..} b -> let useStackSetup = b in InstallGHCOptions{..}) + <$> installOpts (Just GHC) + <*> switch + (short 's' <> long "stack-setup" <> help "Use stacks download info and method of deciding which bindist to use") + @@ -291,6 +307,11 @@ type InstallGHCEffects = '[ AlreadyInstalled , UninstallFailed , UnknownArchive , InstallSetError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch ] runInstGHC :: AppState @@ -308,21 +329,21 @@ runInstGHC appstate' = ------------------- -install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode +install :: Either InstallCommand InstallGHCOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode install installCommand settings getAppState' runLogger = case installCommand of - (Right iopts) -> do + (Right iGHCopts) -> do runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.") - installGHC iopts - (Left (InstallGHC iopts)) -> installGHC iopts - (Left (InstallCabal iopts)) -> installCabal iopts - (Left (InstallHLS iopts)) -> installHLS iopts - (Left (InstallStack iopts)) -> installStack iopts + installGHC iGHCopts + (Left (InstallGHC iGHCopts)) -> installGHC iGHCopts + (Left (InstallCabal iopts)) -> installCabal iopts + (Left (InstallHLS iopts)) -> installHLS iopts + (Left (InstallStack iopts)) -> installStack iopts where - installGHC :: InstallOptions -> IO ExitCode - installGHC InstallOptions{..} = do + installGHC :: InstallGHCOptions -> IO ExitCode + installGHC InstallGHCOptions{..} = do s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case instBindist of - Nothing -> runInstGHC s' $ do + Nothing -> runInstGHC s'{ settings = settings {stackSetup = useStackSetup}} $ do (v, vi) <- liftE $ fromVersion instVer GHC liftE $ runBothE' (installGHCBin v diff --git a/lib-opt/GHCup/OptParse/Run.hs b/lib-opt/GHCup/OptParse/Run.hs index b46e0586..c6e8e8f3 100644 --- a/lib-opt/GHCup/OptParse/Run.hs +++ b/lib-opt/GHCup/OptParse/Run.hs @@ -187,6 +187,11 @@ type RunEffects = '[ AlreadyInstalled , ProcessError , UninstallFailed , MergeFileTreeError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch ] runLeanRUN :: (MonadUnliftIO m, MonadIO m) @@ -226,6 +231,7 @@ run :: forall m . , MonadCatch m , MonadIO m , MonadUnliftIO m + , Alternative m ) => RunOptions -> IO AppState @@ -255,7 +261,9 @@ run RunOptions{..} runAppState leanAppstate runLogger = do liftIO $ putStr tmp pure ExitSuccess (cmd:args) -> do - newEnv <- liftIO $ addToPath tmp runAppendPATH + newEnv <- liftIO $ addToPath [tmp] runAppendPATH + let pathVar = if isWindows then "Path" else "PATH" + forM_ (Map.lookup pathVar . Map.fromList $ newEnv) $ liftIO . setEnv pathVar #ifndef IS_WINDOWS void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) pure ExitSuccess @@ -329,6 +337,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do , MonadThrow m , MonadIO m , MonadCatch m + , Alternative m ) => Toolchain -> FilePath @@ -354,6 +363,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do , CopyError , UninstallFailed , MergeFileTreeError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch ] (ResourceT (ReaderT AppState m)) () installToolChainFull Toolchain{..} tmp = do case ghcVer of diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 07135406..8b797d7d 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -5,7 +5,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} - {-| Module : GHCup.Download Description : Downloading @@ -31,6 +30,8 @@ import GHCup.Download.Utils #endif 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 @@ -159,9 +160,10 @@ getBase :: ( MonadReader env m , MonadCatch m , HasLog env , MonadMask m + , FromJSON j ) => URI - -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo + -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m j getBase uri = do Settings { noNetwork, downloader, metaMode } <- lift getSettings @@ -246,7 +248,7 @@ getBase uri = do Settings { metaCache } <- lift getSettings -- for local files, let's short-circuit and ignore access time - if | scheme == "file" -> liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing Nothing (fromGHCupPath cacheDir) Nothing True + if | scheme == "file" -> liftE $ download uri' Nothing Nothing Nothing (fromGHCupPath cacheDir) Nothing True | e -> do accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime @@ -325,6 +327,45 @@ 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 + let siGHCs = Stack.siGHCs $ dli + ghcVersionsPerKey = (\key -> M.lookup key siGHCs) <$> (T.pack <$> keys) + ghcVersions <- (listToMaybe . catMaybes $ ghcVersionsPerKey) ?? (NoDownload tv GHC Nothing) + ghcVersion <- M.lookup v ghcVersions ?? (NoDownload tv GHC Nothing) + fromStackDownloadInfo (Stack.gdiDownloadInfo ghcVersion) + where + 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 + + -- | Tries to download from the given http or https url -- and saves the result in continuous memory into a file. @@ -352,20 +393,15 @@ download :: ( MonadReader env m download rawUri gpgUri eDigest eCSize dest mfn etags | scheme == "https" = liftE dl | scheme == "http" = liftE dl - | scheme == "file" - , Just s <- gpgScheme - , s /= "file" = throwIO $ userError $ "gpg scheme does not match base file scheme: " <> (T.unpack . decUTF8Safe $ s) | scheme == "file" = do - Settings{ gpgSetting } <- lift getSettings let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri lift $ logDebug $ "using local file: " <> T.pack destFile' - liftE $ verify gpgSetting destFile' (pure . T.unpack . decUTF8Safe . view pathL') + forM_ eDigest (liftE . flip checkDigest destFile') pure destFile' | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme) where - scheme = view (uriSchemeL' % schemeBSL') rawUri - gpgScheme = view (uriSchemeL' % schemeBSL') <$> gpgUri + scheme = view (uriSchemeL' % schemeBSL') rawUri dl = do Settings{ mirrors } <- lift getSettings let uri = applyMirrors mirrors rawUri @@ -407,14 +443,30 @@ download rawUri gpgUri eDigest eCSize dest mfn etags else pure (\fp -> liftE . internalDL fp) #endif liftE $ downloadAction baseDestFile uri - liftE $ verify gpgSetting baseDestFile - (\uri' -> do - gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri' Nothing - lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri' <> " as file " <> T.pack gpgDestFile - flip onException (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile)) $ - downloadAction gpgDestFile uri' - pure gpgDestFile - ) + case (gpgUri, gpgSetting) of + (_, GPGNone) -> pure () + (Just gpgUri', _) -> do + gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile gpgUri' Nothing + liftE $ flip onException + (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile)) + $ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError] + (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e)) + ) $ do + o' <- liftIO getGpgOpts + lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile + liftE $ downloadAction gpgDestFile gpgUri' + lift $ logInfo $ "verifying signature of: " <> T.pack baseDestFile + let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, baseDestFile] + cp <- lift $ executeOut "gpg" args Nothing + case cp of + CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do + lift $ logDebug $ decUTF8Safe' _stdErr + throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args))) + CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr + _ -> pure () + + forM_ eCSize (liftE . flip checkCSize baseDestFile) + forM_ eDigest (liftE . flip checkDigest baseDestFile) pure baseDestFile curlDL :: ( MonadCatch m @@ -612,41 +664,6 @@ download rawUri gpgUri eDigest eCSize dest mfn etags liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp) pure Nothing - verify :: ( MonadReader env m - , HasLog env - , HasDirs env - , HasSettings env - , MonadCatch m - , MonadMask m - , MonadIO m - ) - => GPGSetting - -> FilePath - -> (URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m FilePath) - -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m () - verify gpgSetting destFile' downloadAction' = do - case (gpgUri, gpgSetting) of - (_, GPGNone) -> pure () - (Just gpgUri', _) -> do - liftE $ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError] - (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e)) - ) $ do - o' <- liftIO getGpgOpts - gpgDestFile <- liftE $ downloadAction' gpgUri' - lift $ logInfo $ "verifying signature of: " <> T.pack destFile' - let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, destFile'] - cp <- lift $ executeOut "gpg" args Nothing - case cp of - CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do - lift $ logDebug $ decUTF8Safe' _stdErr - throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args))) - CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr - _ -> pure () - - forM_ eCSize (liftE . flip checkCSize destFile') - forM_ eDigest (liftE . flip checkDigest destFile') - - -- | Download into tmpdir or use cached version, if it exists. If filename -- is omitted, infers the filename from the url. @@ -666,7 +683,7 @@ downloadCached :: ( MonadReader env m downloadCached dli mfn = do Settings{ cache } <- lift getSettings case cache of - True -> liftE $ downloadCached' dli mfn Nothing + True -> downloadCached' dli mfn Nothing False -> do tmp <- lift withGHCupTmpDir liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 72ba7d3c..7d56b6b9 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -87,6 +87,7 @@ allHFError = unlines allErrors , let proxy = Proxy :: Proxy ToolShadowed in format proxy , let proxy = Proxy :: Proxy ContentLengthError in format proxy , let proxy = Proxy :: Proxy DuplicateReleaseChannel in format proxy + , let proxy = Proxy :: Proxy UnsupportedSetupCombo in format proxy , "" , "# high level errors (4000+)" , let proxy = Proxy :: Proxy DownloadFailed in format proxy @@ -99,6 +100,7 @@ allHFError = unlines allErrors , let proxy = Proxy :: Proxy ParseError in format proxy , let proxy = Proxy :: Proxy UnexpectedListLength in format proxy , let proxy = Proxy :: Proxy NoUrlBase in format proxy + , let proxy = Proxy :: Proxy DigestMissing in format proxy , "" , "# orphans (800+)" , let proxy = Proxy :: Proxy URIParseError in format proxy @@ -687,6 +689,17 @@ instance Pretty DuplicateReleaseChannel where <> (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)." +data UnsupportedSetupCombo = UnsupportedSetupCombo Architecture Platform + deriving Show + +instance Pretty UnsupportedSetupCombo where + pPrint (UnsupportedSetupCombo arch plat) = + text "Could not find a compatible setup combo for:" <+> pPrint arch <+> pPrint plat + +instance HFErrorProject UnsupportedSetupCombo where + eBase _ = 360 + eDesc _ = "Could not find a compatible setup combo" + ------------------------- --[ High-level errors ]-- ------------------------- @@ -821,6 +834,18 @@ instance HFErrorProject NoUrlBase where eBase _ = 520 eDesc _ = "URL does not have a base filename." +data DigestMissing = DigestMissing URI + deriving Show + +instance Pretty DigestMissing where + pPrint (DigestMissing uri) = + text "Digest missing for:" <+> (text . T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri + +instance Exception DigestMissing + +instance HFErrorProject DigestMissing where + eBase _ = 530 + eDesc _ = "An expected digest is missing." ------------------------ diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index 73493029..979e6713 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -26,6 +26,7 @@ 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 @@ -74,6 +75,7 @@ import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as E @@ -216,7 +218,9 @@ testUnpackedGHC path tver addMakeArgs = do lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!" ghcDir <- lift $ ghcupGHCDir tver let ghcBinDir = fromGHCupPath ghcDir "bin" - env <- liftIO $ addToPath ghcBinDir False + env <- liftIO $ addToPath [ghcBinDir] False + let pathVar = if isWindows then "Path" else "PATH" + forM_ (Map.lookup pathVar . Map.fromList $ env) $ liftIO . setEnv pathVar lEM $ make' (fmap T.unpack addMakeArgs) (Just $ fromGHCupPath path) @@ -512,6 +516,7 @@ installGHCBin :: ( MonadFail m , MonadResource m , MonadIO m , MonadUnliftIO m + , Alternative m ) => GHCTargetVersion -- ^ the version to install -> InstallDir @@ -533,11 +538,23 @@ installGHCBin :: ( MonadFail m , ProcessError , UninstallFailed , MergeFileTreeError + , NoCompatiblePlatform + , ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch ] m () installGHCBin tver installDir forceInstall addConfArgs = do - dlinfo <- liftE $ getDownloadInfo' GHC tver + 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 liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index 58722af0..c8550397 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -23,11 +23,13 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) -import GHCup.Utils.Dirs +import GHCup.Utils import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.Process import GHCup.Prelude.String.QQ +import GHCup.Prelude.Version.QQ +import GHCup.Prelude.MegaParsec #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -48,11 +50,18 @@ import Prelude hiding ( abs ) import System.Info import System.OsRelease +import System.Exit +import System.FilePath import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix +import qualified Text.Megaparsec as MP + import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Void +import qualified Data.List as L + @@ -197,3 +206,155 @@ getLinuxDistro = do try_debian_version = do ver <- T.readFile debian_version pure (T.pack "debian", Just ver) + + +getStackGhcBuilds :: (MonadReader env m, HasLog env, MonadIO m) + => PlatformResult + -> Excepts '[ParseError, NoCompatiblePlatform, DistroNotFound, ProcessError] m [String] +getStackGhcBuilds PlatformResult{..} = do + case _platform of + Linux _ -> do + -- Some systems don't have ldconfig in the PATH, so make sure to look in + -- /sbin and /usr/sbin as well + sbinEnv <- liftIO $ addToPath sbinDirs False + ldConfig <- lift $ executeOut' "ldconfig" ["-p"] Nothing (Just sbinEnv) + firstWords <- case ldConfig of + CapturedProcess ExitSuccess so _ -> + pure . mapMaybe (listToMaybe . T.words) . T.lines . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ so + CapturedProcess (ExitFailure _) _ _ -> + -- throwE $ NonZeroExit c "ldconfig" ["-p" ] + pure [] + let checkLib :: (MonadReader env m, HasLog env, MonadIO m) => String -> m Bool + checkLib lib + | libT `elem` firstWords = do + logDebug $ "Found shared library " <> libT <> " in 'ldconfig -p' output" + pure True + | isWindows = + -- Cannot parse /usr/lib on Windows + pure False + | otherwise = hasMatches lib usrLibDirs + -- This is a workaround for the fact that libtinfo.so.x doesn't + -- appear in the 'ldconfig -p' output on Arch or Slackware even + -- when it exists. There doesn't seem to be an easy way to get the + -- true list of directories to scan for shared libs, but this + -- works for our particular cases. + where + libT = T.pack lib + + hasMatches :: (MonadReader env m, HasLog env, MonadIO m) => String -> [FilePath] -> m Bool + hasMatches lib dirs = do + matches <- filterM (liftIO . doesFileExist . ( lib)) dirs + case matches of + [] -> logDebug ("Did not find shared library " <> libT) >> pure False + (path:_) -> logDebug ("Found shared library " <> libT <> " in " <> T.pack path) >> pure True + where + libT = T.pack lib + + getLibc6Version :: MonadIO m + => Excepts '[ParseError, ProcessError] m Version + getLibc6Version = do + CapturedProcess{..} <- lift $ executeOut "ldd" ["--version"] Nothing + case _exitCode of + ExitSuccess -> either (throwE . ParseError . show) pure + . MP.parse lddVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut + ExitFailure c -> throwE $ NonZeroExit c "ldd" ["--version" ] + + -- Assumes the first line of ldd has the format: + -- + -- ldd (...) nn.nn + -- + -- where nn.nn corresponds to the version of libc6. + lddVersion :: MP.Parsec Void Text Version + lddVersion = do + skipWhile (/= ')') + skip (== ')') + skipSpace + version' + + hasMusl <- hasMatches relFileLibcMuslx86_64So1 libDirs + mLibc6Version <- veitherToEither <$> runE getLibc6Version + case mLibc6Version of + Right libc6Version -> logDebug $ "Found shared library libc6 in version: " <> prettyVer libc6Version + Left _ -> logDebug "Did not find a version of shared library libc6." + let hasLibc6_2_32 = either (const False) (>= [vver|2.32|]) mLibc6Version + hastinfo5 <- checkLib relFileLibtinfoSo5 + hastinfo6 <- checkLib relFileLibtinfoSo6 + hasncurses6 <- checkLib relFileLibncurseswSo6 + hasgmp5 <- checkLib relFileLibgmpSo10 + hasgmp4 <- checkLib relFileLibgmpSo3 + let libComponents = if hasMusl + then + [ ["musl"] ] + else + concat + [ if hastinfo6 && hasgmp5 + then + if hasLibc6_2_32 + then [["tinfo6"]] + else [["tinfo6-libc6-pre232"]] + else [[]] + , [ [] | hastinfo5 && hasgmp5 ] + , [ ["ncurses6"] | hasncurses6 && hasgmp5 ] + , [ ["gmp4"] | hasgmp4 ] + ] + pure $ map + (\c -> case c of + [] -> [] + _ -> L.intercalate "-" c) + libComponents + FreeBSD -> + case _distroVersion of + Just fVer + | fVer >= [vers|12|] -> pure [] + _ -> pure ["ino64"] + Darwin -> pure [] + Windows -> pure [] + where + + relFileLibcMuslx86_64So1 :: FilePath + relFileLibcMuslx86_64So1 = "libc.musl-x86_64.so.1" + libDirs :: [FilePath] + libDirs = ["/lib", "/lib64"] + usrLibDirs :: [FilePath] + usrLibDirs = ["/usr/lib", "/usr/lib64"] + sbinDirs :: [FilePath] + sbinDirs = ["/sbin", "/usr/sbin"] + relFileLibtinfoSo5 :: FilePath + relFileLibtinfoSo5 = "libtinfo.so.5" + relFileLibtinfoSo6 :: FilePath + relFileLibtinfoSo6 = "libtinfo.so.6" + relFileLibncurseswSo6 :: FilePath + relFileLibncurseswSo6 = "libncursesw.so.6" + relFileLibgmpSo10 :: FilePath + relFileLibgmpSo10 = "libgmp.so.10" + relFileLibgmpSo3 :: FilePath + relFileLibgmpSo3 = "libgmp.so.3" + +getStackOSKey :: Monad m => PlatformRequest -> Excepts '[UnsupportedSetupCombo] m String +getStackOSKey PlatformRequest { .. } = + case (_rArch, _rPlatform) of + (A_32 , Linux _) -> pure "linux32" + (A_64 , Linux _) -> pure "linux64" + (A_32 , Darwin ) -> pure "macosx" + (A_64 , Darwin ) -> pure "macosx" + (A_32 , FreeBSD) -> pure "freebsd32" + (A_64 , FreeBSD) -> pure "freebsd64" + (A_32 , Windows) -> pure "windows32" + (A_64 , Windows) -> pure "windows64" + (A_ARM , Linux _) -> pure "linux-armv7" + (A_ARM64, Linux _) -> pure "linux-aarch64" + (A_Sparc, Linux _) -> pure "linux-sparc" + (A_ARM64, Darwin ) -> pure "macosx-aarch64" + (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) + => PlatformRequest + -> Excepts '[UnsupportedSetupCombo, ParseError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound, ProcessError] m [String] +getStackPlatformKey pfreq@PlatformRequest{..} = do + osKey <- liftE $ getStackOSKey pfreq + builds <- liftE $ getStackGhcBuilds (PlatformResult _rPlatform _rVersion) + let builds' = (\build -> if null build then osKey else osKey <> "-" <> build) <$> builds + logDebug $ "Potential GHC builds: " <> mconcat (L.intersperse ", " $ fmap T.pack builds') + pure builds' + diff --git a/lib/GHCup/Prelude/MegaParsec.hs b/lib/GHCup/Prelude/MegaParsec.hs index c28f0115..bbf6fb19 100644 --- a/lib/GHCup/Prelude/MegaParsec.hs +++ b/lib/GHCup/Prelude/MegaParsec.hs @@ -120,3 +120,17 @@ verP suffix = do pathSep :: MP.Parsec Void Text Char pathSep = MP.oneOf pathSeparators + +skipWhile :: (Char -> Bool) -> MP.Parsec Void Text () +skipWhile f = void $ MP.takeWhileP Nothing f + +skip :: (Char -> Bool) -> MP.Parsec Void Text () +skip f = void $ MP.satisfy f + +skipSpace :: MP.Parsec Void Text () +skipSpace = void $ MP.satisfy isSpace + +isSpace :: Char -> Bool +isSpace c = (c == ' ') || ('\t' <= c && c <= '\r') +{-# INLINE isSpace #-} + diff --git a/lib/GHCup/Prelude/Process.hs b/lib/GHCup/Prelude/Process.hs index ed38b4e3..144d1440 100644 --- a/lib/GHCup/Prelude/Process.hs +++ b/lib/GHCup/Prelude/Process.hs @@ -11,6 +11,7 @@ Portability : portable -} module GHCup.Prelude.Process ( executeOut, + executeOut', execLogged, exec, toProcessError, diff --git a/lib/GHCup/Prelude/Process/Posix.hs b/lib/GHCup/Prelude/Process/Posix.hs index 4e9670b9..bdc263b5 100644 --- a/lib/GHCup/Prelude/Process/Posix.hs +++ b/lib/GHCup/Prelude/Process/Posix.hs @@ -70,6 +70,16 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do maybe (pure ()) changeWorkingDirectory chdir SPP.executeFile path True args Nothing +executeOut' :: MonadIO m + => FilePath -- ^ command as filename, e.g. 'ls' + -> [String] -- ^ arguments to the command + -> Maybe FilePath -- ^ chdir to this path + -> Maybe [(String, String)] + -> m CapturedProcess +executeOut' path args chdir env = liftIO $ captureOutStreams $ do + maybe (pure ()) changeWorkingDirectory chdir + SPP.executeFile path True args env + execLogged :: ( MonadReader env m , HasSettings env @@ -169,7 +179,7 @@ execLogged exe args chdir lfile env = do overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1 blue :: ByteString -> ByteString - blue bs + blue bs | no_color = bs | otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m" diff --git a/lib/GHCup/Prelude/Process/Windows.hs b/lib/GHCup/Prelude/Process/Windows.hs index 89ac9a2b..22ef5290 100644 --- a/lib/GHCup/Prelude/Process/Windows.hs +++ b/lib/GHCup/Prelude/Process/Windows.hs @@ -140,8 +140,16 @@ executeOut :: MonadIO m -> [String] -- ^ arguments to the command -> Maybe FilePath -- ^ chdir to this path -> m CapturedProcess -executeOut path args chdir = do - cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir }) +executeOut path args chdir = executeOut' path args chdir Nothing + +executeOut' :: MonadIO m + => FilePath -- ^ command as filename, e.g. 'ls' + -> [String] -- ^ arguments to the command + -> Maybe FilePath -- ^ chdir to this path + -> Maybe [(String, String)] + -> m CapturedProcess +executeOut' path args chdir env' = do + cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir, env = env' }) (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp "" pure $ CapturedProcess exit out err diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 974ff3f6..bd103ae9 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -46,7 +46,6 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified GHC.Generics as GHC import qualified Data.List.NonEmpty as NE -import Data.Foldable (foldMap) #if !defined(BRICK) data Key = KEsc | KChar Char | KBS | KEnter @@ -343,6 +342,11 @@ instance NFData URLSource instance NFData (URIRef Absolute) where rnf (URI !_ !_ !_ !_ !_) = () +data StackSetupURLSource = StackSetupURL + deriving (Show, Read, Eq, GHC.Generic) + +instance NFData StackSetupURLSource + data MetaMode = Strict | Lax deriving (Show, Read, Eq, GHC.Generic) @@ -363,11 +367,13 @@ 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 +defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings Settings{..} Nothing = @@ -385,6 +391,8 @@ fromSettings Settings{..} Nothing = , uGPGSetting = Just gpgSetting , uPlatformOverride = platformOverride , uMirrors = Just mirrors + , uStackSetupSource = Just stackSetupSource + , uStackSetup = Just stackSetup } fromSettings Settings{..} (Just KeyBindings{..}) = let ukb = UserKeyBindings @@ -412,6 +420,8 @@ fromSettings Settings{..} (Just KeyBindings{..}) = , uGPGSetting = Just gpgSetting , uPlatformOverride = platformOverride , uMirrors = Just mirrors + , uStackSetupSource = Just stackSetupSource + , uStackSetup = Just stackSetup } data UserKeyBindings = UserKeyBindings @@ -496,6 +506,8 @@ data Settings = Settings , noColor :: Bool -- this also exists in LoggerConfig , platformOverride :: Maybe PlatformRequest , mirrors :: DownloadMirrors + , stackSetupSource :: StackSetupURLSource + , stackSetup :: Bool } deriving (Show, GHC.Generic) @@ -503,7 +515,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) +defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) StackSetupURL False instance NFData Settings diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index ed308ab1..4fa4bb59 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -23,6 +23,7 @@ module GHCup.Types.JSON where import GHCup.Types import GHCup.Types.JSON.Utils +import GHCup.Types.JSON.Versions () import GHCup.Prelude.MegaParsec import Control.Applicative ( (<|>) ) @@ -112,34 +113,6 @@ instance FromJSONKey GHCTargetVersion where Right x -> pure x Left e -> fail $ "Failure in GHCTargetVersion (FromJSONKey)" <> show e -instance ToJSON Versioning where - toJSON = toJSON . prettyV - -instance FromJSON Versioning where - parseJSON = withText "Versioning" $ \t -> case versioning t of - Right x -> pure x - Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e - -instance ToJSONKey Versioning where - toJSONKey = toJSONKeyText $ \x -> prettyV x - -instance FromJSONKey Versioning where - fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of - Right x -> pure x - Left e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e - -instance ToJSONKey (Maybe Versioning) where - toJSONKey = toJSONKeyText $ \case - Just x -> prettyV x - Nothing -> T.pack "unknown_versioning" - -instance FromJSONKey (Maybe Versioning) where - fromJSONKey = FromJSONKeyTextParser $ \t -> - if t == T.pack "unknown_versioning" then pure Nothing else just t - where - just t = case versioning t of - Right x -> pure $ Just x - Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e instance ToJSONKey Platform where toJSONKey = toJSONKeyText $ \case @@ -176,43 +149,6 @@ instance ToJSONKey Architecture where instance FromJSONKey Architecture where fromJSONKey = genericFromJSONKey defaultJSONKeyOptions -instance ToJSONKey (Maybe Version) where - toJSONKey = toJSONKeyText $ \case - Just x -> prettyVer x - Nothing -> T.pack "unknown_version" - -instance FromJSONKey (Maybe Version) where - fromJSONKey = FromJSONKeyTextParser $ \t -> - if t == T.pack "unknown_version" then pure Nothing else just t - where - just t = case version t of - Right x -> pure $ Just x - Left e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e - -instance ToJSON Version where - toJSON = toJSON . prettyVer - -instance FromJSON Version where - parseJSON = withText "Version" $ \t -> case version t of - Right x -> pure x - Left e -> fail $ "Failure in Version (FromJSON)" <> show e - -instance ToJSONKey Version where - toJSONKey = toJSONKeyText $ \x -> prettyVer x - -instance FromJSONKey Version where - fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of - Right x -> pure x - Left e -> fail $ "Failure in Version (FromJSONKey)" <> show e - -instance ToJSON PVP where - toJSON = toJSON . prettyPVP - -instance FromJSON PVP where - parseJSON = withText "PVP" $ \t -> case pvp t of - Right x -> pure x - Left e -> fail $ "Failure in PVP (FromJSON)" <> show e - instance ToJSONKey Tool where toJSONKey = genericToJSONKey defaultJSONKeyOptions @@ -348,6 +284,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downlo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource +deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''StackSetupURLSource deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port diff --git a/lib/GHCup/Types/JSON/Versions.hs b/lib/GHCup/Types/JSON/Versions.hs new file mode 100644 index 00000000..0d65e39c --- /dev/null +++ b/lib/GHCup/Types/JSON/Versions.hs @@ -0,0 +1,90 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : GHCup.Types.JSON.Versions +Description : GHCup Version JSON types/instances +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Types.JSON.Versions where + +import Data.Aeson hiding (Key) +import Data.Aeson.Types hiding (Key) +import Data.Versions + +import qualified Data.Text as T + +instance ToJSON Versioning where + toJSON = toJSON . prettyV + +instance FromJSON Versioning where + parseJSON = withText "Versioning" $ \t -> case versioning t of + Right x -> pure x + Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e + +instance ToJSONKey Versioning where + toJSONKey = toJSONKeyText $ \x -> prettyV x + +instance FromJSONKey Versioning where + fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of + Right x -> pure x + Left e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e + +instance ToJSONKey (Maybe Versioning) where + toJSONKey = toJSONKeyText $ \case + Just x -> prettyV x + Nothing -> T.pack "unknown_versioning" + +instance FromJSONKey (Maybe Versioning) where + fromJSONKey = FromJSONKeyTextParser $ \t -> + if t == T.pack "unknown_versioning" then pure Nothing else just t + where + just t = case versioning t of + Right x -> pure $ Just x + Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e + +instance ToJSONKey (Maybe Version) where + toJSONKey = toJSONKeyText $ \case + Just x -> prettyVer x + Nothing -> T.pack "unknown_version" + +instance FromJSONKey (Maybe Version) where + fromJSONKey = FromJSONKeyTextParser $ \t -> + if t == T.pack "unknown_version" then pure Nothing else just t + where + just t = case version t of + Right x -> pure $ Just x + Left e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e + +instance ToJSON Version where + toJSON = toJSON . prettyVer + +instance FromJSON Version where + parseJSON = withText "Version" $ \t -> case version t of + Right x -> pure x + Left e -> fail $ "Failure in Version (FromJSON)" <> show e + +instance ToJSONKey Version where + toJSONKey = toJSONKeyText $ \x -> prettyVer x + +instance FromJSONKey Version where + fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of + Right x -> pure x + Left e -> fail $ "Failure in Version (FromJSONKey)" <> show e + +instance ToJSON PVP where + toJSON = toJSON . prettyPVP + +instance FromJSON PVP where + parseJSON = withText "PVP" $ \t -> case pvp t of + Right x -> pure x + Left e -> fail $ "Failure in PVP (FromJSON)" <> show e diff --git a/lib/GHCup/Types/Stack.hs b/lib/GHCup/Types/Stack.hs new file mode 100644 index 00000000..76aca2b3 --- /dev/null +++ b/lib/GHCup/Types/Stack.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| +Module : GHCup.Types.Stack +Description : GHCup types.Stack +Copyright : (c) Julian Ospald, 2023 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Types.Stack where + +import GHCup.Types.JSON.Versions () + +import Control.Applicative +import Control.Monad.Catch +import Data.ByteString +import Data.Aeson +import Data.Aeson.Types +import Data.Map.Strict ( Map ) +import Data.Text ( Text ) +import Data.Text.Encoding +import Data.Versions +import URI.ByteString + +import qualified Data.Map as Map + + + --------------------------- + --[ Stack download info ]-- + --------------------------- + +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) + } + deriving Show + +instance FromJSON SetupInfo where + parseJSON = withObject "SetupInfo" $ \o -> do + siSevenzExe <- o .:? "sevenzexe-info" + siSevenzDll <- o .:? "sevenzdll-info" + siMsys2 <- o .:? "msys2" .!= mempty + siGHCs <- o .:? "ghc" .!= mempty + siStack <- o .:? "stack" .!= mempty + pure SetupInfo {..} + +-- | For the @siGHCs@ field maps are deeply merged. For all fields the values +-- from the first @SetupInfo@ win. +instance Semigroup SetupInfo where + l <> r = + SetupInfo + { siSevenzExe = siSevenzExe l <|> siSevenzExe r + , siSevenzDll = siSevenzDll l <|> siSevenzDll r + , siMsys2 = siMsys2 l <> siMsys2 r + , siGHCs = Map.unionWith (<>) (siGHCs l) (siGHCs r) + , siStack = Map.unionWith (<>) (siStack l) (siStack r) } + +instance Monoid SetupInfo where + mempty = + SetupInfo + { siSevenzExe = Nothing + , siSevenzDll = Nothing + , siMsys2 = Map.empty + , siGHCs = Map.empty + , siStack = Map.empty + } + mappend = (<>) + +-- | Build of the compiler distribution (e.g. standard, gmp4, tinfo6) +-- | Information for a file to download. +data DownloadInfo = DownloadInfo + { downloadInfoUrl :: Text + -- ^ URL or absolute file path + , downloadInfoContentLength :: Maybe Int + , downloadInfoSha1 :: Maybe ByteString + , downloadInfoSha256 :: Maybe ByteString + } + deriving Show + +instance FromJSON DownloadInfo where + parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject + +-- | Parse JSON in existing object for 'DownloadInfo' +parseDownloadInfoFromObject :: Object -> Parser DownloadInfo +parseDownloadInfoFromObject o = do + url <- o .: "url" + contentLength <- o .:? "content-length" + sha1TextMay <- o .:? "sha1" + sha256TextMay <- o .:? "sha256" + pure + DownloadInfo + { downloadInfoUrl = url + , downloadInfoContentLength = contentLength + , downloadInfoSha1 = fmap encodeUtf8 sha1TextMay + , downloadInfoSha256 = fmap encodeUtf8 sha256TextMay + } + +data VersionedDownloadInfo = VersionedDownloadInfo + { vdiVersion :: Version + , vdiDownloadInfo :: DownloadInfo + } + deriving Show + +instance FromJSON VersionedDownloadInfo where + parseJSON = withObject "VersionedDownloadInfo" $ \o -> do + ver' <- o .: "version" + downloadInfo <- parseDownloadInfoFromObject o + pure VersionedDownloadInfo + { vdiVersion = ver' + , vdiDownloadInfo = downloadInfo + } + +data GHCDownloadInfo = GHCDownloadInfo + { gdiConfigureOpts :: [Text] + , gdiConfigureEnv :: Map Text Text + , gdiDownloadInfo :: DownloadInfo + } + deriving Show + +instance FromJSON GHCDownloadInfo where + parseJSON = withObject "GHCDownloadInfo" $ \o -> do + configureOpts <- o .:? "configure-opts" .!= mempty + configureEnv <- o .:? "configure-env" .!= mempty + downloadInfo <- parseDownloadInfoFromObject o + pure GHCDownloadInfo + { gdiConfigureOpts = configureOpts + , gdiConfigureEnv = configureEnv + , gdiDownloadInfo = downloadInfo + } + diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 5216ab9b..c669aaa9 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -49,7 +49,6 @@ import GHCup.Prelude.Logger.Internal import GHCup.Prelude.MegaParsec import GHCup.Prelude.Process import GHCup.Prelude.String.QQ - import Codec.Archive hiding ( Directory ) import Control.Applicative import Control.Exception.Safe @@ -92,7 +91,7 @@ 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, setEnv) +import System.Environment (getEnvironment) import Data.Time (Day(..), diffDays, addDays) @@ -1321,20 +1320,27 @@ warnAboutHlsCompatibility = do -addToPath :: FilePath +addToPath :: [FilePath] -> Bool -- ^ if False will prepend -> IO [(String, String)] -addToPath path append = do - cEnv <- Map.fromList <$> getEnvironment - let paths = ["PATH", "Path"] - curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths - {- HLINT ignore "Redundant bracket" -} - newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ [path]) else (path : 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 - liftIO $ setEnv pathVar newPath - return envWithNewPath +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/Version.hs b/lib/GHCup/Version.hs index 73ef5fee..a9c03b58 100644 --- a/lib/GHCup/Version.hs +++ b/lib/GHCup/Version.hs @@ -36,6 +36,9 @@ import Data.Void (Void) ghcupURL :: URI ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.8.yaml|] +stackSetupURL :: URI +stackSetupURL = [uri|https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml|] + -- | The current ghcup version. ghcUpVer :: V.PVP ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version