hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

Browse Source
This commit is contained in:
Julian Ospald 2022-03-10 20:26:51 +01:00
parent fdcd6822c4
commit 8eeb32c495
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
6 changed files with 118 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
app/ghcup/GHCup/OptParse/Config.hs
View File

@ -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,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

2
app/ghcup/Main.hs
View File

@ -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)

14
data/config.yaml
View File

@ -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"

35
lib/GHCup/Download.hs
View File

@ -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

4
lib/GHCup/Types.hs
View File

@ -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

34
lib/GHCup/Types/JSON.hs
View File

@ -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