diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index 13014ef..c8072ab 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/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 "") <*> 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,23 +121,18 @@ formatConfig :: UserSettings -> String formatConfig = UTF8.toString . Y.encode -updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings -updateSettings config' settings = do - 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 - keepDirs' = fromMaybe keepDirs uKeepDirs - downloader' = fromMaybe downloader uDownloader - verbose' = fromMaybe verbose uVerbose - urlSource' = fromMaybe urlSource uUrlSource - noNetwork' = fromMaybe noNetwork uNoNetwork - gpgSetting' = fromMaybe gpgSetting uGPGSetting - in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor +updateSettings :: UserSettings -> Settings -> Settings +updateSettings UserSettings{..} Settings{..} = + let cache' = fromMaybe cache uCache + metaCache' = fromMaybe metaCache uMetaCache + noVerify' = fromMaybe noVerify uNoVerify + keepDirs' = fromMaybe keepDirs uKeepDirs + downloader' = fromMaybe downloader uDownloader + verbose' = fromMaybe verbose uVerbose + urlSource' = fromMaybe urlSource uUrlSource + noNetwork' = fromMaybe noNetwork uNoNetwork + gpgSetting' = fromMaybe gpgSetting uGPGSetting + in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor @@ -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)) -> - case v of - "" -> do - runLogger $ logError "Empty values are not allowed" - pure $ ExitFailure 55 - _ -> doConfig (k <> ": " <> v <> "\n") + (SetConfig k mv) -> do + r <- runE @'[JSONError, ParseError] $ do + case mv of + Just "" -> + throwE $ ParseError "Empty values are not allowed" + Nothing -> do + usersettings <- decodeSettings k + lift $ doConfig usersettings + pure () + Just v -> do + usersettings <- decodeSettings (k <> ": " <> v <> "\n") + lift $ doConfig usersettings + 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 - (SetConfig json Nothing) -> doConfig json + 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 val = do - r <- runE @'[JSONError] $ do - 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 () + 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 () - 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 + decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 7b31c40..b4748ee 100644 --- a/app/ghcup/Main.hs +++ b/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) diff --git a/data/config.yaml b/data/config.yaml index 3cca0ec..2bccf63 100644 --- a/data/config.yaml +++ b/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" diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index acb6e4d..8327c76 100644 --- a/lib/GHCup/Download.hs +++ b/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) - (AddSource (Right uri)) -> do - base <- liftE $ getBase ghcupURL - ext <- liftE $ getBase uri - pure (mergeGhcupInfo base ext) + ext <- liftE $ mapM (either pure getBase) exts + mergeGhcupInfo (base:ext) - where - - mergeGhcupInfo :: GHCupInfo -- ^ base to merge with - -> GHCupInfo -- ^ extension overwriting the base - -> GHCupInfo - mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) = - let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of - Just a' -> M.union a' a - Nothing -> a - ) base - newGlobalTools = M.union base2 ext2 - in GHCupInfo tr newDownloads newGlobalTools + where + mergeGhcupInfo :: MonadFail m + => [GHCupInfo] + -> m GHCupInfo + mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo" + mergeGhcupInfo xs@(GHCupInfo{}: _) = + let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs) + newGlobalTools = M.unionsWith (\_ a2 -> a2 ) (_globalTools <$> xs) + newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs) + in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 5633f78..cab0858 100644 --- a/lib/GHCup/Types.hs +++ b/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 diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 8aafad9..8d7cd3b 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/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