From d3a20dbc84e51e68e68ec1661035874c5ac5a120 Mon Sep 17 00:00:00 2001 From: Divam Date: Mon, 28 Oct 2024 21:49:47 +0900 Subject: [PATCH 1/4] move makeLenses to Optics module --- lib/GHCup/Types.hs | 3 --- lib/GHCup/Types/Optics.hs | 2 ++ 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 33e496ef..d70c88f6 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -6,7 +6,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DuplicateRecordFields #-} {-| @@ -39,7 +38,6 @@ import Data.Time.Calendar ( Day ) import Data.Text ( Text ) import Data.Versions import GHC.IO.Exception ( ExitCode ) -import Optics ( makeLenses ) import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text) import URI.ByteString #if defined(BRICK) @@ -808,7 +806,6 @@ data CapturedProcess = CapturedProcess } deriving (Eq, Show) -makeLenses ''CapturedProcess data InstallDir = IsolateDir FilePath diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index f6887b20..768faa95 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -42,6 +42,8 @@ makeLenses ''GHCTargetVersion makeLenses ''GHCupInfo +makeLenses ''CapturedProcess + uriSchemeL' :: Lens' (URIRef Absolute) Scheme uriSchemeL' = lensVL uriSchemeL From ba1f52b1179c438cbd5afc051fe009581ccefd5b Mon Sep 17 00:00:00 2001 From: Divam Date: Sun, 3 Nov 2024 14:23:46 +0900 Subject: [PATCH 2/4] Use MapIgnoreUnknownKeys for parsing metadata to maintain backward compatibility This is a Map with custom FromJSON instance that will allow an older ghcup to parse metadata containing new Platform/Architecture types in Map keys --- ghcup.cabal | 1 + lib/GHCup/Download.hs | 5 ++- lib/GHCup/Requirements.hs | 2 +- lib/GHCup/Types.hs | 11 ++++-- lib/GHCup/Types/JSON.hs | 1 + lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs | 37 ++++++++++++++++++++ 6 files changed, 50 insertions(+), 7 deletions(-) create mode 100644 lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs diff --git a/ghcup.cabal b/ghcup.cabal index bba6d915..f040554e 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -137,6 +137,7 @@ library GHCup.Stack GHCup.Types GHCup.Types.JSON + GHCup.Types.JSON.MapIgnoreUnknownKeys GHCup.Types.JSON.Utils GHCup.Types.JSON.Versions GHCup.Types.Optics diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index be6c16a3..f0642eae 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -176,7 +176,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do pure (GHCupInfo mempty ghcupDownloads' Nothing) where fromDownloadInfo :: DownloadInfo -> VersionInfo - fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli)) + fromDownloadInfo dli = let aspec = MapIgnoreUnknownKeys $ M.singleton arch (MapIgnoreUnknownKeys $ M.singleton plat (M.singleton Nothing dli)) in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing Nothing fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo @@ -403,7 +403,7 @@ getDownloadInfo' t v = do let distro_preview f g = let platformVersionSpec = - preview (ix t % ix v % viArch % ix a % ix (f p)) dls + preview (ix t % ix v % viArch % to unMapIgnoreUnknownKeys % ix a % to unMapIgnoreUnknownKeys % ix (f p)) dls mv' = g mv in fmap snd . find @@ -889,4 +889,3 @@ applyMirrors (DM ms) uri@(URI { uriAuthority = Just (Authority { authorityHost = Just (DownloadMirror auth Nothing) -> uri { uriAuthority = Just auth } applyMirrors _ uri = uri - diff --git a/lib/GHCup/Requirements.hs b/lib/GHCup/Requirements.hs index 27bb87ad..573ec316 100644 --- a/lib/GHCup/Requirements.hs +++ b/lib/GHCup/Requirements.hs @@ -44,7 +44,7 @@ getCommonRequirements pr tr = distro_preview f g = let platformVersionSpec = - preview (ix GHC % ix Nothing % ix (f pr)) tr + preview (ix GHC % ix Nothing % to unMapIgnoreUnknownKeys % ix (f pr)) tr mv' = g pr in fmap snd . find diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index d70c88f6..5e989c20 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -89,7 +89,7 @@ instance NFData GHCupInfo type ToolRequirements = Map Tool ToolReqVersionSpec type ToolReqVersionSpec = Map (Maybe Version) PlatformReqSpec -type PlatformReqSpec = Map Platform PlatformReqVersionSpec +type PlatformReqSpec = MapIgnoreUnknownKeys Platform PlatformReqVersionSpec type PlatformReqVersionSpec = Map (Maybe VersionRange) Requirements @@ -114,8 +114,8 @@ instance NFData Requirements -- of nested maps. type GHCupDownloads = Map Tool ToolVersionSpec type ToolVersionSpec = Map GHCTargetVersion VersionInfo -type ArchitectureSpec = Map Architecture PlatformSpec -type PlatformSpec = Map Platform PlatformVersionSpec +type ArchitectureSpec = MapIgnoreUnknownKeys Architecture PlatformSpec +type PlatformSpec = MapIgnoreUnknownKeys Platform PlatformVersionSpec type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo @@ -860,3 +860,8 @@ data VersionPattern = CabalVer | S String deriving (Eq, Show) +-- | Map with custom FromJSON instance which ignores unknown keys +newtype MapIgnoreUnknownKeys k v = MapIgnoreUnknownKeys { unMapIgnoreUnknownKeys :: Map k v } + deriving (Eq, Show, GHC.Generic) + +instance (NFData k, NFData v) => NFData (MapIgnoreUnknownKeys k v) diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index d30f4331..07126634 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -23,6 +23,7 @@ module GHCup.Types.JSON where import GHCup.Types import GHCup.Types.Stack (SetupInfo) +import GHCup.Types.JSON.MapIgnoreUnknownKeys () import GHCup.Types.JSON.Utils import GHCup.Types.JSON.Versions () import GHCup.Prelude.MegaParsec diff --git a/lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs b/lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs new file mode 100644 index 00000000..210a7e31 --- /dev/null +++ b/lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHCup.Types.JSON.MapIgnoreUnknownKeys where + +import GHCup.Types + +import Data.Aeson hiding (Key) +import Data.Aeson.Types hiding (Key) + +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Map.Strict as Map + +-- | Create a Map ignoring KeyValue pair which fail at parse of the key +-- But if the key is parsed, the failures of parsing the value will not be ignored +instance (Ord k, FromJSONKey k, FromJSON v) => FromJSON (MapIgnoreUnknownKeys k v) where + parseJSON = withObject "MapIgnoreUnknownKeys" $ \obj -> do + m <- case fromJSONKey of + FromJSONKeyTextParser f -> + let doParse k v m = case parseMaybe f (Key.toText k) of + Just k' -> Map.insert k' <$> parseJSON v <*> m + Nothing -> m + in KeyMap.foldrWithKey doParse (pure Map.empty) obj + FromJSONKeyValue f -> + let doParse k v m = case parseMaybe f (toJSON k) of + Just k' -> Map.insert k' <$> parseJSON v <*> m + Nothing -> m + in KeyMap.foldrWithKey doParse (pure Map.empty) obj + -- FromJSONKeyCoerce and FromJSONKeyText always parse to Success; hence use instance of Map + _ -> parseJSON (Object obj) + pure $ MapIgnoreUnknownKeys m + +instance (ToJSON (Map.Map k v)) => ToJSON (MapIgnoreUnknownKeys k v) where + toJSON = toJSON . unMapIgnoreUnknownKeys From d1f92d496d80c63d1255bcd335c492290397ee16 Mon Sep 17 00:00:00 2001 From: Divam Date: Sun, 3 Nov 2024 15:13:12 +0900 Subject: [PATCH 3/4] Add flag 'strict-metadata-parsing' to enable use of normal Map instance This is for use in ghcup-metadata validation code --- ghcup.cabal | 10 ++++++++++ lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs | 8 ++++++++ 2 files changed, 18 insertions(+) diff --git a/ghcup.cabal b/ghcup.cabal index f040554e..aec5e8a7 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -54,6 +54,13 @@ flag internal-downloader default: False manual: True +flag strict-metadata-parsing + description: + Don't ignore unknown keys in metadata. Useful for metadata testing. + + default: False + manual: True + flag no-exe description: Don't build any executables default: False @@ -278,6 +285,9 @@ library cpp-options: -DBRICK build-depends: vty ^>=6.0 || ^>=6.1 || ^>=6.2 + if (flag(strict-metadata-parsing)) + cpp-options: -DSTRICT_METADATA_PARSING + library ghcup-optparse import: app-common-depends exposed-modules: diff --git a/lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs b/lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs index 210a7e31..f61063cf 100644 --- a/lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs +++ b/lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} @@ -14,6 +15,12 @@ import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Map.Strict as Map +#if defined(STRICT_METADATA_PARSING) +-- | Use the instance of Map +instance (FromJSON (Map.Map k v)) => FromJSON (MapIgnoreUnknownKeys k v) where + parseJSON = fmap MapIgnoreUnknownKeys . parseJSON +#else + -- | Create a Map ignoring KeyValue pair which fail at parse of the key -- But if the key is parsed, the failures of parsing the value will not be ignored instance (Ord k, FromJSONKey k, FromJSON v) => FromJSON (MapIgnoreUnknownKeys k v) where @@ -32,6 +39,7 @@ instance (Ord k, FromJSONKey k, FromJSON v) => FromJSON (MapIgnoreUnknownKeys k -- FromJSONKeyCoerce and FromJSONKeyText always parse to Success; hence use instance of Map _ -> parseJSON (Object obj) pure $ MapIgnoreUnknownKeys m +#endif instance (ToJSON (Map.Map k v)) => ToJSON (MapIgnoreUnknownKeys k v) where toJSON = toJSON . unMapIgnoreUnknownKeys From a1facfac7ae68dfd494e336fd12fc925407c6d56 Mon Sep 17 00:00:00 2001 From: Divam Date: Sun, 3 Nov 2024 15:19:17 +0900 Subject: [PATCH 4/4] Arbitrary instances for MapIgnoreUnknownKeys --- test/ghcup-test/GHCup/ArbitraryTypes.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/test/ghcup-test/GHCup/ArbitraryTypes.hs b/test/ghcup-test/GHCup/ArbitraryTypes.hs index 4bd1f0d4..916add68 100644 --- a/test/ghcup-test/GHCup/ArbitraryTypes.hs +++ b/test/ghcup-test/GHCup/ArbitraryTypes.hs @@ -196,6 +196,11 @@ instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Version) v) whe instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map Platform v) where arbitrary = resize 8 $ M.fromList <$> arbitrary +instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (MapIgnoreUnknownKeys Platform v) where + arbitrary = resize 8 $ MapIgnoreUnknownKeys . M.fromList <$> arbitrary + +instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (MapIgnoreUnknownKeys Architecture v) where + arbitrary = resize 8 $ MapIgnoreUnknownKeys . M.fromList <$> arbitrary + instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Versioning) v) where arbitrary = resize 8 $ M.fromList <$> arbitrary -