diff --git a/README.md b/README.md index 8741d1c..16107d0 100644 --- a/README.md +++ b/README.md @@ -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. diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index e18893d..38a6e39 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -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 ()) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 8615af6..b4d0fee 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -494,6 +494,7 @@ settings' = unsafePerformIO $ do , keepDirs = Never , downloader = Curl , verbose = False + , urlSource = GHCupURL , .. }) dirs diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index d45cdfa..beff0df 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -913,12 +913,13 @@ toSettings options = do 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 + 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 + 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 |] . flip runReaderT appstate . runE @'[JSONError , DownloadFailed, FileDoesNotExistError] $ liftE - $ getDownloadsF (maybe GHCupURL OwnSource optUrlSource) + $ getDownloadsF (urlSource settings) ) >>= \case VRight r -> pure r diff --git a/config.yaml b/config.yaml new file mode 100644 index 0000000..cb98934 --- /dev/null +++ b/config.yaml @@ -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" diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 18a2c5c..c07f3ff 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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-.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. diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index e2cc526..4387f39 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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) diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 4333596..e68a608 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -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