Improve stack metadata support wrt #892

2023-10-25 00:35:41 +08:00
parent 38cd5ad8ed
commit c7439d3c89
19 changed files with 410 additions and 371 deletions
--- a/lib-opt/GHCup/OptParse.hs
+++ b/lib-opt/GHCup/OptParse.hs
@@ -57,16 +57,13 @@ import           GHCup.Types
 import           Control.Monad.Fail             ( MonadFail )
 #endif
 import           Control.Monad.Reader
-import           Data.Bifunctor
 import           Data.Either
 import           Data.Functor
 import           Data.Maybe
 import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
-import           URI.ByteString

-import qualified Data.ByteString.UTF8          as UTF8


 data Options = Options
@@ -77,18 +74,19 @@ data Options = Options
  , optMetaCache   :: Maybe Integer
  , optMetaMode    :: Maybe MetaMode
  , optPlatform    :: Maybe PlatformRequest
-  , optUrlSource   :: Maybe URI
+  , optUrlSource   :: Maybe URLSource
  , optNoVerify    :: Maybe Bool
  , optKeepDirs    :: Maybe KeepDirs
  , optsDownloader :: Maybe Downloader
  , optNoNetwork   :: Maybe Bool
  , optGpg         :: Maybe GPGSetting
+  , optStackSetup  :: Maybe Bool
  -- commands
  , optCommand     :: Command
  }

 data Command
-  = Install (Either InstallCommand InstallGHCOptions)
+  = Install (Either InstallCommand InstallOptions)
  | Test TestCommand
  | InstallCabalLegacy InstallOptions
  | Set (Either SetCommand SetOptions)
@@ -134,13 +132,13 @@ opts =
      )
    <*> optional
          (option
-            (eitherReader parseUri)
+            (eitherReader parseUrlSource)
            (  short 's'
            <> long "url-source"
-            <> metavar "URL"
-            <> help "Alternative ghcup download info url"
+            <> metavar "URL_SOURCE"
+            <> help "Alternative ghcup download info"
            <> internal
-            <> completer fileUri
+            <> completer urlSourceCompleter
            )
          )
    <*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
@@ -178,10 +176,9 @@ opts =
          "GPG verification (default: none)"
          <> completer (listCompleter ["strict", "lax", "none"])
          ))
+    <*> invertableSwitch "stack-setup" (Just 's') False (help "Use stack's setup info for discovering and installing GHC versions")
    <*> com
- where
-  parseUri s' =
-    first show $ parseURI strictURIParserOptions (UTF8.fromString s')
+


 com :: Parser Command
--- a/lib-opt/GHCup/OptParse/Common.hs
+++ b/lib-opt/GHCup/OptParse/Common.hs
@@ -64,6 +64,8 @@ import           URI.ByteString
 import qualified Data.ByteString.UTF8          as UTF8
 import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
+import qualified Data.Text.Lazy.Encoding       as LE
+import qualified Data.Text.Lazy                as LT
 import qualified Text.Megaparsec               as MP
 import qualified System.FilePath.Posix         as FP
 import GHCup.Version
@@ -322,6 +324,15 @@ toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]
 gitFileUri :: [String] -> Completer
 gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)

+urlSourceCompleter :: Completer
+urlSourceCompleter = mkCompleter $ urlSourceCompleter' []
+
+urlSourceCompleter' :: [String] -> String -> IO [String]
+urlSourceCompleter' add str' = do
+  let static = ["GHCupURL", "StackSetupURL"]
+  file <- fileUri' add str'
+  pure $ static ++ file
+
 fileUri :: Completer
 fileUri = mkCompleter $ fileUri' []

@@ -450,13 +461,15 @@ tagCompleter tool add = listIOCompleter $ do
        defaultKeyBindings
        loggerConfig

-  mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
-  case mGhcUpInfo of
-    VRight ghcupInfo -> do
-      let allTags = filter (/= Old)
-            $ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
-      pure $ nub $ (add ++) $ fmap tagToString allTags
-    VLeft _ -> pure  (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
+  mpFreq <- flip runReaderT appState . runE $ platformRequest
+  forFold mpFreq $ \pfreq -> do
+    mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF pfreq
+    case mGhcUpInfo of
+      VRight ghcupInfo -> do
+        let allTags = filter (/= Old)
+              $ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
+        pure $ nub $ (add ++) $ fmap tagToString allTags
+      VLeft _ -> pure  (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)

 versionCompleter :: [ListCriteria] -> Tool -> Completer
 versionCompleter criteria tool = versionCompleter' criteria tool (const True)
@@ -477,8 +490,8 @@ versionCompleter' criteria tool filter' = listIOCompleter $ do
                   defaultKeyBindings
                   loggerConfig
  mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
-  mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
  forFold mpFreq $ \pfreq -> do
+    mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF pfreq
    forFold mGhcUpInfo $ \ghcupInfo -> do
      let appState = AppState
            settings
@@ -817,3 +830,15 @@ logGHCPostRm ghcVer = do
  let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))
  logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir

+parseUrlSource :: String -> Either String URLSource
+parseUrlSource "GHCupURL" = pure GHCupURL
+parseUrlSource "StackSetupURL" = pure StackSetupURL
+parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')
+            <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')
+
+parseNewUrlSource :: String -> Either String NewURLSource
+parseNewUrlSource "GHCupURL" = pure NewGHCupURL
+parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL
+parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')
+            <|> (fmap NewURI . first show . parseURI strictURIParserOptions .UTF8.fromString $ s')
+
--- a/lib-opt/GHCup/OptParse/Config.hs
+++ b/lib-opt/GHCup/OptParse/Config.hs
@@ -32,7 +32,6 @@ import           Options.Applicative     hiding ( style, ParseError )
 import           Options.Applicative.Help.Pretty ( text )
 import           Prelude                 hiding ( appendFile )
 import           System.Exit
-import           URI.ByteString          hiding ( uriParser )

 import qualified Data.Text                     as T
 import qualified Data.ByteString.UTF8          as UTF8
@@ -51,7 +50,7 @@ data ConfigCommand
  = ShowConfig
  | SetConfig String (Maybe String)
  | InitConfig
-  | AddReleaseChannel Bool URI
+  | AddReleaseChannel Bool NewURLSource
  deriving (Eq, Show)


@@ -75,8 +74,8 @@ configP = subparser
  showP = info (pure ShowConfig) (progDesc "Show current config (default)")
  setP  = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
  argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
-  addP  = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
-    (progDesc "Add a release channel from a URI")
+  addP  = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader parseNewUrlSource) (metavar "URL_SOURCE" <> completer urlSourceCompleter))
+    (progDesc "Add a release channel, e.g. from a URI")



@@ -135,9 +134,7 @@ updateSettings usl usr =
       gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
       platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
       mirrors' = uMirrors usl <|> uMirrors usr
-       stackSetupSource' = uStackSetupSource usl <|> uStackSetupSource usr
-       stackSetup' = uStackSetup usl <|> uStackSetup usr
-   in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' stackSetupSource' stackSetup'
+   in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'
 where
  updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
  updateKeyBindings Nothing Nothing = Nothing
@@ -209,27 +206,15 @@ config configCommand settings userConf keybindings runLogger = case configComman
        pure $ ExitFailure 65
      VLeft _ -> pure $ ExitFailure 65

-  AddReleaseChannel force uri -> do
+  AddReleaseChannel force new -> do
    r <- runE @'[DuplicateReleaseChannel] $ do
-      case urlSource settings of
-        AddSource xs -> do
-          case checkDuplicate xs (Right uri) of
-            Duplicate
-              | not force -> throwE (DuplicateReleaseChannel uri)
-            DuplicateLast -> pure ()
-            _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) })
-        GHCupURL -> do
-          lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
-          pure ()
-        OwnSource xs -> do
-          case checkDuplicate xs (Right uri) of
-            Duplicate
-              | not force -> throwE (DuplicateReleaseChannel uri)
-            DuplicateLast -> pure ()
-            _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) })
-        OwnSpec spec -> do
-          lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] })
-          pure ()
+      let oldSources = fromURLSource (urlSource settings)
+      let merged = oldSources ++ [new]
+      case checkDuplicate oldSources new of
+        Duplicate
+          | not force -> throwE (DuplicateReleaseChannel new)
+        DuplicateLast -> pure ()
+        _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ SimpleList merged })
    case r of
      VRight _ -> do
        pure ExitSuccess
@@ -244,15 +229,6 @@ config configCommand settings userConf keybindings runLogger = case configComman
    | a `elem` xs  = Duplicate
    | otherwise    = NoDuplicate

-  -- appends the element to the end of the list, but also removes it from the existing list
-  appendUnique :: Eq a => [a] -> a -> [a]
-  appendUnique xs' e = go xs'
-   where
-    go [] = [e]
-    go (x:xs)
-      | x == e    =     go xs -- skip
-      | otherwise = x : go xs
-
  doConfig :: MonadIO m => UserSettings -> m ()
  doConfig usersettings = do
    let settings' = updateSettings usersettings userConf
--- a/lib-opt/GHCup/OptParse/Install.hs
+++ b/lib-opt/GHCup/OptParse/Install.hs
@@ -50,7 +50,7 @@ import qualified Data.Text                     as T
    ----------------


-data InstallCommand = InstallGHC InstallGHCOptions
+data InstallCommand = InstallGHC InstallOptions
                    | InstallCabal InstallOptions
                    | InstallHLS InstallOptions
                    | InstallStack InstallOptions
@@ -63,16 +63,6 @@ data InstallCommand = InstallGHC InstallGHCOptions
    --[ Options ]--
    ---------------

-data InstallGHCOptions = InstallGHCOptions
-  { instVer       :: Maybe ToolVersion
-  , instBindist   :: Maybe URI
-  , instSet       :: Bool
-  , isolateDir    :: Maybe FilePath
-  , forceInstall  :: Bool
-  , addConfArgs   :: [T.Text]
-  , useStackSetup :: Maybe Bool
-  } deriving (Eq, Show)
-
 data InstallOptions = InstallOptions
  { instVer      :: Maybe ToolVersion
  , instBindist  :: Maybe URI
@@ -102,14 +92,14 @@ installCabalFooter = [s|Discussion:
    --[ Parsers ]--
    ---------------

-installParser :: Parser (Either InstallCommand InstallGHCOptions)
+installParser :: Parser (Either InstallCommand InstallOptions)
 installParser =
  (Left <$> subparser
      (  command
          "ghc"
          (   InstallGHC
          <$> info
-                (installGHCOpts <**> helper)
+                (installOpts (Just GHC) <**> helper)
                (  progDesc "Install GHC"
                <> footerDoc (Just $ text installGHCFooter)
                )
@@ -143,7 +133,7 @@ installParser =
           )
      )
    )
-    <|> (Right <$> installGHCOpts)
+    <|> (Right <$> installOpts (Just GHC))
 where
  installHLSFooter :: String
  installHLSFooter = [s|Discussion:
@@ -219,12 +209,6 @@ installOpts tool =
    Just GHC -> False
    Just _   -> True

-installGHCOpts :: Parser InstallGHCOptions
-installGHCOpts =
-  (\InstallOptions{..} b -> let useStackSetup = b in InstallGHCOptions{..})
-    <$> installOpts (Just GHC)
-    <*> invertableSwitch "stack-setup" (Just 's') False (help "Set as active version after install")
-



@@ -328,7 +312,7 @@ runInstGHC appstate' =
    -------------------


-install :: Either InstallCommand InstallGHCOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
+install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
 install installCommand settings getAppState' runLogger = case installCommand of
  (Right iGHCopts) -> do
    runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
@@ -338,11 +322,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
  (Left (InstallHLS iopts))    -> installHLS iopts
  (Left (InstallStack iopts))  -> installStack iopts
 where
-  installGHC :: InstallGHCOptions -> IO ExitCode
-  installGHC InstallGHCOptions{..} = do
+  installGHC :: InstallOptions -> IO ExitCode
+  installGHC InstallOptions{..} = do
    s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
    (case instBindist of
-       Nothing -> runInstGHC s'{ settings = maybe settings (\b -> settings {stackSetup = b}) useStackSetup }  $ do
+       Nothing -> runInstGHC s' $ do
         (v, vi) <- liftE $ fromVersion instVer GHC
         liftE $ runBothE' (installGHCBin
                     v
--- a/lib-opt/GHCup/OptParse/Prefetch.hs
+++ b/lib-opt/GHCup/OptParse/Prefetch.hs
@@ -14,6 +14,7 @@ module GHCup.OptParse.Prefetch where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
+import           GHCup.Types.Optics
 import           GHCup.Prelude.File
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.String.QQ
@@ -157,7 +158,9 @@ type PrefetchEffects = '[ TagNotFound
                        , GPGError
                        , DownloadFailed
                        , JSONError
-                        , FileDoesNotExistError ]
+                        , FileDoesNotExistError
+                        , StackPlatformDetectError
+                        ]


 runPrefetch :: MonadUnliftIO m
@@ -210,7 +213,8 @@ prefetch prefetchCommand runAppState runLogger =
        (v, _) <- liftE $ fromVersion mt Stack
        liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
      PrefetchMetadata -> do
-        _ <- liftE getDownloadsF
+        pfreq <- lift getPlatformReq
+        _ <- liftE $ getDownloadsF pfreq
        pure ""
       ) >>= \case
                VRight _ -> do