diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 66c851a..5afa2db 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -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 () diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index 97cf23d..c04eac5 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -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 diff --git a/lib-opt/GHCup/OptParse/Prefetch.hs b/lib-opt/GHCup/OptParse/Prefetch.hs index 803457d..3550ab7 100644 --- a/lib-opt/GHCup/OptParse/Prefetch.hs +++ b/lib-opt/GHCup/OptParse/Prefetch.hs @@ -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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 74c55e8..827dd7d 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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 diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 5c833ac..73708ec 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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 diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 367b23a..4ea2953 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 53b3c3c..3763623 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 diff --git a/lib/GHCup/Types/Stack.hs b/lib/GHCup/Types/Stack.hs index 52cea72..84c3b45 100644 --- a/lib/GHCup/Types/Stack.hs +++ b/lib/GHCup/Types/Stack.hs @@ -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 {..}