Overhaul metadata merging and add 'ghcup config add-release-channel URI'

app/ghcup/GHCup/OptParse/Config.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ExplicitForAll #-}
 
 module GHCup.OptParse.Config where
 
@@ -17,6 +18,7 @@ import           GHCup.Utils
 import           GHCup.Utils.Prelude
 import           GHCup.Utils.Logger
 import           GHCup.Utils.String.QQ
+import           GHCup.OptParse.Common
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -27,10 +29,11 @@ import           Control.Monad.Trans.Resource
 import           Data.Functor
 import           Data.Maybe
 import           Haskus.Utils.Variant.Excepts
-import           Options.Applicative     hiding ( style )
+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
@@ -49,6 +52,7 @@ data ConfigCommand
   = ShowConfig
   | SetConfig String (Maybe String)
   | InitConfig
+  | AddReleaseChannel URI
 
 
 
@@ -62,6 +66,7 @@ configP = subparser
       (  command "init" initP
       <> command "set"  setP -- [set] KEY VALUE at help lhs
       <> command "show" showP
+      <> command "add-release-channel" addP
       )
     <|> argsP -- add show for a single option
     <|> pure ShowConfig
@@ -70,6 +75,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 <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
+    (progDesc "Add a release channel from a URI")
 
 
 
@@ -114,13 +121,8 @@ formatConfig :: UserSettings -> String
 formatConfig = UTF8.toString . Y.encode
 
 
-updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
+updateSettings :: UserSettings -> Settings -> Settings
-updateSettings config' settings = do
+updateSettings UserSettings{..} Settings{..} =
-  settings' <- lE' (JSONDecodeError . displayException) . Y.decodeEither' $ config'
-  pure $ mergeConf settings' settings
-  where
-   mergeConf :: UserSettings -> Settings -> Settings
-   mergeConf UserSettings{..} Settings{..} =
    let cache'      = fromMaybe cache uCache
        metaCache'  = fromMaybe metaCache uMetaCache
        noVerify'   = fromMaybe noVerify uNoVerify
@@ -140,7 +142,7 @@ updateSettings config' settings = do
 
 
 
-config :: ( Monad m
+config :: forall m. ( Monad m
           , MonadMask m
           , MonadUnliftIO m
           , MonadFail m
@@ -161,27 +163,42 @@ config configCommand settings keybindings runLogger = case configCommand of
     liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
     pure ExitSuccess
 
-  (SetConfig k (Just v)) ->
+  (SetConfig k mv) -> do
-    case v of
+    r <- runE @'[JSONError, ParseError] $ do
-      "" -> do
+      case mv of
-        runLogger $ logError "Empty values are not allowed"
+        Just "" ->
-        pure $ ExitFailure 55
+          throwE $ ParseError "Empty values are not allowed"
-      _  -> doConfig (k <> ": " <> v <> "\n")
+        Nothing -> do
-
+          usersettings <- decodeSettings k
-  (SetConfig json Nothing) -> doConfig json
+          lift $ doConfig usersettings
-
+          pure ()
- where
+        Just v -> do
-  doConfig val = do
+          usersettings <- decodeSettings (k <> ": " <> v <> "\n")
-    r <- runE @'[JSONError] $ do
+          lift $ doConfig usersettings
-      settings' <- updateSettings (UTF8.fromString val) settings
-      path <- liftIO getConfigFilePath
-      liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
-      lift $ runLogger $ logDebug $ T.pack $ show settings'
           pure ()
-
     case r of
       VRight _ -> pure ExitSuccess
       VLeft (V (JSONDecodeError e)) -> do
         runLogger $ logError $ "Error decoding config: " <> T.pack e
         pure $ ExitFailure 65
       VLeft _ -> pure $ ExitFailure 65
+
+  AddReleaseChannel uri -> do
+    case urlSource settings of
+      AddSource xs -> do
+        doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })
+        pure ExitSuccess
+      _ -> do
+        doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
+        pure ExitSuccess
+
+ where
+  doConfig :: MonadIO m => UserSettings -> m ()
+  doConfig usersettings = do
+    let settings' = updateSettings usersettings settings
+    path <- liftIO getConfigFilePath
+    liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
+    runLogger $ logDebug $ T.pack $ show settings'
+    pure ()
+
+  decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString

app/ghcup/Main.hs

@@ -82,7 +82,7 @@ toSettings options = do
          keepDirs    = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
          downloader  = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
          keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
-         urlSource   = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) OwnSource optUrlSource
+         urlSource   = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
          noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
          gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
      in (Settings {..}, keyBindings)

data/config.yaml

@@ -48,12 +48,16 @@ url-source:
 
   ## Example 1: Read download info from this location instead
   ## Accepts file/http/https scheme
+  ## Can also be an array of URLs or an array of 'Either GHCupInfo URL', in
+  ## which case they are merged right-biased (overwriting duplicate versions).
   # OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
 
-  ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions
+  ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions.
+  ## Can also be an array of 'Either GHCupInfo URL', also see Example 3.
   # AddSource:
     # Left:
-      # toolRequirements: {} # this is ignored
+      # globalTools: {}
+      # toolRequirements: {}
       # ghcupDownloads:
         # GHC:
           # 9.10.2:
@@ -66,6 +70,8 @@ url-source:
                     # dlSubdir: ghc-7.10.3
                     # dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
 
-  ## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions
+  ## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate
+  ## versions).
   # AddSource:
-    # Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
+    # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
+    # - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"

lib/GHCup/Download.hs

@@ -121,28 +121,25 @@ getDownloadsF = do
   Settings { urlSource } <- lift getSettings
   case urlSource of
     GHCupURL -> liftE $ getBase ghcupURL
-    (OwnSource url) -> liftE $ getBase url
+    (OwnSource exts) -> do
+      ext  <- liftE $ mapM (either pure getBase) exts
+      mergeGhcupInfo ext
     (OwnSpec av) -> pure av
-    (AddSource (Left ext)) -> do
+    (AddSource exts) -> do
       base <- liftE $ getBase ghcupURL
-      pure (mergeGhcupInfo base ext)
+      ext  <- liftE $ mapM (either pure getBase) exts
-    (AddSource (Right uri)) -> do
+      mergeGhcupInfo (base:ext)
-      base <- liftE $ getBase ghcupURL
-      ext  <- liftE $ getBase uri
-      pure (mergeGhcupInfo base ext)
 
  where
-
+  mergeGhcupInfo :: MonadFail m
-  mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
+                 => [GHCupInfo]
-                 -> GHCupInfo -- ^ extension overwriting the base
+                 -> m GHCupInfo
-                 -> GHCupInfo
+  mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
-  mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
+  mergeGhcupInfo xs@(GHCupInfo{}: _) =
-    let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
+    let newDownloads   = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads   <$> xs)
-                                        Just a' -> M.union a' a
+        newGlobalTools = M.unionsWith (\_ a2 -> a2              ) (_globalTools      <$> xs)
-                                        Nothing -> a
+        newToolReqs    = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
-                                    ) base
+    in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
-        newGlobalTools = M.union base2 ext2
-    in GHCupInfo tr newDownloads newGlobalTools
 
 
 yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath

lib/GHCup/Types.hs

@@ -286,9 +286,9 @@ instance Pretty TarDir where
 
 -- | Where to fetch GHCupDownloads from.
 data URLSource = GHCupURL
-               | OwnSource URI
+               | OwnSource [Either GHCupInfo URI] -- ^ complete source list
                | OwnSpec GHCupInfo
-               | AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
+               | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
                deriving (GHC.Generic, Show)
 
 instance NFData URLSource

lib/GHCup/Types/JSON.hs

@@ -79,6 +79,38 @@ instance FromJSON Tag where
 instance ToJSON URI where
   toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef'
 
+instance FromJSON URLSource where
+  parseJSON v =
+        parseGHCupURL v
+    <|> parseOwnSourceLegacy v
+    <|> parseOwnSourceNew1 v
+    <|> parseOwnSourceNew2 v
+    <|> parseOwnSpec v
+    <|> legacyParseAddSource v
+    <|> newParseAddSource v
+   where
+    parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
+      r :: URI <- o .: "OwnSource"
+      pure (OwnSource [Right r])
+    parseOwnSourceNew1 = withObject "URLSource" $ \o -> do
+      r :: [URI] <- o .: "OwnSource"
+      pure (OwnSource (fmap Right r))
+    parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
+      r :: [Either GHCupInfo URI] <- o .: "OwnSource"
+      pure (OwnSource r)
+    parseOwnSpec = withObject "URLSource" $ \o -> do
+      r :: GHCupInfo <- o .: "OwnSpec"
+      pure (OwnSpec r)
+    parseGHCupURL = withObject "URLSource" $ \o -> do
+      _ :: [Value] <- o .: "GHCupURL"
+      pure GHCupURL
+    legacyParseAddSource = withObject "URLSource" $ \o -> do
+      r :: Either GHCupInfo URI <- o .: "AddSource"
+      pure (AddSource [r])
+    newParseAddSource = withObject "URLSource" $ \o -> do
+      r :: [Either GHCupInfo URI] <- o .: "AddSource"
+      pure (AddSource r)
+
 instance FromJSON URI where
   parseJSON = withText "URL" $ \t ->
     case parseURI strictURIParserOptions (encodeUtf8 t) of
@@ -314,7 +346,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
-deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
+deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
 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 = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings