Merge remote-tracking branch 'origin/pr/1144'

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:

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
-

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

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)

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

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

lib/GHCup/Types/Optics.hs

@@ -42,6 +42,8 @@ makeLenses ''GHCTargetVersion
 
 makeLenses ''GHCupInfo
 
+makeLenses ''CapturedProcess
+
 uriSchemeL' :: Lens' (URIRef Absolute) Scheme
 uriSchemeL' = lensVL uriSchemeL
 

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
-