Add mechanism to warn on new metadata versions, fixes #860
This commit is contained in:
parent
c6aa5c3ed7
commit
2e5dee8e1a
@ -683,7 +683,7 @@ settings' = unsafePerformIO $ do
|
|||||||
newIORef $ AppState defaultSettings
|
newIORef $ AppState defaultSettings
|
||||||
dirs
|
dirs
|
||||||
defaultKeyBindings
|
defaultKeyBindings
|
||||||
(GHCupInfo mempty mempty)
|
(GHCupInfo mempty mempty Nothing)
|
||||||
(PlatformRequest A_64 Darwin Nothing)
|
(PlatformRequest A_64 Darwin Nothing)
|
||||||
loggerConfig
|
loggerConfig
|
||||||
|
|
||||||
|
@ -158,7 +158,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
|
|||||||
catchE @JSONError (\(JSONDecodeError _) -> do
|
catchE @JSONError (\(JSONDecodeError _) -> do
|
||||||
logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: "
|
logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: "
|
||||||
Right <$> decodeMetadata @Stack.SetupInfo base)
|
Right <$> decodeMetadata @Stack.SetupInfo base)
|
||||||
$ fmap Left $ decodeMetadata @GHCupInfo base
|
$ fmap Left (decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI)
|
||||||
|
|
||||||
fromStackSetupInfo :: MonadThrow m
|
fromStackSetupInfo :: MonadThrow m
|
||||||
=> Stack.SetupInfo
|
=> Stack.SetupInfo
|
||||||
@ -170,7 +170,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
|
|||||||
(ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
|
(ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
|
||||||
M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
|
M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
|
||||||
let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
|
let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
|
||||||
pure (GHCupInfo mempty ghcupDownloads')
|
pure (GHCupInfo mempty ghcupDownloads' Nothing)
|
||||||
where
|
where
|
||||||
fromDownloadInfo :: DownloadInfo -> VersionInfo
|
fromDownloadInfo :: DownloadInfo -> VersionInfo
|
||||||
fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
|
fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
|
||||||
@ -190,7 +190,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
|
|||||||
mergeGhcupInfo xs@(GHCupInfo{}: _) =
|
mergeGhcupInfo xs@(GHCupInfo{}: _) =
|
||||||
let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs)
|
let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs)
|
||||||
newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
|
newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
|
||||||
in pure $ GHCupInfo newToolReqs newDownloads
|
in pure $ GHCupInfo newToolReqs newDownloads Nothing
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -307,6 +307,36 @@ getBase uri = do
|
|||||||
|
|
||||||
pure f
|
pure f
|
||||||
|
|
||||||
|
warnOnMetadataUpdate ::
|
||||||
|
( MonadReader env m
|
||||||
|
, MonadIO m
|
||||||
|
, HasLog env
|
||||||
|
, HasDirs env
|
||||||
|
)
|
||||||
|
=> URI
|
||||||
|
-> GHCupInfo
|
||||||
|
-> m ()
|
||||||
|
warnOnMetadataUpdate uri (GHCupInfo { _metadataUpdate = Just newUri })
|
||||||
|
| scheme' uri == "file"
|
||||||
|
, urlBase' uri /= urlBase' newUri = do
|
||||||
|
confFile <- getConfigFilePath'
|
||||||
|
logWarn $ "New metadata version detected"
|
||||||
|
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
|
||||||
|
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
|
||||||
|
<> "\nYou might need to update your " <> T.pack confFile
|
||||||
|
| scheme' uri /= "file"
|
||||||
|
, uri /= newUri = do
|
||||||
|
confFile <- getConfigFilePath'
|
||||||
|
logWarn $ "New metadata version detected"
|
||||||
|
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
|
||||||
|
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
|
||||||
|
<> "\nYou might need to update your " <> T.pack confFile
|
||||||
|
where
|
||||||
|
scheme' = view (uriSchemeL' % schemeBSL')
|
||||||
|
urlBase' = T.unpack . decUTF8Safe . urlBaseName . view pathL'
|
||||||
|
warnOnMetadataUpdate _ _ = pure ()
|
||||||
|
|
||||||
|
|
||||||
decodeMetadata :: forall j m env .
|
decodeMetadata :: forall j m env .
|
||||||
( MonadReader env m
|
( MonadReader env m
|
||||||
, HasDirs env
|
, HasDirs env
|
||||||
|
@ -74,6 +74,7 @@ data KeyCombination = KeyCombination { key :: Key, mods :: [Modifier] }
|
|||||||
data GHCupInfo = GHCupInfo
|
data GHCupInfo = GHCupInfo
|
||||||
{ _toolRequirements :: ToolRequirements
|
{ _toolRequirements :: ToolRequirements
|
||||||
, _ghcupDownloads :: GHCupDownloads
|
, _ghcupDownloads :: GHCupDownloads
|
||||||
|
, _metadataUpdate :: Maybe URI
|
||||||
}
|
}
|
||||||
deriving (Show, GHC.Generic, Eq)
|
deriving (Show, GHC.Generic, Eq)
|
||||||
|
|
||||||
|
@ -281,8 +281,9 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio
|
|||||||
instance FromJSON GHCupInfo where
|
instance FromJSON GHCupInfo where
|
||||||
parseJSON = withObject "GHCupInfo" $ \o -> do
|
parseJSON = withObject "GHCupInfo" $ \o -> do
|
||||||
toolRequirements' <- o .:? "toolRequirements"
|
toolRequirements' <- o .:? "toolRequirements"
|
||||||
|
metadataUpdate <- o .:? "metadataUpdate"
|
||||||
ghcupDownloads' <- o .: "ghcupDownloads"
|
ghcupDownloads' <- o .: "ghcupDownloads"
|
||||||
pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads')
|
pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' metadataUpdate)
|
||||||
|
|
||||||
deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
||||||
|
|
||||||
|
@ -29,6 +29,7 @@ module GHCup.Utils.Dirs
|
|||||||
, relativeSymlink
|
, relativeSymlink
|
||||||
, withGHCupTmpDir
|
, withGHCupTmpDir
|
||||||
, getConfigFilePath
|
, getConfigFilePath
|
||||||
|
, getConfigFilePath'
|
||||||
, useXDG
|
, useXDG
|
||||||
, cleanupTrash
|
, cleanupTrash
|
||||||
|
|
||||||
@ -360,6 +361,12 @@ getConfigFilePath = do
|
|||||||
confDir <- liftIO ghcupConfigDir
|
confDir <- liftIO ghcupConfigDir
|
||||||
pure $ fromGHCupPath confDir </> "config.yaml"
|
pure $ fromGHCupPath confDir </> "config.yaml"
|
||||||
|
|
||||||
|
getConfigFilePath' :: (MonadReader env m, HasDirs env) => m FilePath
|
||||||
|
getConfigFilePath' = do
|
||||||
|
Dirs {..} <- getDirs
|
||||||
|
pure $ fromGHCupPath confDir </> "config.yaml"
|
||||||
|
|
||||||
|
|
||||||
ghcupConfigFile :: (MonadIO m)
|
ghcupConfigFile :: (MonadIO m)
|
||||||
=> Excepts '[JSONError] m UserSettings
|
=> Excepts '[JSONError] m UserSettings
|
||||||
ghcupConfigFile = do
|
ghcupConfigFile = do
|
||||||
|
Loading…
Reference in New Issue
Block a user