diff --git a/ghcup.cabal b/ghcup.cabal index 6e97f168..1805e35b 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -61,6 +61,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 @@ -144,6 +151,7 @@ library GHCup.Stack GHCup.Types GHCup.Types.JSON + GHCup.Types.JSON.MapIgnoreUnknownKeys GHCup.Types.JSON.Utils GHCup.Types.JSON.Versions GHCup.Types.Optics @@ -284,6 +292,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/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 33e496ef..5e989c20 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) @@ -91,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 @@ -116,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 @@ -808,7 +806,6 @@ data CapturedProcess = CapturedProcess } deriving (Eq, Show) -makeLenses ''CapturedProcess data InstallDir = IsolateDir FilePath @@ -863,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..f61063cf --- /dev/null +++ b/lib/GHCup/Types/JSON/MapIgnoreUnknownKeys.hs @@ -0,0 +1,45 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE CPP #-} +{-# 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 + +#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 + 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 +#endif + +instance (ToJSON (Map.Map k v)) => ToJSON (MapIgnoreUnknownKeys k v) where + toJSON = toJSON . unMapIgnoreUnknownKeys 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 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 -