Allow configuring URLSource as well

2020-10-25 14:17:17 +01:00 · 2020-10-25 14:17:17 +01:00 · 53f5a08924
commit 53f5a08924
parent d368863c3d
8 changed files with 112 additions and 79 deletions
--- 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.

--- 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 ())
--- 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
--- 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 <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
--- a/config.yaml
+++ 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"
--- 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-<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.
--- 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)

--- 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