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/data/config.yaml b/data/config.yaml index 0659e0cb..430484cb 100644 --- a/data/config.yaml +++ b/data/config.yaml @@ -82,6 +82,18 @@ url-source: # - 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 + + # 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 000cc6c4..73445c1f 100644 --- a/docs/guide.md +++ b/docs/guide.md @@ -246,6 +246,38 @@ stack config set install-ghc false --global 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: + +```sh +ghcup install ghc --stack-setup 9.4.7 +``` + +To make this permanent, you can add the following to you `~/.ghcup/config.yaml`: + +```yaml +stack-setup: true +``` + +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: + 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 +``` + +The main caveat with using this method is that there's no guarantee that GHCup will pick a compatible HLS bindist +when you try to install HLS. + ### Windows On windows, you may find the following config options useful too: 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..f3a8d30e 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 :: Maybe 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,12 @@ 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") + @@ -291,6 +306,11 @@ type InstallGHCEffects = '[ AlreadyInstalled , UninstallFailed , UnknownArchive , InstallSetError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch ] runInstGHC :: AppState @@ -308,21 +328,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 = maybe settings (\b -> settings {stackSetup = b}) 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..3ef3e546 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,107 @@ 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 -- and saves the result in continuous memory into a file. @@ -352,20 +455,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 +505,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 +726,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 +745,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..fe930feb 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -26,6 +26,7 @@ module GHCup.Types ) where +import GHCup.Types.Stack ( SetupInfo ) import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath ) import Control.DeepSeq ( NFData, rnf ) @@ -46,7 +47,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 @@ -58,6 +58,7 @@ data Key = KEsc | KChar Char | KBS | KEnter #endif + -------------------- --[ GHCInfo Tree ]-- -------------------- @@ -339,10 +340,19 @@ data URLSource = GHCupURL | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL deriving (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) + +instance NFData StackSetupURLSource + instance NFData URLSource instance NFData (URIRef Absolute) where rnf (URI !_ !_ !_ !_ !_) = () + data MetaMode = Strict | Lax deriving (Show, Read, Eq, GHC.Generic) @@ -363,11 +373,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 +397,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 +426,8 @@ fromSettings Settings{..} (Just KeyBindings{..}) = , uGPGSetting = Just gpgSetting , uPlatformOverride = platformOverride , uMirrors = Just mirrors + , uStackSetupSource = Just stackSetupSource + , uStackSetup = Just stackSetup } data UserKeyBindings = UserKeyBindings @@ -496,6 +512,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 +521,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 @@ -749,3 +767,4 @@ instance Pretty ToolVersion where data BuildSystem = Hadrian | Make deriving (Show, Eq) + diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index ed308ab1..c6f8c5af 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, constructorTagModifier = \str' -> if str' == "StackSetupURL" then str' else maybe str' T.unpack . T.stripPrefix (T.pack "S") . T.pack $ str' } ''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..52cea720 --- /dev/null +++ b/lib/GHCup/Types/Stack.hs @@ -0,0 +1,180 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} + +{-| +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.DeepSeq ( NFData ) +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 qualified Data.Map as Map +import qualified GHC.Generics as GHC + + + -------------------------------------- + --[ Stack download info copy pasta ]-- + -------------------------------------- + +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, Eq, GHC.Generic) + +instance NFData SetupInfo + +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 {..} + +instance ToJSON SetupInfo where + toJSON (SetupInfo {..}) = object [ "sevenzexe-info" .= siSevenzExe + , "sevenzdll-info" .= siSevenzDll + , "msys2" .= siMsys2 + , "ghc" .= siGHCs + , "stack" .= siStack + ] + +-- | 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, Eq, GHC.Generic) + +instance ToJSON DownloadInfo where + toJSON (DownloadInfo {..}) = object [ "url" .= downloadInfoUrl + , "content-length" .= downloadInfoContentLength + , "sha1" .= (decodeUtf8 <$> downloadInfoSha1) + , "sha256" .= (decodeUtf8 <$> downloadInfoSha256) + ] + +instance NFData DownloadInfo + +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, Eq, GHC.Generic) + +instance ToJSON VersionedDownloadInfo where + toJSON (VersionedDownloadInfo {vdiDownloadInfo = DownloadInfo{..}, ..}) + = object [ "version" .= vdiVersion + , "url" .= downloadInfoUrl + , "content-length" .= downloadInfoContentLength + , "sha1" .= (decodeUtf8 <$> downloadInfoSha1) + , "sha256" .= (decodeUtf8 <$> downloadInfoSha256) + ] + +instance NFData VersionedDownloadInfo + +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, Eq, GHC.Generic) + +instance NFData GHCDownloadInfo + +instance ToJSON GHCDownloadInfo where + toJSON (GHCDownloadInfo {gdiDownloadInfo = DownloadInfo {..}, ..}) + = object [ "configure-opts" .= gdiConfigureOpts + , "configure-env" .= gdiConfigureEnv + , "url" .= downloadInfoUrl + , "content-length" .= downloadInfoContentLength + , "sha1" .= (decodeUtf8 <$> downloadInfoSha1) + , "sha256" .= (decodeUtf8 <$> downloadInfoSha256) + ] + +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 diff --git a/test/optparse-test/InstallTest.hs b/test/optparse-test/InstallTest.hs index 020f2f1b..3e050d0f 100644 --- a/test/optparse-test/InstallTest.hs +++ b/test/optparse-test/InstallTest.hs @@ -2,6 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} module InstallTest where @@ -13,6 +16,8 @@ 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 @@ -26,37 +31,52 @@ installTests = testGroup "install" (buildTestTree installParseWith) [ ("old-style", oldStyleCheckList) , ("ghc", installGhcCheckList) - , ("cabal", installCabalCheckList) - , ("hls", installHlsCheckList) - , ("stack", installStackCheckList) + , ("cabal", (fmap . fmap . fmap) toGHCOptions installCabalCheckList) + , ("hls", (fmap . fmap . fmap) toGHCOptions installHlsCheckList) + , ("stack", (fmap . fmap . fmap) toGHCOptions 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 -> InstallOptions -mkInstallOptions ver = InstallOptions (Just ver) Nothing False Nothing False [] +mkInstallOptions :: ToolVersion -> InstallGHCOptions +mkInstallOptions ver = InstallGHCOptions (Just ver) Nothing False Nothing False [] Nothing -- | Set as active version mkInstallOptions' :: ToolVersion -> InstallOptions mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False [] -oldStyleCheckList :: [(String, Either InstallCommand InstallOptions)] +oldStyleCheckList :: [(String, Either InstallCommand InstallGHCOptions)] oldStyleCheckList = - ("install", Right defaultOptions) - : ("install --set", Right defaultOptions{instSet = True}) - : ("install --force", Right defaultOptions{forceInstall = True}) + ("install", Right defaultGHCOptions) + : ("install --set", Right (defaultGHCOptions{instSet = True} :: InstallGHCOptions)) + : ("install --force", Right (defaultGHCOptions{forceInstall = True} :: InstallGHCOptions)) #ifdef IS_WINDOWS - : ("install -i C:\\\\", Right defaultOptions{Install.isolateDir = Just "C:\\\\"}) + : ("install -i C:\\\\", Right (defaultGHCOptions{Install.isolateDir = Just "C:\\\\"} :: InstallGHCOptions)) #else - : ("install -i /", Right defaultOptions{Install.isolateDir = Just "/"}) + : ("install -i /", Right (defaultGHCOptions{Install.isolateDir = Just "/"} :: InstallGHCOptions)) #endif : ("install -u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz head" - , Right defaultOptions + , Right (defaultGHCOptions { 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) @@ -108,9 +128,9 @@ oldStyleCheckList = ) ] -installGhcCheckList :: [(String, Either InstallCommand InstallOptions)] +installGhcCheckList :: [(String, Either InstallCommand InstallGHCOptions)] installGhcCheckList = - ("install ghc", Left $ InstallGHC defaultOptions) + ("install ghc", Left $ InstallGHC defaultGHCOptions) : mapSecond (Left . InstallGHC . mkInstallOptions) [ ("install ghc 9.2", GHCVersion $ GHCTargetVersion @@ -151,7 +171,7 @@ installGhcCheckList = installCabalCheckList :: [(String, Either InstallCommand InstallOptions)] installCabalCheckList = - ("install cabal", Left $ InstallCabal defaultOptions{instSet = True}) + ("install cabal", Left $ InstallCabal (defaultOptions{instSet = True} :: InstallOptions)) : mapSecond (Left . InstallCabal . mkInstallOptions') [ ("install cabal 3.10", ToolVersion $(versionQ "3.10")) , ("install cabal next", ToolVersion $(versionQ "next")) @@ -197,7 +217,7 @@ installStackCheckList = , ("install stack stack-2.9", ToolVersion $(versionQ "stack-2.9")) ] -installParseWith :: [String] -> IO (Either InstallCommand InstallOptions) +installParseWith :: [String] -> IO (Either InstallCommand InstallGHCOptions) installParseWith args = do Install a <- parseWith args pure a