From 2e5dee8e1a572644f71c5800bc856c7e1c43d3a8 Mon Sep 17 00:00:00 2001
From: Julian Ospald <hasufell@posteo.de>
Date: Mon, 13 Nov 2023 16:53:24 +0800
Subject: [PATCH] Add mechanism to warn on new metadata versions, fixes #860

---
 app/ghcup/BrickMain.hs  |  2 +-
 lib/GHCup/Download.hs   | 36 +++++++++++++++++++++++++++++++++---
 lib/GHCup/Types.hs      |  1 +
 lib/GHCup/Types/JSON.hs |  3 ++-
 lib/GHCup/Utils/Dirs.hs |  7 +++++++
 5 files changed, 44 insertions(+), 5 deletions(-)

diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs
index 7014b5b..5ae12bd 100644
--- a/app/ghcup/BrickMain.hs
+++ b/app/ghcup/BrickMain.hs
@@ -683,7 +683,7 @@ settings' = unsafePerformIO $ do
   newIORef $ AppState defaultSettings
                       dirs
                       defaultKeyBindings
-                      (GHCupInfo mempty mempty)
+                      (GHCupInfo mempty mempty Nothing)
                       (PlatformRequest A_64 Darwin Nothing)
                       loggerConfig
 
diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs
index 3a359f9..2de9519 100644
--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@@ -158,7 +158,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
                             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
+                              $ fmap Left (decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI)
 
   fromStackSetupInfo :: MonadThrow m
                      => Stack.SetupInfo
@@ -170,7 +170,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
     (ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
       M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
     let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
-    pure (GHCupInfo mempty ghcupDownloads')
+    pure (GHCupInfo mempty ghcupDownloads' Nothing)
    where
     fromDownloadInfo :: DownloadInfo -> VersionInfo
     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{}: _) =
     let newDownloads   = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads   <$> 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
 
+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 .
                ( MonadReader env m
                , HasDirs env
diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs
index fca0846..e8995f5 100644
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -74,6 +74,7 @@ data KeyCombination = KeyCombination { key :: Key, mods :: [Modifier] }
 data GHCupInfo = GHCupInfo
   { _toolRequirements :: ToolRequirements
   , _ghcupDownloads   :: GHCupDownloads
+  , _metadataUpdate   :: Maybe URI
   }
   deriving (Show, GHC.Generic, Eq)
 
diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs
index 037c88b..99c281a 100644
--- a/lib/GHCup/Types/JSON.hs
+++ b/lib/GHCup/Types/JSON.hs
@@ -281,8 +281,9 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio
 instance FromJSON GHCupInfo where
   parseJSON = withObject "GHCupInfo" $ \o -> do
     toolRequirements' <- o .:? "toolRequirements"
+    metadataUpdate    <- o .:? "metadataUpdate"
     ghcupDownloads'   <- o .:  "ghcupDownloads"
-    pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads')
+    pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' metadataUpdate)
 
 deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
 
diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs
index a31d442..838341e 100644
--- a/lib/GHCup/Utils/Dirs.hs
+++ b/lib/GHCup/Utils/Dirs.hs
@@ -29,6 +29,7 @@ module GHCup.Utils.Dirs
   , relativeSymlink
   , withGHCupTmpDir
   , getConfigFilePath
+  , getConfigFilePath'
   , useXDG
   , cleanupTrash
 
@@ -360,6 +361,12 @@ getConfigFilePath = do
   confDir <- liftIO ghcupConfigDir
   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)
                 => Excepts '[JSONError] m UserSettings
 ghcupConfigFile = do