262 lines
8.6 KiB
Haskell
262 lines
8.6 KiB
Haskell
{-# 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.Prelude
|
|
import GHCup.Prelude.Logger
|
|
import GHCup.Prelude.String.QQ
|
|
import GHCup.OptParse.Common
|
|
|
|
#if !MIN_VERSION_base(4,13,0)
|
|
import Control.Monad.Fail ( MonadFail )
|
|
#endif
|
|
import Control.Exception ( displayException )
|
|
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, 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
|
|
import qualified Data.Yaml.Aeson as Y
|
|
import Control.Exception.Safe (MonadMask)
|
|
|
|
|
|
|
|
|
|
----------------
|
|
--[ Commands ]--
|
|
----------------
|
|
|
|
|
|
data ConfigCommand
|
|
= ShowConfig
|
|
| SetConfig String (Maybe String)
|
|
| InitConfig
|
|
| AddReleaseChannel Bool URI
|
|
|
|
|
|
|
|
---------------
|
|
--[ Parsers ]--
|
|
---------------
|
|
|
|
|
|
configP :: Parser ConfigCommand
|
|
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
|
|
where
|
|
initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
|
|
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 <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
|
|
(progDesc "Add a release channel from a URI")
|
|
|
|
|
|
|
|
|
|
--------------
|
|
--[ Footer ]--
|
|
--------------
|
|
|
|
|
|
configFooter :: String
|
|
configFooter = [s|Examples:
|
|
|
|
# show current config
|
|
ghcup config
|
|
|
|
# initialize config
|
|
ghcup config init
|
|
|
|
# set <key> <value> configuration pair
|
|
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>"}}'|]
|
|
|
|
|
|
|
|
-----------------
|
|
--[ Utilities ]--
|
|
-----------------
|
|
|
|
|
|
formatConfig :: UserSettings -> String
|
|
formatConfig = UTF8.toString . Y.encode
|
|
|
|
|
|
updateSettings :: UserSettings -> UserSettings -> UserSettings
|
|
updateSettings usl usr =
|
|
let cache' = uCache usl <|> uCache usr
|
|
metaCache' = uMetaCache usl <|> uMetaCache usr
|
|
metaMode' = uMetaMode usl <|> uMetaMode usr
|
|
noVerify' = uNoVerify usl <|> uNoVerify usr
|
|
verbose' = uVerbose usl <|> uVerbose usr
|
|
keepDirs' = uKeepDirs usl <|> uKeepDirs usr
|
|
downloader' = uDownloader usl <|> uDownloader usr
|
|
urlSource' = uUrlSource usl <|> uUrlSource usr
|
|
noNetwork' = uNoNetwork usl <|> uNoNetwork usr
|
|
gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
|
|
platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
|
|
mirrors' = uMirrors usl <|> uMirrors usr
|
|
in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'
|
|
where
|
|
updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
|
|
updateKeyBindings Nothing Nothing = Nothing
|
|
updateKeyBindings (Just kbl) Nothing = Just kbl
|
|
updateKeyBindings Nothing (Just kbr) = Just kbr
|
|
updateKeyBindings (Just kbl) (Just kbr) =
|
|
Just $ UserKeyBindings {
|
|
kUp = kUp kbl <|> kUp kbr
|
|
, kDown = kDown kbl <|> kDown kbr
|
|
, kQuit = kQuit kbl <|> kQuit kbr
|
|
, kInstall = kInstall kbl <|> kInstall kbr
|
|
, kUninstall = kUninstall kbl <|> kUninstall kbr
|
|
, kSet = kSet kbl <|> kSet kbr
|
|
, kChangelog = kChangelog kbl <|> kChangelog kbr
|
|
, kShowAll = kShowAll kbl <|> kShowAll kbr
|
|
, kShowAllTools = kShowAllTools kbl <|> kShowAllTools kbr
|
|
}
|
|
|
|
|
|
|
|
------------------
|
|
--[ Entrypoint ]--
|
|
------------------
|
|
|
|
data Duplicate = Duplicate -- ^ there is a duplicate somewhere in the middle
|
|
| NoDuplicate -- ^ there is no duplicate
|
|
| DuplicateLast -- ^ there's a duplicate, but it's the last element
|
|
|
|
|
|
config :: forall m. ( Monad m
|
|
, MonadMask m
|
|
, MonadUnliftIO m
|
|
, MonadFail m
|
|
)
|
|
=> ConfigCommand
|
|
-> Settings
|
|
-> UserSettings
|
|
-> KeyBindings
|
|
-> (ReaderT LeanAppState m () -> m ())
|
|
-> m ExitCode
|
|
config configCommand settings userConf 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
|
|
|
|
(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
|
|
|
|
AddReleaseChannel force uri -> do
|
|
r <- runE @'[DuplicateReleaseChannel] $ do
|
|
case urlSource settings of
|
|
AddSource xs -> do
|
|
case checkDuplicate xs (Right uri) of
|
|
Duplicate
|
|
| not force -> throwE (DuplicateReleaseChannel uri)
|
|
DuplicateLast -> pure ()
|
|
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) })
|
|
GHCupURL -> do
|
|
lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
|
|
pure ()
|
|
OwnSource xs -> do
|
|
case checkDuplicate xs (Right uri) of
|
|
Duplicate
|
|
| not force -> throwE (DuplicateReleaseChannel uri)
|
|
DuplicateLast -> pure ()
|
|
_ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) })
|
|
OwnSpec spec -> do
|
|
lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] })
|
|
pure ()
|
|
case r of
|
|
VRight _ -> do
|
|
pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyHFError e
|
|
pure $ ExitFailure 15
|
|
|
|
where
|
|
checkDuplicate :: Eq a => [a] -> a -> Duplicate
|
|
checkDuplicate xs a
|
|
| last xs == a = DuplicateLast
|
|
| a `elem` xs = Duplicate
|
|
| otherwise = NoDuplicate
|
|
|
|
-- appends the element to the end of the list, but also removes it from the existing list
|
|
appendUnique :: Eq a => [a] -> a -> [a]
|
|
appendUnique xs' e = go xs'
|
|
where
|
|
go [] = [e]
|
|
go (x:xs)
|
|
| x == e = go xs -- skip
|
|
| otherwise = x : go xs
|
|
|
|
doConfig :: MonadIO m => UserSettings -> m ()
|
|
doConfig usersettings = do
|
|
let settings' = updateSettings usersettings userConf
|
|
path <- liftIO getConfigFilePath
|
|
liftIO $ writeFile path $ formatConfig $ settings'
|
|
runLogger $ logDebug $ T.pack $ show settings'
|
|
pure ()
|
|
|
|
decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString
|