Merge branch 'monday-improvements'

2023-11-14 23:16:42 +08:00 · 2023-11-14 23:16:42 +08:00 · b1106985ec
commit b1106985ec
parent dee54445bf cd8ce9aaa9
16 changed files with 15246 additions and 14299 deletions
--- a/.github/workflows/release.yaml
+++ b/.github/workflows/release.yaml
@ -322,7 +322,7 @@ jobs:
        with:
          name: testfiles
          path: |
-            ./test/golden/unix/GHCupInfo*json
+            ./test/ghcup-test/golden/unix/GHCupInfo*json

  test-arm:
    name: Test ARM
@ -389,7 +389,7 @@ jobs:
        with:
          name: testfiles
          path: |
-            ./test/golden/unix/GHCupInfo*json
+            ./test/ghcup-test/golden/unix/GHCupInfo*json

  test-macwin:
    name: Test Mac/Win
@ -458,7 +458,7 @@ jobs:
        with:
          name: testfiles
          path: |
-            ./test/golden/windows/GHCupInfo*json
+            ./test/ghcup-test/golden/windows/GHCupInfo*json

      - if: failure() && runner.os != 'Windows'
        name: Upload artifact
@ -466,7 +466,7 @@ jobs:
        with:
          name: testfiles
          path: |
-            ./test/golden/unix/GHCupInfo*json
+            ./test/ghcup-test/golden/unix/GHCupInfo*json
  hls:
    name: hls
    needs: build-linux
--- 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 mempty)
+                      (GHCupInfo mempty mempty Nothing)
                      (PlatformRequest A_64 Darwin Nothing)
                      loggerConfig

--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -261,7 +261,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                         Just _ -> pure ()

                -- TODO: always run for windows
-                siletRunLogger (flip runReaderT s' $ runE ensureGlobalTools) >>= \case
+                siletRunLogger (flip runReaderT s' $ runE ensureShimGen) >>= \case
                  VRight _ -> pure ()
                  VLeft e -> do
                    runLogger
--- 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' mempty)
+    pure (GHCupInfo mempty ghcupDownloads' Nothing)
   where
    fromDownloadInfo :: DownloadInfo -> VersionInfo
    fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
@ -189,9 +189,8 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
  mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
  mergeGhcupInfo xs@(GHCupInfo{}: _) =
    let newDownloads   = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads   <$> xs)
-        newGlobalTools = M.unionsWith (\_ a2 -> a2              ) (_globalTools      <$> xs)
        newToolReqs    = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
-    in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
+    in pure $ GHCupInfo newToolReqs newDownloads Nothing



@ -308,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
--- a/lib/GHCup/Errors.hs
+++ b/lib/GHCup/Errors.hs
@ -209,7 +209,6 @@ instance HFErrorProject NoCompatiblePlatform where

 -- | Unable to find a download for the requested version/distro.
 data NoDownload = NoDownload GHCTargetVersion Tool (Maybe PlatformRequest)
-                | NoDownload' GlobalTool
  deriving Show

 instance Pretty NoDownload where
@ -227,7 +226,6 @@ instance Pretty NoDownload where
             <> T.unpack (prettyVer vv)
             <> "'"
    | otherwise = text $ "Unable to find a download for " <> T.unpack (tVerToText tver)
-  pPrint (NoDownload' globalTool) = text $ "Unable to find a download for " <> prettyShow globalTool

 instance HFErrorProject NoDownload where
  eBase _ = 10
--- a/lib/GHCup/GHC.hs
+++ b/lib/GHCup/GHC.hs
@ -763,6 +763,7 @@ rmGHCVer ver = do

  Dirs {..} <- lift getDirs

+  when isSetGHC $ do
    lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir </> "share")


--- a/lib/GHCup/Prelude/File.hs
+++ b/lib/GHCup/Prelude/File.hs
@ -387,7 +387,7 @@ rmLink fp
 --
 -- This overwrites previously existing files.
 --
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
+-- On windows, this requires that 'ensureShimGen' was run beforehand.
 createLink :: ( MonadMask m
              , MonadThrow m
              , HasLog env
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@ -74,7 +74,7 @@ data KeyCombination = KeyCombination { key :: Key, mods :: [Modifier] }
 data GHCupInfo = GHCupInfo
  { _toolRequirements :: ToolRequirements
  , _ghcupDownloads   :: GHCupDownloads
-  , _globalTools      :: Map GlobalTool DownloadInfo
+  , _metadataUpdate   :: Maybe URI
  }
  deriving (Show, GHC.Generic, Eq)

@ -136,14 +136,6 @@ instance Pretty Tool where

 instance NFData Tool

-data GlobalTool = ShimGen
-  deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
-
-instance NFData GlobalTool
-
-instance Pretty GlobalTool where
-  pPrint ShimGen = text "shimgen"
-

 -- | All necessary information of a tool version, including
 -- source download and per-architecture downloads.
--- a/lib/GHCup/Types/JSON.hs
+++ b/lib/GHCup/Types/JSON.hs
@ -59,7 +59,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Chunk
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Release
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting
@ -158,12 +157,6 @@ instance ToJSONKey Tool where
 instance FromJSONKey Tool where
  fromJSONKey = genericFromJSONKey defaultJSONKeyOptions

-instance ToJSONKey GlobalTool where
-  toJSONKey = genericToJSONKey defaultJSONKeyOptions
-
-instance FromJSONKey GlobalTool where
-  fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
-
 instance ToJSON TarDir where
  toJSON (RealDir  p) = toJSON p
  toJSON (RegexDir r) = object ["RegexDir" .= r]
@ -288,9 +281,9 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio
 instance FromJSON GHCupInfo where
  parseJSON = withObject "GHCupInfo" $ \o -> do
    toolRequirements' <- o .:? "toolRequirements"
-    globalTools'      <- o .:? "globalTools"
+    metadataUpdate    <- o .:? "metadataUpdate"
    ghcupDownloads'   <- o .:  "ghcupDownloads"
-    pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' (fromMaybe mempty globalTools'))
+    pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' metadataUpdate)

 deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo

--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@ -1199,7 +1199,7 @@ getVersionInfo v' tool =
    )


-ensureGlobalTools :: ( MonadMask m
+ensureShimGen :: ( MonadMask m
                 , MonadThrow m
                 , HasLog env
                 , MonadIO m
@ -1211,12 +1211,10 @@ ensureGlobalTools :: ( MonadMask m
                 , MonadFail m
                 )
              => Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m ()
-ensureGlobalTools
+ensureShimGen
  | isWindows = do
-      (GHCupInfo _ _ gTools) <- lift getGHCupInfo
      dirs <- lift getDirs
-      shimDownload <- liftE $ lE @_ @'[NoDownload]
-        $ maybe (Left (NoDownload' ShimGen)) Right $ Map.lookup ShimGen gTools
+      let shimDownload = DownloadInfo shimGenURL Nothing shimGenSHA Nothing Nothing
      let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
      void $ (\DigestError{} -> do
          lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
--- 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
--- a/lib/GHCup/Version.hs
+++ b/lib/GHCup/Version.hs
@ -39,6 +39,12 @@ ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/
 stackSetupURL :: URI
 stackSetupURL = [uri|https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml|]

+shimGenURL :: URI
+shimGenURL = [uri|https://downloads.haskell.org/~ghcup/shimgen/shim-2.exe|]
+
+shimGenSHA :: T.Text
+shimGenSHA = T.pack "7c55e201f71860c5babea886007c8fa44b861abf50d1c07e5677eb0bda387a70"
+
 -- | The current ghcup version.
 ghcUpVer :: V.PVP
 ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version
--- a/scripts/dev/update-shell-completions.sh
+++ b/scripts/dev/update-shell-completions.sh
@ -0,0 +1,8 @@
+#!/bin/sh
+
+set -xue
+
+cabal --verbose=0 run ghcup:exe:ghcup -- --bash-completion-script ghcup > scripts/shell-completions/bash
+cabal --verbose=0 run ghcup:exe:ghcup -- --zsh-completion-script ghcup > scripts/shell-completions/zsh
+cabal --verbose=0 run ghcup:exe:ghcup -- --fish-completion-script ghcup > scripts/shell-completions/fish
+
--- a/test/ghcup-test/GHCup/ArbitraryTypes.hs
+++ b/test/ghcup-test/GHCup/ArbitraryTypes.hs
@ -175,10 +175,6 @@ instance Arbitrary Tool where
  arbitrary = genericArbitrary
  shrink    = genericShrink

-instance Arbitrary GlobalTool where
-  arbitrary = genericArbitrary
-  shrink    = genericShrink
-
 instance Arbitrary GHCupInfo where
  arbitrary = genericArbitrary
  shrink    = genericShrink
--- a/test/ghcup-test/golden/unix/GHCupInfo.json
+++ b/test/ghcup-test/golden/unix/GHCupInfo.json
--- a/test/ghcup-test/golden/windows/GHCupInfo.json
+++ b/test/ghcup-test/golden/windows/GHCupInfo.json
@ -4116,17 +4116,7 @@
                    }
                }
            },
-            "globalTools": {
-                "ShimGen": {
-                    "dlCSize": -1,
-                    "dlHash": "xrocmtsmjzgmemxrenf",
-                    "dlOutput": null,
-                    "dlSubdir": {
-                        "RegexDir": "\u0013tt\u0013m-"
-                    },
-                    "dlUri": "https:wjmqkzflmlzetqdcxed"
-                }
-            },
+            "metadataUpdate": "https:ixnnceymgu",
            "toolRequirements": {
                "GHCup": {
                    "3.8.8": {
@ -9309,17 +9299,7 @@
                    }
                }
            },
-            "globalTools": {
-                "ShimGen": {
-                    "dlCSize": -18,
-                    "dlHash": "wbpx",
-                    "dlOutput": null,
-                    "dlSubdir": {
-                        "RegexDir": "[u3"
-                    },
-                    "dlUri": "https:"
-                }
-            },
+            "metadataUpdate": "https:cxnnfovqllcccybmllaikuvluhp",
            "toolRequirements": {
                "HLS": {
                    "2.6.9": {
@ -11308,15 +11288,7 @@
                    }
                }
            },
-            "globalTools": {
-                "ShimGen": {
-                    "dlCSize": null,
-                    "dlHash": "yfwka",
-                    "dlOutput": "c5q",
-                    "dlSubdir": "􊆁M󿅃/|",
-                    "dlUri": "https:yolsdtmmo"
-                }
-            },
+            "metadataUpdate": "http:fbptvnonarkxeszcsn",
            "toolRequirements": {
                "Cabal": {
                    "7.7.4": {
@ -13648,15 +13620,7 @@
                "GHCup": {},
                "Stack": {}
            },
-            "globalTools": {
-                "ShimGen": {
-                    "dlCSize": null,
-                    "dlHash": "hoegok",
-                    "dlOutput": null,
-                    "dlSubdir": "􁃽\u0005]?9\u0001Q:𭲎8ᙣ𑐛'oD\u001a󱧼(𛆎􃥧\u0004\\𢨓[\u001e",
-                    "dlUri": "https:nimu"
-                }
-            },
+            "metadataUpdate": null,
            "toolRequirements": {
                "Cabal": {
                    "3.5.4": {
@ -18153,17 +18117,7 @@
                    }
                }
            },
-            "globalTools": {
-                "ShimGen": {
-                    "dlCSize": null,
-                    "dlHash": "mpljxguikoebuynzv",
-                    "dlOutput": "Q􆹿@i\"%\u0014gb0/PPYE\u001f\u0014KC`-wL",
-                    "dlSubdir": {
-                        "RegexDir": ".`_\u0005󹦸&󲥠\u0014^1Fml\u001e􄋔>o􅟘G"
-                    },
-                    "dlUri": "http:tmcnu"
-                }
-            },
+            "metadataUpdate": "http:ntkddscbgdrjmwymnvpqpmgr",
            "toolRequirements": {
                "GHC": {
                    "6.3.1": {