ghcup-hs/app/ghcup/GHCup/OptParse/Config.hs

188 lines
5.3 KiB
Haskell
Raw Normal View History

2021-10-15 20:24:23 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Config where
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Prelude
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2021-10-21 21:17:26 +00:00
import Control.Exception ( displayException )
2021-10-15 20:24:23 +00:00
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
2021-10-19 18:38:53 +00:00
import Options.Applicative.Help.Pretty ( text )
2021-10-15 20:24:23 +00:00
import Prelude hiding ( appendFile )
import System.Exit
import qualified Data.Text as T
import qualified Data.ByteString.UTF8 as UTF8
2021-10-21 21:17:26 +00:00
import qualified Data.Yaml.Aeson as Y
2021-10-15 20:24:23 +00:00
import Control.Exception.Safe (MonadMask)
----------------
--[ Commands ]--
----------------
data ConfigCommand
= ShowConfig
2021-10-19 18:38:53 +00:00
| SetConfig String (Maybe String)
2021-10-15 20:24:23 +00:00
| InitConfig
---------------
--[ Parsers ]--
---------------
configP :: Parser ConfigCommand
configP = subparser
( command "init" initP
<> command "set" setP -- [set] KEY VALUE at help lhs
<> command "show" showP
)
<|> argsP -- add show for a single option
<|> pure ShowConfig
where
initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
showP = info (pure ShowConfig) (progDesc "Show current config (default)")
2021-10-19 18:38:53 +00:00
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"))
2021-10-15 20:24:23 +00:00
--------------
--[ Footer ]--
--------------
configFooter :: String
configFooter = [s|Examples:
# show current config
ghcup config
# initialize config
ghcup config init
# set <key> <value> configuration pair
2021-10-19 18:38:53 +00:00
ghcup config set <key> <value>|]
configSetFooter :: String
configSetFooter = [s|Examples:
# disable caching
ghcup config set cache false
# switch downloader to wget
ghcup config set downloader Wget
# set mirror for ghcup metadata
ghcup config set '{url-source: { OwnSource: "<url>"}}'|]
2021-10-15 20:24:23 +00:00
-----------------
--[ Utilities ]--
-----------------
formatConfig :: UserSettings -> String
2021-10-21 21:17:26 +00:00
formatConfig = UTF8.toString . Y.encode
2021-10-15 20:24:23 +00:00
updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
updateSettings config' settings = do
2021-10-21 21:17:26 +00:00
settings' <- lE' (JSONDecodeError . displayException) . Y.decodeEither' $ config'
2021-10-15 20:24:23 +00:00
pure $ mergeConf settings' settings
where
mergeConf :: UserSettings -> Settings -> Settings
mergeConf UserSettings{..} Settings{..} =
let cache' = fromMaybe cache uCache
metaCache' = fromMaybe metaCache uMetaCache
2021-10-15 20:24:23 +00:00
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
2021-10-15 20:24:23 +00:00
------------------
--[ Entrypoint ]--
------------------
config :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> ConfigCommand
-> Settings
-> KeyBindings
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
config configCommand settings keybindings runLogger = case configCommand of
InitConfig -> do
path <- getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path
pure ExitSuccess
ShowConfig -> do
liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
pure ExitSuccess
2021-10-19 18:38:53 +00:00
(SetConfig k (Just v)) ->
2021-10-15 20:24:23 +00:00
case v of
"" -> do
runLogger $ logError "Empty values are not allowed"
pure $ ExitFailure 55
2021-10-19 18:38:53 +00:00
_ -> doConfig (k <> ": " <> v <> "\n")
(SetConfig json Nothing) -> doConfig json
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 ()
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