Change optUrlSource to use NewURLSource, this allows use of ChannelAlias

While still maintaining backward compatibility with URLSource
haskell · Dec 27, 2024 · 13def98 · 13def98
1 parent 930da8d
commit 13def98
Show file tree

Hide file tree

Showing 6 changed files with 15 additions and 13 deletions.
diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs
@@ -89,7 +89,7 @@ toSettings noColor pagerCmd options = do
          keepDirs    = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
          downloader  = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
          keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
-         urlSource   = fromMaybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) optUrlSource
+         urlSource   = fromMaybe (maybe (Types.urlSource defaultSettings) fromURLSource uUrlSource) optUrlSource
          noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
          gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
          platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)

diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs
@@ -81,7 +81,7 @@ data Options = Options
   , optMetaCache   :: Maybe Integer
   , optMetaMode    :: Maybe MetaMode
   , optPlatform    :: Maybe PlatformRequest
-  , optUrlSource   :: Maybe URLSource
+  , optUrlSource   :: Maybe [NewURLSource]
   , optNoVerify    :: Maybe Bool
   , optKeepDirs    :: Maybe KeepDirs
   , optsDownloader :: Maybe Downloader

diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs
@@ -226,7 +226,7 @@ config configCommand settings userConf keybindings runLogger = case configComman
 
   AddReleaseChannel force new -> do
     r <- runE @'[DuplicateReleaseChannel] $ do
-      let oldSources = fromURLSource (urlSource settings)
+      let oldSources = urlSource settings
       let merged = oldSources ++ [new]
       case checkDuplicate (aliasToURI <$> oldSources) (aliasToURI new) of
         Duplicate

diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs
@@ -124,8 +124,7 @@ getDownloadsF :: ( FromJSONKey Tool
                    GHCupInfo
 getDownloadsF pfreq@(PlatformRequest arch plat _) = do
   Settings { urlSource } <- lift getSettings
-  let newUrlSources = fromURLSource urlSource
-  infos <- liftE $ mapM dl' newUrlSources
+  infos <- liftE $ mapM dl' urlSource
   keys <- if any isRight infos
           then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
           else pure []

diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs
@@ -466,7 +466,7 @@ fromSettings Settings{..} Nothing =
     , uDownloader = Just downloader
     , uNoNetwork = Just noNetwork
     , uKeyBindings = Nothing
-    , uUrlSource = Just urlSource
+    , uUrlSource = Just (SimpleList urlSource)
     , uGPGSetting = Just gpgSetting
     , uPlatformOverride = platformOverride
     , uMirrors = Just mirrors
@@ -494,7 +494,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
     , uDownloader = Just downloader
     , uNoNetwork = Just noNetwork
     , uKeyBindings = Just ukb
-    , uUrlSource = Just urlSource
+    , uUrlSource = Just (SimpleList urlSource)
     , uGPGSetting = Just gpgSetting
     , uPlatformOverride = platformOverride
     , uMirrors = Just mirrors
@@ -579,7 +579,7 @@ data Settings = Settings
   , keepDirs          :: KeepDirs
   , downloader        :: Downloader
   , verbose           :: Bool
-  , urlSource         :: URLSource
+  , urlSource         :: [NewURLSource]
   , noNetwork         :: Bool
   , gpgSetting        :: GPGSetting
   , noColor           :: Bool -- this also exists in LoggerConfig
@@ -608,7 +608,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) [] defaultPagerConfig
+defaultSettings = Settings False defaultMetaCache Lax False Never Curl False [NewGHCupURL] False GPGNone False Nothing (DM mempty) [] defaultPagerConfig
 
 instance NFData Settings
 

diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs
@@ -381,10 +381,13 @@ fromVersion' (SetToolTag t') tool =
   throwE $ TagNotFound t' tool
 
 
-parseUrlSource :: String -> Either String URLSource
-parseUrlSource "GHCupURL" = pure GHCupURL
-parseUrlSource "StackSetupURL" = pure StackSetupURL
-parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s')
+parseUrlSource :: String -> Either String [NewURLSource]
+parseUrlSource s = (fromURLSource <$> parseUrlSource' s) <|> ((:[]) <$> parseNewUrlSource s)
+
+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 .UTF8.fromString $ s')
 
 parseNewUrlSource :: String -> Either String NewURLSource