Merge branch 'sunday-improvements'
This commit is contained in:
commit
0103e2771e
@ -555,7 +555,35 @@ set' bs input@(_, ListResult {..}) = do
|
||||
|
||||
let run =
|
||||
flip runReaderT settings
|
||||
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
, ArchiveResult
|
||||
, UnknownArchive
|
||||
, FileDoesNotExistError
|
||||
, CopyError
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, BuildFailed
|
||||
, TagNotFound
|
||||
, DigestError
|
||||
, ContentLengthError
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, DirNotEmpty
|
||||
, NoUpdate
|
||||
, TarDirDoesNotExist
|
||||
, FileAlreadyExistsError
|
||||
, ProcessError
|
||||
, ToolShadowed
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
, NoCompatiblePlatform
|
||||
, GHCup.Errors.ParseError
|
||||
, UnsupportedSetupCombo
|
||||
, DistroNotFound
|
||||
, NoCompatibleArch
|
||||
]
|
||||
|
||||
run (do
|
||||
case lTool of
|
||||
@ -563,7 +591,12 @@ set' bs input@(_, ListResult {..}) = do
|
||||
Cabal -> liftE $ setCabal lVer $> ()
|
||||
HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
|
||||
Stack -> liftE $ setStack lVer $> ()
|
||||
GHCup -> pure ()
|
||||
GHCup -> do
|
||||
promptAnswer <- getUserPromptResponse "Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/N]: "
|
||||
case promptAnswer of
|
||||
PromptYes -> do
|
||||
void $ liftE $ upgradeGHCup Nothing False False
|
||||
PromptNo -> pure ()
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure $ Right ()
|
||||
|
||||
@ -67,7 +67,6 @@ configP = subparser
|
||||
<> command "show" showP
|
||||
<> command "add-release-channel" addP
|
||||
)
|
||||
<|> argsP -- add show for a single option
|
||||
<|> pure ShowConfig
|
||||
where
|
||||
initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
|
||||
@ -193,10 +192,14 @@ config configCommand settings userConf keybindings runLogger = case configComman
|
||||
throwE $ ParseError "Empty values are not allowed"
|
||||
Nothing -> do
|
||||
usersettings <- decodeSettings k
|
||||
when (usersettings == defaultUserSettings)
|
||||
$ throwE $ ParseError ("Failed to parse setting (maybe typo?): " <> k)
|
||||
lift $ doConfig usersettings
|
||||
pure ()
|
||||
Just v -> do
|
||||
usersettings <- decodeSettings (k <> ": " <> v <> "\n")
|
||||
when (usersettings == defaultUserSettings)
|
||||
$ throwE $ ParseError ("Failed to parse key '" <> k <> "' with value '" <> v <> "' as user setting. Maybe typo?")
|
||||
lift $ doConfig usersettings
|
||||
pure ()
|
||||
case r of
|
||||
@ -204,7 +207,9 @@ config configCommand settings userConf keybindings runLogger = case configComman
|
||||
VLeft (V (JSONDecodeError e)) -> do
|
||||
runLogger $ logError $ "Error decoding config: " <> T.pack e
|
||||
pure $ ExitFailure 65
|
||||
VLeft _ -> pure $ ExitFailure 65
|
||||
VLeft e -> do
|
||||
runLogger (logError $ T.pack $ prettyHFError e)
|
||||
pure $ ExitFailure 65
|
||||
|
||||
AddReleaseChannel force new -> do
|
||||
r <- runE @'[DuplicateReleaseChannel] $ do
|
||||
|
||||
@ -199,19 +199,19 @@ prefetch prefetchCommand runAppState runLogger =
|
||||
(v, _) <- liftE $ fromVersion mt GHC
|
||||
if pfGHCSrc
|
||||
then liftE $ fetchGHCSrc v pfCacheDir
|
||||
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
|
||||
else liftE $ fetchToolBindist v GHC pfCacheDir
|
||||
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt Cabal
|
||||
liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
|
||||
liftE $ fetchToolBindist v Cabal pfCacheDir
|
||||
PrefetchHLS PrefetchOptions {pfCacheDir} mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt HLS
|
||||
liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
|
||||
liftE $ fetchToolBindist v HLS pfCacheDir
|
||||
PrefetchStack PrefetchOptions {pfCacheDir} mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt Stack
|
||||
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
|
||||
liftE $ fetchToolBindist v Stack pfCacheDir
|
||||
PrefetchMetadata -> do
|
||||
pfreq <- lift getPlatformReq
|
||||
_ <- liftE $ getDownloadsF pfreq
|
||||
|
||||
@ -100,7 +100,7 @@ fetchToolBindist :: ( MonadFail m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Version
|
||||
=> GHCTargetVersion
|
||||
-> Tool
|
||||
-> Maybe FilePath
|
||||
-> Excepts
|
||||
@ -113,7 +113,7 @@ fetchToolBindist :: ( MonadFail m
|
||||
m
|
||||
FilePath
|
||||
fetchToolBindist v t mfp = do
|
||||
dlinfo <- liftE $ getDownloadInfo t v
|
||||
dlinfo <- liftE $ getDownloadInfo' t v
|
||||
liftE $ downloadCached' dlinfo Nothing mfp
|
||||
|
||||
|
||||
|
||||
@ -149,12 +149,16 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
|
||||
-> Excepts
|
||||
'[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError]
|
||||
m (Either GHCupInfo Stack.SetupInfo)
|
||||
dl' NewGHCupURL = fmap Left $ liftE $ getBase @GHCupInfo ghcupURL
|
||||
dl' NewStackSetupURL = fmap Right $ liftE $ getBase @Stack.SetupInfo stackSetupURL
|
||||
dl' NewGHCupURL = fmap Left $ liftE (getBase ghcupURL) >>= liftE . decodeMetadata @GHCupInfo
|
||||
dl' NewStackSetupURL = fmap Right $ liftE (getBase stackSetupURL) >>= liftE . decodeMetadata @Stack.SetupInfo
|
||||
dl' (NewGHCupInfo gi) = pure (Left gi)
|
||||
dl' (NewSetupInfo si) = pure (Right si)
|
||||
dl' (NewURI uri) = catchE @JSONError (\(JSONDecodeError _) -> Right <$> getBase @Stack.SetupInfo uri)
|
||||
$ fmap Left $ getBase @GHCupInfo uri
|
||||
dl' (NewURI uri) = do
|
||||
base <- liftE $ getBase uri
|
||||
catchE @JSONError (\(JSONDecodeError _) -> do
|
||||
logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: "
|
||||
Right <$> decodeMetadata @Stack.SetupInfo base)
|
||||
$ fmap Left $ decodeMetadata @GHCupInfo base
|
||||
|
||||
fromStackSetupInfo :: MonadThrow m
|
||||
=> Stack.SetupInfo
|
||||
@ -201,7 +205,7 @@ etagsFile :: FilePath -> FilePath
|
||||
etagsFile = (<.> "etags")
|
||||
|
||||
|
||||
getBase :: forall j m env . ( MonadReader env m
|
||||
getBase :: forall m env . ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadFail m
|
||||
@ -209,10 +213,9 @@ getBase :: forall j m env . ( MonadReader env m
|
||||
, MonadCatch m
|
||||
, HasLog env
|
||||
, MonadMask m
|
||||
, FromJSON j
|
||||
)
|
||||
=> URI
|
||||
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m j
|
||||
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError] m FilePath
|
||||
getBase uri = do
|
||||
Settings { noNetwork, downloader, metaMode } <- lift getSettings
|
||||
|
||||
@ -232,25 +235,8 @@ getBase uri = do
|
||||
$ uri
|
||||
|
||||
-- if we didn't get a filepath from the download, use the cached yaml
|
||||
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
|
||||
lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
|
||||
|
||||
liftE
|
||||
. onE_ (onError actualYaml)
|
||||
. lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
|
||||
. liftIO
|
||||
. Y.decodeFileEither
|
||||
$ actualYaml
|
||||
maybe (lift $ yamlFromCache uri) pure mYaml
|
||||
where
|
||||
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
|
||||
-- may re-download and succeed.
|
||||
onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
|
||||
onError fp = do
|
||||
let efp = etagsFile fp
|
||||
handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
|
||||
(hideError doesNotExistErrorType $ rmFile efp)
|
||||
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
|
||||
|
||||
warnCache :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> Downloader -> m ()
|
||||
warnCache s downloader' = do
|
||||
let tryDownloder = case downloader' of
|
||||
@ -322,6 +308,39 @@ getBase uri = do
|
||||
|
||||
pure f
|
||||
|
||||
decodeMetadata :: forall j m env .
|
||||
( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, HasLog env
|
||||
, MonadMask m
|
||||
, FromJSON j
|
||||
)
|
||||
=> FilePath
|
||||
-> Excepts '[JSONError, FileDoesNotExistError] m j
|
||||
decodeMetadata actualYaml = do
|
||||
lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
|
||||
|
||||
liftE
|
||||
. onE_ (onError actualYaml)
|
||||
. lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
|
||||
. liftIO
|
||||
. Y.decodeFileEither
|
||||
$ actualYaml
|
||||
where
|
||||
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
|
||||
-- may re-download and succeed.
|
||||
onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
|
||||
onError fp = do
|
||||
let efp = etagsFile fp
|
||||
handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
|
||||
(hideError doesNotExistErrorType $ rmFile efp)
|
||||
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
|
||||
|
||||
|
||||
getDownloadInfo :: ( MonadReader env m
|
||||
, HasPlatformReq env
|
||||
, HasGHCupInfo env
|
||||
|
||||
@ -724,7 +724,7 @@ data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), HFErrorPr
|
||||
|
||||
instance Pretty InstallSetError where
|
||||
pPrint (InstallSetError reason1 reason2) =
|
||||
text "Both installation and setting the tool failed. Install error was:"
|
||||
text "Both installation and setting the tool failed.\nInstall error was:"
|
||||
<+> pPrint reason1
|
||||
<+> text "\nSet error was:"
|
||||
<+> pPrint reason2
|
||||
|
||||
@ -398,7 +398,7 @@ data UserSettings = UserSettings
|
||||
, uPlatformOverride :: Maybe PlatformRequest
|
||||
, uMirrors :: Maybe DownloadMirrors
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
deriving (Show, GHC.Generic, Eq)
|
||||
|
||||
defaultUserSettings :: UserSettings
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
@ -459,7 +459,7 @@ data UserKeyBindings = UserKeyBindings
|
||||
, kShowAll :: Maybe KeyCombination
|
||||
, kShowAllTools :: Maybe KeyCombination
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
deriving (Show, GHC.Generic, Eq)
|
||||
|
||||
data KeyBindings = KeyBindings
|
||||
{ bUp :: KeyCombination
|
||||
|
||||
@ -50,7 +50,7 @@ instance FromJSON SetupInfo where
|
||||
siSevenzExe <- o .:? "sevenzexe-info"
|
||||
siSevenzDll <- o .:? "sevenzdll-info"
|
||||
siMsys2 <- o .:? "msys2" .!= mempty
|
||||
siGHCs <- o .:? "ghc" .!= mempty
|
||||
siGHCs <- o .: "ghc"
|
||||
siStack <- o .:? "stack" .!= mempty
|
||||
pure SetupInfo {..}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user