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

Allow to configure ghcup with a yaml config file

Browse Source 
Fixes #41
This commit is contained in:
Julian Ospald 2020-10-24 22:03:00 +02:00
parent 241dadbeb5
commit 4fef93b7b1
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
9 changed files with 294 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CHANGELOG.md
View File

@ -7,6 +7,7 @@
- reverse list order so latest is on top
- expand the blues selected bar
- show new latest versions in bright white
* allow configuration file and settings TUI hotkeys wrt #41
## 0.1.11 -- 2020-09-23

42
README.md
View File

@ -13,6 +13,7 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
* [Manual install](#manual-install)
* [Vim integration](#vim-integration)
* [Usage](#usage)
* [Configuration](#configuration)
* [Manpages](#manpages)
* [Shell-completion](#shell-completion)
* [Cross support](#cross-support)
@ -80,6 +81,47 @@ ghcup upgrade
Generally this is meant to be used with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
handles your haskell packages and can demand that [a specific version](https://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-flag---with-compiler) of `ghc` is available, which `ghcup` can do.
### Configuration
A configuration file can be put in `~/.ghcup/config.yaml`. Here is the complete default
configuration:
```yaml
# Cache downloads in ~/.ghcup/cache
cache: False
# Skip tarball checksum verification
no-verify: False
# enable verbosity
verbose: False
# When to keep build directories
keep-dirs: Errors # Always | Never | Errors
# Which downloader to use
downloader: Curl # Curl | Wget | Internal
# TUI key bindings,
# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
# for possible values.
key-bindings:
up:
KUp: []
down:
KDown: []
quit:
KChar: 'q'
install:
KChar: 'i'
uninstall:
KChar: 'u'
set:
KChar: 's'
changelog:
KChar: 'c'
show-all:
KChar: 'a'
```
Partial configuration is fine. Command line options always overwrite the config file settings.
### Manpages
For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc.

2
app/ghcup-gen/Validate.hs
View File

@ -193,7 +193,7 @@ validateTarballs dls = do
where
downloadAll dli = do
dirs <- liftIO getDirs
let settings = AppState (Settings True False Never Curl False) dirs
let settings = AppState (Settings True False Never Curl False) dirs defaultKeyBindings
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())

73
app/ghcup/BrickMain.hs
View File

@ -36,7 +36,6 @@ import Data.Bool
import Data.Functor
import Data.List
import Data.Maybe
import Data.Char
import Data.IORef
import Data.String.Interpolate
import Data.Vector ( Vector
@ -77,33 +76,44 @@ data BrickState = BrickState
{ appData :: BrickData
, appSettings :: BrickSettings
, appState :: BrickInternalState
, appKeys :: KeyBindings
}
deriving Show
keyHandlers :: [ ( Char
keyHandlers :: KeyBindings
-> [ ( Vty.Key
, BrickSettings -> String
, BrickState -> EventM n (Next BrickState)
)
]
keyHandlers =
[ ('q', const "Quit" , halt)
, ('i', const "Install" , withIOAction install')
, ('u', const "Uninstall", withIOAction del')
, ('s', const "Set" , withIOAction set')
, ('c', const "ChangeLog", withIOAction changelog')
, ( 'a'
keyHandlers KeyBindings {..} =
[ (bQuit, const "Quit" , halt)
, (bInstall, const "Install" , withIOAction install')
, (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction set')
, (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAll
, (\BrickSettings {..} ->
if showAll then "Hide old versions" else "Show all versions"
)
, hideShowHandler
)
, (bUp, const "Up", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Up), .. }))
, (bDown, const "Down", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Down), .. }))
]
where
hideShowHandler (BrickState {..}) =
let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
newInternalState = constructList appData newAppSettings (Just appState)
in continue (BrickState appData newAppSettings newInternalState)
in continue (BrickState appData newAppSettings newInternalState appKeys)
showKey :: Vty.Key -> String
showKey (Vty.KChar c) = [c]
showKey (Vty.KUp) = "↑"
showKey (Vty.KDown) = "↓"
showKey key = tail (show key)
ui :: BrickState -> Widget String
@ -122,8 +132,7 @@ ui BrickState { appSettings = as@(BrickSettings {}), ..}
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s as)) keyHandlers)
$ (fmap (\(key, s, _) -> (showKey key <> ":" <> s as)) $ keyHandlers appKeys)
header =
(minHSize 2 $ emptyWidget)
<+> (padLeft (Pad 2) $ minHSize 6 $ str "Tool")
@ -261,24 +270,30 @@ dimAttributes = attrMap
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
]
eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState)
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
eventHandler BrickState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
continue (BrickState { appState = (moveCursor appState Up), .. })
eventHandler BrickState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
continue (BrickState { appState = (moveCursor appState Down), .. })
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as
Just (_, _, handler) -> handler as
eventHandler st _ = continue st
eventHandler st@(BrickState {..}) ev = do
AppState { keyBindings = kb } <- liftIO $ readIORef settings'
case ev of
(MouseDown _ Vty.BScrollUp _ _) ->
continue (BrickState { appState = moveCursor 1 appState Up, .. })
(MouseDown _ Vty.BScrollDown _ _) ->
continue (BrickState { appState = moveCursor 1 appState Down, .. })
(VtyEvent (Vty.EvResize _ _)) -> continue st
(VtyEvent (Vty.EvKey Vty.KUp _)) ->
continue (BrickState { appState = (moveCursor 1 appState Up), .. })
(VtyEvent (Vty.EvKey Vty.KDown _)) ->
continue (BrickState { appState = (moveCursor 1 appState Down), .. })
(VtyEvent (Vty.EvKey key _)) ->
case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
Nothing -> continue st
Just (_, _, handler) -> handler st
_ -> continue st
moveCursor :: BrickInternalState -> Direction -> BrickInternalState
moveCursor ais@(BrickInternalState {..}) direction =
let newIx = if direction == Down then ix + 1 else ix - 1
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
moveCursor steps ais@(BrickInternalState {..}) direction =
let newIx = if direction == Down then ix + steps else ix - steps
in case clr !? newIx of
Just _ -> BrickInternalState { ix = newIx, .. }
Nothing -> ais
@ -312,6 +327,7 @@ updateList appD (BrickState {..}) =
in BrickState { appState = newInternalState
, appData = appD
, appSettings = appSettings
, appKeys = appKeys
}
@ -481,6 +497,7 @@ settings' = unsafePerformIO $ do
, ..
})
dirs
defaultKeyBindings
@ -515,6 +532,8 @@ brickMain s muri l av pfreq' = do
(BrickState ad
defaultAppSettings
(constructList ad defaultAppSettings Nothing)
(keyBindings s)
)
$> ()
Left e -> do

115
app/ghcup/Main.hs
View File

@ -81,12 +81,12 @@ import qualified Text.Megaparsec.Char as MPC
data Options = Options
{
-- global options
optVerbose :: Bool
, optCache :: Bool
optVerbose :: Maybe Bool
, optCache :: Maybe Bool
, optUrlSource :: Maybe URI
, optNoVerify :: Bool
, optKeepDirs :: KeepDirs
, optsDownloader :: Downloader
, optNoVerify :: Maybe Bool
, optKeepDirs :: Maybe KeepDirs
, optsDownloader :: Maybe Downloader
-- commands
, optCommand :: Command
}
@ -180,13 +180,48 @@ data ChangeLogOptions = ChangeLogOptions
}
-- https://github.com/pcapriotti/optparse-applicative/issues/148
-- | A switch that can be enabled using --foo and disabled using --no-foo.
--
-- The option modifier is applied to only the option that is *not* enabled
-- by default. For example:
--
-- > invertableSwitch "recursive" True (help "do not recurse into directories")
--
-- This example makes --recursive enabled by default, so
-- the help is shown only for --no-recursive.
invertableSwitch
:: String -- ^ long option
-> Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
-> Mod FlagFields Bool -- ^ option modifier
-> Parser (Maybe Bool)
invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shortopt defv
(if defv then mempty else optmod)
(if defv then optmod else mempty)
-- | Allows providing option modifiers for both --foo and --no-foo.
invertableSwitch'
:: String -- ^ long option (eg "foo")
-> Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
-> Mod FlagFields Bool -- ^ option modifier for --foo
-> Mod FlagFields Bool -- ^ option modifier for --no-foo
-> Parser (Maybe Bool)
invertableSwitch' longopt shortopt defv enmod dismod = optional
( flag' True (enmod <> long longopt <> if defv then mempty else short shortopt)
<|> flag' False (dismod <> long nolongopt <> if defv then short shortopt else mempty)
)
where
nolongopt = "no-" ++ longopt
opts :: Parser Options
opts =
Options
<$> switch (short 'v' <> long "verbose" <> help "Enable verbosity")
<*> switch
(short 'c' <> long "cache" <> help "Cache downloads in ~/.ghcup/cache"
)
<$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
<*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
<*> (optional
(option
(eitherReader parseUri)
@ -198,35 +233,29 @@ opts =
)
)
)
<*> switch
(short 'n' <> long "no-verify" <> help
"Skip tarball checksum verification"
)
<*> option
<*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
<*> optional (option
(eitherReader keepOnParser)
( long "keep"
<> metavar "<always|errors|never>"
<> help
"Keep build directories? (default: errors)"
<> value Errors
<> hidden
)
<*> option
))
<*> optional (option
(eitherReader downloaderParser)
( long "downloader"
#if defined(INTERNAL_DOWNLOADER)
<> metavar "<internal|curl|wget>"
<> help
"Downloader to use (default: internal)"
<> value Internal
#else
<> metavar "<curl|wget>"
<> help
"Downloader to use (default: curl)"
<> value Curl
#endif
<> hidden
)
))
<*> com
where
parseUri s' =
@ -857,14 +886,44 @@ bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
toSettings :: Options -> IO AppState
toSettings Options {..} = do
let cache = optCache
noVerify = optNoVerify
keepDirs = optKeepDirs
downloader = optsDownloader
verbose = optVerbose
toSettings options = do
dirs <- getDirs
pure $ AppState (Settings { .. }) dirs
userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
VRight r -> pure r
VLeft (V (JSONDecodeError e)) -> do
B.hPut stderr ("Error decoding config file: " <> (E.encodeUtf8 . T.pack . show $ e))
pure defaultUserSettings
_ -> do
die "Unexpected error!"
pure $ mergeConf options dirs userConf
where
mergeConf :: Options -> Dirs -> UserSettings -> AppState
mergeConf (Options {..}) dirs (UserSettings {..}) =
let cache = fromMaybe (fromMaybe False uCache) optCache
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose
keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
in AppState (Settings {..}) dirs keyBindings
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
#else
defaultDownloader = Curl
#endif
mergeKeys :: UserKeyBindings -> KeyBindings
mergeKeys UserKeyBindings {..} =
let KeyBindings {..} = defaultKeyBindings
in KeyBindings {
bUp = fromMaybe bUp kUp
, bDown = fromMaybe bDown kDown
, bQuit = fromMaybe bQuit kQuit
, bInstall = fromMaybe bInstall kInstall
, bUninstall = fromMaybe bUninstall kUninstall
, bSet = fromMaybe bSet kSet
, bChangelog = fromMaybe bChangelog kChangelog
, bShowAll = fromMaybe bShowAll kShowAll
}
upgradeOptsP :: Parser UpgradeOpts
@ -948,7 +1007,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- logger interpreter
logfile <- flip runReaderT appstate $ initGHCupFileLogging [rel|ghcup.log|]
let loggerConfig = LoggerConfig
{ lcPrintDebug = optVerbose
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
}

5
ghcup.cabal
View File

@ -72,6 +72,9 @@ common bz2
common case-insensitive
build-depends: case-insensitive >=1.2.1.0
common casing
build-depends: casing >=0.1.4.1
common concurrent-output
build-depends: concurrent-output >=1.10.11
@ -266,6 +269,7 @@ library
, bytestring
, bz2
, case-insensitive
, casing
, concurrent-output
, containers
, cryptohash-sha256
@ -307,6 +311,7 @@ library
, utf8-string
, vector
, versions
, vty
, word8
, yaml
, zlib

54
lib/GHCup/Types.hs
View File

@ -21,6 +21,7 @@ import URI.ByteString
import qualified Data.Text as T
import qualified GHC.Generics as GHC
import qualified Graphics.Vty as Vty
@ -193,9 +194,59 @@ data URLSource = GHCupURL
deriving (GHC.Generic, Show)
data UserSettings = UserSettings
{ uCache :: Maybe Bool
, uNoVerify :: Maybe Bool
, uVerbose :: Maybe Bool
, uKeepDirs :: Maybe KeepDirs
, uDownloader :: Maybe Downloader
, uKeyBindings :: Maybe UserKeyBindings
}
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing
data UserKeyBindings = UserKeyBindings
{ kUp :: Maybe Vty.Key
, kDown :: Maybe Vty.Key
, kQuit :: Maybe Vty.Key
, kInstall :: Maybe Vty.Key
, kUninstall :: Maybe Vty.Key
, kSet :: Maybe Vty.Key
, kChangelog :: Maybe Vty.Key
, kShowAll :: Maybe Vty.Key
}
deriving (Show, GHC.Generic)
data KeyBindings = KeyBindings
{ bUp :: Vty.Key
, bDown :: Vty.Key
, bQuit :: Vty.Key
, bInstall :: Vty.Key
, bUninstall :: Vty.Key
, bSet :: Vty.Key
, bChangelog :: Vty.Key
, bShowAll :: Vty.Key
}
deriving (Show, GHC.Generic)
defaultKeyBindings :: KeyBindings
defaultKeyBindings = KeyBindings
{ bUp = Vty.KUp
, bDown = Vty.KDown
, bQuit = Vty.KChar 'q'
, bInstall = Vty.KChar 'i'
, bUninstall = Vty.KChar 'u'
, bSet = Vty.KChar 's'
, bChangelog = Vty.KChar 'c'
, bShowAll = Vty.KChar 'a'
}
data AppState = AppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
} deriving (Show)
data Settings = Settings
@ -205,13 +256,14 @@ data Settings = Settings
, downloader :: Downloader
, verbose :: Bool
}
deriving Show
deriving (Show, GHC.Generic)
data Dirs = Dirs
{ baseDir :: Path Abs
, binDir :: Path Abs
, cacheDir :: Path Abs
, logsDir :: Path Abs
, confDir :: Path Abs
}
deriving Show

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

@ -33,9 +33,11 @@ import Data.Versions
import Data.Word8
import HPath
import URI.ByteString
import Text.Casing
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
@ -51,6 +53,11 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Vty.Key
instance ToJSON Tag where
toJSON Latest = String "Latest"

51
lib/GHCup/Utils/Dirs.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
@ -14,16 +15,18 @@ Portability : POSIX
-}
module GHCup.Utils.Dirs
( getDirs
, ghcupConfigFile
, ghcupGHCBaseDir
, ghcupGHCDir
, parseGHCupGHCDir
, mkGhcupTmpDir
, withGHCupTmpDir
, parseGHCupGHCDir
, relativeSymlink
, withGHCupTmpDir
)
where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.MegaParsec
@ -34,8 +37,11 @@ import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Maybe
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO
import Optics
@ -49,8 +55,10 @@ import System.Posix.Env.ByteString ( getEnv
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
import qualified Text.Megaparsec as MP
@ -84,6 +92,28 @@ ghcupBaseDir = do
pure (bdir </> [rel|.ghcup|])
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
ghcupConfigDir :: IO (Path Abs)
ghcupConfigDir = do
xdg <- useXDG
if xdg
then do
bdir <- getEnv "XDG_CONFIG_HOME" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> [rel|.config|])
pure (bdir </> [rel|ghcup|])
else do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> liftIO getHomeDirectory
pure (bdir </> [rel|.ghcup|])
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
-- (which, sadly is not strictly xdg spec).
@ -142,10 +172,27 @@ getDirs = do
binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
pure Dirs { .. }
-------------------
--[ GHCup files ]--
-------------------
ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings
ghcupConfigFile = do
confDir <- liftIO $ ghcupConfigDir
let file = confDir </> [rel|config.yaml|]
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ fmap Just $ readFile file
case bs of
Nothing -> pure defaultUserSettings
Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs'
-------------------------
--[ GHCup directories ]--
-------------------------