Allow configuring URLSource as well

This commit is contained in:
Julian Ospald 2020-10-25 14:17:17 +01:00
parent d368863c3d
commit 53f5a08924
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
8 changed files with 112 additions and 79 deletions

View File

@ -83,42 +83,8 @@ handles your haskell packages and can demand that [a specific version](https://c
### 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'
```
A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
explaining all possible configurations can be found in this repo: [config.yaml](./config.yaml).
Partial configuration is fine. Command line options always overwrite the config file settings.

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 defaultKeyBindings
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())

View File

@ -494,6 +494,7 @@ settings' = unsafePerformIO $ do
, keepDirs = Never
, downloader = Curl
, verbose = False
, urlSource = GHCupURL
, ..
})
dirs

View File

@ -919,6 +919,7 @@ toSettings options = do
keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
in AppState (Settings {..}) dirs keyBindings
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
@ -1149,7 +1150,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. flip runReaderT appstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF (maybe GHCupURL OwnSource optUrlSource)
$ getDownloadsF (urlSource settings)
)
>>= \case
VRight r -> pure r

61
config.yaml Normal file
View File

@ -0,0 +1,61 @@
# 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'
# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
# check the 'URLSource' type in the code.
url-source:
## Use the internal download uri, this is the default
GHCupURL: []
## Example 1: Read download info from this location instead
## Accepts file/http/https scheme
# OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions
# AddSource:
# Left:
# toolRequirements: {} # this is ignored
# ghcupDownloads:
# GHC:
# 9.10.2:
# viTags: []
# viArch:
# A_64:
# Linux_UnknownLinux:
# unknown_versioning:
# dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2
# dlSubdir: ghc-7.10.3
# dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions
# AddSource:
# Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"

View File

@ -83,9 +83,9 @@ import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
#if defined(INTERNAL_DOWNLOADER)
import qualified Data.CaseInsensitive as CI
import qualified Data.Map.Strict as M
import qualified Data.Text as T
#endif
import qualified Data.Text.Encoding as E
@ -104,8 +104,8 @@ import qualified System.Posix.RawFilePath.Directory
------------------
-- | Like 'getDownloads', but tries to fall back to
-- cached ~/.ghcup/cache/ghcup-<format-ver>.yaml
-- | Downloads the download information! But only if we need to ;P
getDownloadsF :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
@ -123,15 +123,22 @@ getDownloadsF :: ( FromJSONKey Tool
GHCupInfo
getDownloadsF urlSource = do
case urlSource of
GHCupURL ->
liftE
$ handleIO (\_ -> readFromCache)
$ catchE @_ @'[JSONError , FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache)
$ getDownloads urlSource
(OwnSource _) -> liftE $ getDownloads urlSource
(OwnSpec _) -> liftE $ getDownloads urlSource
GHCupURL -> liftE getBase
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure av
(AddSource (Left ext)) -> do
base <- liftE getBase
pure (mergeGhcupInfo base ext)
(AddSource (Right uri)) -> do
base <- liftE getBase
bsExt <- reThrowAll DownloadFailed $ downloadBS uri
ext <- lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext)
where
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache = do
AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn)
@ -145,32 +152,25 @@ getDownloadsF urlSource = do
$ readFile yaml_file
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase =
handleIO (\_ -> readFromCache)
$ catchE @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache)
$ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
-- | Downloads the download information! But only if we need to ;P
getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version
, FromJSON VersionInfo
, MonadIO m
, MonadCatch m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadReader AppState m
)
=> URLSource
-> Excepts '[JSONError , DownloadFailed] m GHCupInfo
getDownloads urlSource = do
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
case urlSource of
GHCupURL -> do
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure $ av
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
-> GHCupInfo -- ^ extension overwriting the base
-> GHCupInfo
mergeGhcupInfo (GHCupInfo tr base) (GHCupInfo _ ext) =
let new = M.mapWithKey (\k a -> case M.lookup k ext of
Just a' -> M.union a' a
Nothing -> a
) base
in GHCupInfo tr new
where
-- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the
-- last 5 minutes, just reuse it.

View File

@ -191,6 +191,7 @@ data TarDir = RealDir (Path Rel)
data URLSource = GHCupURL
| OwnSource URI
| OwnSpec GHCupInfo
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
deriving (GHC.Generic, Show)
@ -201,11 +202,12 @@ data UserSettings = UserSettings
, uKeepDirs :: Maybe KeepDirs
, uDownloader :: Maybe Downloader
, uKeyBindings :: Maybe UserKeyBindings
, uUrlSource :: Maybe URLSource
}
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data UserKeyBindings = UserKeyBindings
{ kUp :: Maybe Vty.Key
@ -255,6 +257,7 @@ data Settings = Settings
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
, urlSource :: URLSource
}
deriving (Show, GHC.Generic)

View File

@ -55,6 +55,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupI
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
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