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

Merge branch 'max_path'

Browse Source
This commit is contained in:
Julian Ospald 2022-03-18 17:48:58 +01:00
commit 76acc9a5f5
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
11 changed files with 243 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
CHANGELOG.md
View File

@ -5,6 +5,11 @@
* Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242) * Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242)
* Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324) * Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324)
* Fix bad error message wrt [#323](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/323) * Fix bad error message wrt [#323](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/323)
* Use predictable /tmp names for `ghcup run`, fixes [#329](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/329)
* Fix bug with isolated installation of not previously installed versions
* Add `--no-set` to install commands, fixes [#330](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/330)
* Fix serious bug in `ghcup list --raw-format -t <tool> -c installed`
* Overhaul metadata merging and add `ghcup config add-release-channel URI` wrt [#328](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/328)
## 0.1.17.5 -- 2022-02-26 ## 0.1.17.5 -- 2022-02-26

95
app/ghcup/GHCup/OptParse/Config.hs
View File

@ -7,6 +7,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExplicitForAll #-}
module GHCup.OptParse.Config where module GHCup.OptParse.Config where
@ -17,6 +18,7 @@ import GHCup.Utils
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.String.QQ import GHCup.Utils.String.QQ
import GHCup.OptParse.Common
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@ -27,10 +29,11 @@ import Control.Monad.Trans.Resource
import Data.Functor import Data.Functor
import Data.Maybe import Data.Maybe
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style, ParseError )
import Options.Applicative.Help.Pretty ( text ) import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Exit import System.Exit
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
@ -49,6 +52,7 @@ data ConfigCommand
= ShowConfig = ShowConfig
| SetConfig String (Maybe String) | SetConfig String (Maybe String)
| InitConfig | InitConfig
| AddReleaseChannel URI
@ -62,6 +66,7 @@ configP = subparser
( command "init" initP ( command "init" initP
<> command "set" setP -- [set] KEY VALUE at help lhs <> command "set" setP -- [set] KEY VALUE at help lhs
<> command "show" showP <> command "show" showP
<> command "add-release-channel" addP
) )
<|> argsP -- add show for a single option <|> argsP -- add show for a single option
<|> pure ShowConfig <|> pure ShowConfig
@ -70,6 +75,8 @@ configP = subparser
showP = info (pure ShowConfig) (progDesc "Show current config (default)") 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)) 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")) argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
addP = info (AddReleaseChannel <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
(progDesc "Add a release channel from a URI")
@ -114,23 +121,18 @@ formatConfig :: UserSettings -> String
formatConfig = UTF8.toString . Y.encode formatConfig = UTF8.toString . Y.encode
updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings updateSettings :: UserSettings -> Settings -> Settings
updateSettings config' settings = do updateSettings UserSettings{..} Settings{..} =
settings' <- lE' (JSONDecodeError . displayException) . Y.decodeEither' $ config' let cache' = fromMaybe cache uCache
pure $ mergeConf settings' settings metaCache' = fromMaybe metaCache uMetaCache
where noVerify' = fromMaybe noVerify uNoVerify
mergeConf :: UserSettings -> Settings -> Settings keepDirs' = fromMaybe keepDirs uKeepDirs
mergeConf UserSettings{..} Settings{..} = downloader' = fromMaybe downloader uDownloader
let cache' = fromMaybe cache uCache verbose' = fromMaybe verbose uVerbose
metaCache' = fromMaybe metaCache uMetaCache urlSource' = fromMaybe urlSource uUrlSource
noVerify' = fromMaybe noVerify uNoVerify noNetwork' = fromMaybe noNetwork uNoNetwork
keepDirs' = fromMaybe keepDirs uKeepDirs gpgSetting' = fromMaybe gpgSetting uGPGSetting
downloader' = fromMaybe downloader uDownloader in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
verbose' = fromMaybe verbose uVerbose
urlSource' = fromMaybe urlSource uUrlSource
noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting
in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
@ -140,7 +142,7 @@ updateSettings config' settings = do
config :: ( Monad m config :: forall m. ( Monad m
, MonadMask m , MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
@ -161,27 +163,42 @@ config configCommand settings keybindings runLogger = case configCommand of
liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings) liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
pure ExitSuccess pure ExitSuccess
(SetConfig k (Just v)) -> (SetConfig k mv) -> do
case v of r <- runE @'[JSONError, ParseError] $ do
"" -> do case mv of
runLogger $ logError "Empty values are not allowed" Just "" ->
pure $ ExitFailure 55 throwE $ ParseError "Empty values are not allowed"
_ -> doConfig (k <> ": " <> v <> "\n") 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
(SetConfig json Nothing) -> doConfig json AddReleaseChannel uri -> do
case urlSource settings of
AddSource xs -> do
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })
pure ExitSuccess
_ -> do
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
pure ExitSuccess
where where
doConfig val = do doConfig :: MonadIO m => UserSettings -> m ()
r <- runE @'[JSONError] $ do doConfig usersettings = do
settings' <- updateSettings (UTF8.fromString val) settings let settings' = updateSettings usersettings settings
path <- liftIO getConfigFilePath path <- liftIO getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings) liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
lift $ runLogger $ logDebug $ T.pack $ show settings' runLogger $ logDebug $ T.pack $ show settings'
pure () pure ()
case r of decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString
VRight _ -> pure ExitSuccess
VLeft (V (JSONDecodeError e)) -> do
runLogger $ logError $ "Error decoding config: " <> T.pack e
pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65

4
app/ghcup/GHCup/OptParse/List.hs
View File

@ -143,11 +143,11 @@ printListResult no_color raw lr = do
) )
$ lr $ lr
let cols = let cols =
foldr (\xs ys -> zipWith (:) xs ys) (cycle [[]]) rows foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows
lengths = fmap (maximum . fmap strWidth) cols lengths = fmap (maximum . fmap strWidth) cols
padded = fmap (\xs -> zipWith padTo xs lengths) rows padded = fmap (\xs -> zipWith padTo xs lengths) rows
forM_ padded $ \row -> putStrLn $ unwords row forM_ (if raw then rows else padded) $ \row -> putStrLn $ unwords row
where where
padTo str' x = padTo str' x =

146
app/ghcup/GHCup/OptParse/Run.hs
View File

@ -15,7 +15,7 @@ import GHCup.Utils.File
import GHCup.OptParse.Common import GHCup.OptParse.Common
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics ( getDirs ) import GHCup.Types.Optics
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.String.QQ import GHCup.Utils.String.QQ
@ -187,14 +187,16 @@ runLeanRUN leanAppstate =
@RunEffects @RunEffects
runRUN :: MonadUnliftIO m runRUN :: MonadUnliftIO m
=> (ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a)) => IO AppState
-> Excepts RunEffects (ResourceT (ReaderT AppState m)) a -> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither RunEffects a) -> m (VEither RunEffects a)
runRUN runAppState = runRUN appState action' = do
runAppState s' <- liftIO appState
flip runReaderT s'
. runResourceT . runResourceT
. runE . runE
@RunEffects @RunEffects
$ action'
@ -212,52 +214,77 @@ run :: forall m.
, MonadUnliftIO m , MonadUnliftIO m
) )
=> RunOptions => RunOptions
-> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a)) -> IO AppState
-> LeanAppState -> LeanAppState
-> (ReaderT LeanAppState m () -> m ()) -> (ReaderT LeanAppState m () -> m ())
-> m ExitCode -> m ExitCode
run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do run RunOptions{..} runAppState leanAppstate runLogger = do
toolchain <- Excepts resolveToolchain r <- if or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool'
tmp <- case runBinDir of then runRUN runAppState $ do
Just bindir -> do toolchain <- liftE resolveToolchainFull
liftIO $ createDirRecursive' bindir tmp <- case runBinDir of
liftIO $ canonicalizePath bindir Just bindir -> do
Nothing -> do liftIO $ createDirRecursive' bindir
d <- liftIO $ predictableTmpDir toolchain liftIO $ canonicalizePath bindir
liftIO $ createDirRecursive' d Nothing -> do
liftIO $ canonicalizePath d d <- liftIO $ predictableTmpDir toolchain
Excepts $ installToolChain toolchain tmp liftIO $ createDirRecursive' d
pure tmp liftIO $ canonicalizePath d
) >>= \case liftE $ installToolChainFull toolchain tmp
VRight tmp -> do pure tmp
case runCOMMAND of else runLeanRUN leanAppstate $ do
[] -> do toolchain <- resolveToolchain
liftIO $ putStr tmp tmp <- case runBinDir of
pure ExitSuccess Just bindir -> do
(cmd:args) -> do liftIO $ createDirRecursive' bindir
newEnv <- liftIO $ addToPath tmp liftIO $ canonicalizePath bindir
Nothing -> do
d <- liftIO $ predictableTmpDir toolchain
liftIO $ createDirRecursive' d
liftIO $ canonicalizePath d
liftE $ installToolChain toolchain tmp
pure tmp
case r of
VRight tmp -> do
case runCOMMAND of
[] -> do
liftIO $ putStr tmp
pure ExitSuccess
(cmd:args) -> do
newEnv <- liftIO $ addToPath tmp
#ifndef IS_WINDOWS #ifndef IS_WINDOWS
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
pure ExitSuccess pure ExitSuccess
#else #else
r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
case r' of case r' of
VRight _ -> pure ExitSuccess VRight _ -> pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 28 pure $ ExitFailure 28
#endif #endif
VLeft e -> do VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 27 pure $ ExitFailure 27
where where
isToolTag :: ToolVersion -> Bool isToolTag :: ToolVersion -> Bool
isToolTag (ToolTag _) = True isToolTag (ToolTag _) = True
isToolTag _ = False isToolTag _ = False
-- TODO: doesn't work for cross -- TODO: doesn't work for cross
resolveToolchain resolveToolchainFull :: ( MonadFail m
| or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do , MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] (ResourceT (ReaderT AppState m)) Toolchain
resolveToolchainFull = do
ghcVer <- forM runGHCVer $ \ver -> do ghcVer <- forM runGHCVer $ \ver -> do
(v, _) <- liftE $ fromVersion (Just ver) GHC (v, _) <- liftE $ fromVersion (Just ver) GHC
pure v pure v
@ -271,7 +298,8 @@ run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do
(v, _) <- liftE $ fromVersion (Just ver) Stack (v, _) <- liftE $ fromVersion (Just ver) Stack
pure v pure v
pure Toolchain{..} pure Toolchain{..}
| otherwise = runLeanRUN leanAppstate $ do
resolveToolchain = do
ghcVer <- case runGHCVer of ghcVer <- case runGHCVer of
Just (ToolVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing Nothing -> pure Nothing
@ -290,8 +318,33 @@ run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do
_ -> fail "Internal error" _ -> fail "Internal error"
pure Toolchain{..} pure Toolchain{..}
installToolChain Toolchain{..} tmp installToolChainFull :: ( MonadFail m
| or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do , MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Toolchain
-> FilePath
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
, UnknownArchive
, TarDirDoesNotExist
, ProcessError
, NotInstalled
, NoDownload
, GPGError
, DownloadFailed
, DirNotEmpty
, DigestError
, BuildFailed
, ArchiveResult
, AlreadyInstalled
, FileAlreadyExistsError
, CopyError
] (ResourceT (ReaderT AppState m)) ()
installToolChainFull Toolchain{..} tmp = do
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt
case mt of case mt of
@ -320,7 +373,16 @@ run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do
False False
setTool HLS v tmp setTool HLS v tmp
_ -> pure () _ -> pure ()
| otherwise = runLeanRUN leanAppstate $ do
installToolChain :: ( MonadFail m
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Toolchain
-> FilePath
-> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
installToolChain Toolchain{..} tmp = do
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
case mt of case mt of
Just (GHC, v) -> setTool GHC v tmp Just (GHC, v) -> setTool GHC v tmp

8
app/ghcup/Main.hs
View File

@ -82,7 +82,7 @@ toSettings options = do
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) OwnSource optUrlSource urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
in (Settings {..}, keyBindings) in (Settings {..}, keyBindings)
@ -235,7 +235,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Interactive -> pure () Interactive -> pure ()
#endif #endif
-- check for new tools -- check for new tools
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case _
| Just False <- optVerbose -> pure ()
| otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do
newTools <- lift checkForUpdates newTools <- lift checkForUpdates
forM_ newTools $ \newTool@(t, l) -> do forM_ newTools $ \newTool@(t, l) -> do
@ -313,7 +315,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nuke -> nuke appState runLogger Nuke -> nuke appState runLogger
Prefetch pfCom -> prefetch pfCom runAppState runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand runAppState leanAppstate runLogger Run runCommand -> run runCommand appState leanAppstate runLogger
case res of case res of
ExitSuccess -> pure () ExitSuccess -> pure ()

14
data/config.yaml
View File

@ -48,12 +48,16 @@ url-source:
## Example 1: Read download info from this location instead ## Example 1: Read download info from this location instead
## Accepts file/http/https scheme ## Accepts file/http/https scheme
## Can also be an array of URLs or an array of 'Either GHCupInfo URL', in
## which case they are merged right-biased (overwriting duplicate versions).
# OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml" # OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions.
## Can also be an array of 'Either GHCupInfo URL', also see Example 3.
# AddSource: # AddSource:
# Left: # Left:
# toolRequirements: {} # this is ignored # globalTools: {}
# toolRequirements: {}
# ghcupDownloads: # ghcupDownloads:
# GHC: # GHC:
# 9.10.2: # 9.10.2:
@ -66,6 +70,8 @@ url-source:
# dlSubdir: ghc-7.10.3 # dlSubdir: ghc-7.10.3
# dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5 # dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions ## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate
## versions).
# AddSource: # AddSource:
# Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml" # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"

2
ghcup.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0 cabal-version: 3.0
name: ghcup name: ghcup
version: 0.1.17.5 version: 0.1.17.6
license: LGPL-3.0-only license: LGPL-3.0-only
license-file: LICENSE license-file: LICENSE
copyright: Julian Ospald 2020 copyright: Julian Ospald 2020

35
lib/GHCup/Download.hs
View File

@ -121,28 +121,25 @@ getDownloadsF = do
Settings { urlSource } <- lift getSettings Settings { urlSource } <- lift getSettings
case urlSource of case urlSource of
GHCupURL -> liftE $ getBase ghcupURL GHCupURL -> liftE $ getBase ghcupURL
(OwnSource url) -> liftE $ getBase url (OwnSource exts) -> do
ext <- liftE $ mapM (either pure getBase) exts
mergeGhcupInfo ext
(OwnSpec av) -> pure av (OwnSpec av) -> pure av
(AddSource (Left ext)) -> do (AddSource exts) -> do
base <- liftE $ getBase ghcupURL base <- liftE $ getBase ghcupURL
pure (mergeGhcupInfo base ext) ext <- liftE $ mapM (either pure getBase) exts
(AddSource (Right uri)) -> do mergeGhcupInfo (base:ext)
base <- liftE $ getBase ghcupURL
ext <- liftE $ getBase uri
pure (mergeGhcupInfo base ext)
where where
mergeGhcupInfo :: MonadFail m
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with => [GHCupInfo]
-> GHCupInfo -- ^ extension overwriting the base -> m GHCupInfo
-> GHCupInfo mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) = mergeGhcupInfo xs@(GHCupInfo{}: _) =
let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs)
Just a' -> M.union a' a newGlobalTools = M.unionsWith (\_ a2 -> a2 ) (_globalTools <$> xs)
Nothing -> a newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
) base in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
newGlobalTools = M.union base2 ext2
in GHCupInfo tr newDownloads newGlobalTools
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath

4
lib/GHCup/Types.hs
View File

@ -286,9 +286,9 @@ instance Pretty TarDir where
-- | Where to fetch GHCupDownloads from. -- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL data URLSource = GHCupURL
| OwnSource URI | OwnSource [Either GHCupInfo URI] -- ^ complete source list
| OwnSpec GHCupInfo | OwnSpec GHCupInfo
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
deriving (GHC.Generic, Show) deriving (GHC.Generic, Show)
instance NFData URLSource instance NFData URLSource

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

@ -79,6 +79,38 @@ instance FromJSON Tag where
instance ToJSON URI where instance ToJSON URI where
toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef' toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef'
instance FromJSON URLSource where
parseJSON v =
parseGHCupURL v
<|> parseOwnSourceLegacy v
<|> parseOwnSourceNew1 v
<|> parseOwnSourceNew2 v
<|> parseOwnSpec v
<|> legacyParseAddSource v
<|> newParseAddSource v
where
parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
r :: URI <- o .: "OwnSource"
pure (OwnSource [Right r])
parseOwnSourceNew1 = withObject "URLSource" $ \o -> do
r :: [URI] <- o .: "OwnSource"
pure (OwnSource (fmap Right r))
parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "OwnSource"
pure (OwnSource r)
parseOwnSpec = withObject "URLSource" $ \o -> do
r :: GHCupInfo <- o .: "OwnSpec"
pure (OwnSpec r)
parseGHCupURL = withObject "URLSource" $ \o -> do
_ :: [Value] <- o .: "GHCupURL"
pure GHCupURL
legacyParseAddSource = withObject "URLSource" $ \o -> do
r :: Either GHCupInfo URI <- o .: "AddSource"
pure (AddSource [r])
newParseAddSource = withObject "URLSource" $ \o -> do
r :: [Either GHCupInfo URI] <- o .: "AddSource"
pure (AddSource r)
instance FromJSON URI where instance FromJSON URI where
parseJSON = withText "URL" $ \t -> parseJSON = withText "URL" $ \t ->
case parseURI strictURIParserOptions (encodeUtf8 t) of case parseURI strictURIParserOptions (encodeUtf8 t) of
@ -314,7 +346,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
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 "u-") . T.pack . kebab $ str' } ''UserSettings

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

@ -339,13 +339,15 @@ useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
relativeSymlink :: FilePath -- ^ the path in which to create the symlink relativeSymlink :: FilePath -- ^ the path in which to create the symlink
-> FilePath -- ^ the symlink destination -> FilePath -- ^ the symlink destination
-> FilePath -> FilePath
relativeSymlink p1 p2 = relativeSymlink p1 p2
let d1 = splitDirectories p1 | isWindows = p2 -- windows quickly gets into MAX_PATH issues so we don't care about relative symlinks
d2 = splitDirectories p2 | otherwise =
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2 let d1 = splitDirectories p1
cPrefix = drop (length common) d1 d2 = splitDirectories p2
in joinPath (replicate (length cPrefix) "..") common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
<> joinPath ([pathSeparator] : drop (length common) d2) cPrefix = drop (length common) d1
in joinPath (replicate (length cPrefix) "..")
<> joinPath ([pathSeparator] : drop (length common) d2)
cleanupTrash :: ( MonadIO m cleanupTrash :: ( MonadIO m