From a7c384b2408f2a512ecaee9d1287a9bbf5d41290 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Thu, 6 Jun 2024 16:01:08 +1200
Subject: [PATCH] Improve handling of invalid FontConfig data.

---
 lib/Graphics/Text/Font/Choose/CharSet.hs |  4 ++--
 lib/Graphics/Text/Font/Choose/FontSet.hs | 15 ++++++++++-----
 lib/Graphics/Text/Font/Choose/LangSet.hs | 17 ++++++++++++-----
 lib/Graphics/Text/Font/Choose/Pattern.hs | 20 +++++++++++++-------
 4 files changed, 37 insertions(+), 19 deletions(-)

diff --git a/lib/Graphics/Text/Font/Choose/CharSet.hs b/lib/Graphics/Text/Font/Choose/CharSet.hs
index a8de4cb..e18f3ac 100644
--- a/lib/Graphics/Text/Font/Choose/CharSet.hs
+++ b/lib/Graphics/Text/Font/Choose/CharSet.hs
@@ -3,7 +3,7 @@ module Graphics.Text.Font.Choose.CharSet(
     ) where
 
 import Data.IntSet (IntSet, union)
-import qualified Data.IntSet as IntSet
+import Data.IntSet as IntSet
 
 import Data.Char (isHexDigit, ord, chr)
 import Numeric (readHex)
@@ -60,7 +60,7 @@ instance MessagePack CharSet' where
     fromObject msg =
         CharSet' <$> IntSet.fromAscList <$> diffDecompress 0 <$> fromObject msg
 instance Arbitrary CharSet' where
-    arbitrary = CharSet' <$> IntSet.fromList <$> map (succ . abs) <$> arbitrary
+    arbitrary = CharSet' <$> IntSet.fromList <$> Prelude.map (succ . abs) <$> arbitrary
 
 validCharSet' :: CharSet' -> Bool
 validCharSet' (CharSet' self) =
diff --git a/lib/Graphics/Text/Font/Choose/FontSet.hs b/lib/Graphics/Text/Font/Choose/FontSet.hs
index a3d15fc..4cfb1d1 100644
--- a/lib/Graphics/Text/Font/Choose/FontSet.hs
+++ b/lib/Graphics/Text/Font/Choose/FontSet.hs
@@ -6,7 +6,7 @@ module Graphics.Text.Font.Choose.FontSet(
 import Graphics.Text.Font.Choose.Pattern hiding (map)
 import Graphics.Text.Font.Choose.Config
 import Graphics.Text.Font.Choose.ObjectSet
-import Graphics.Text.Font.Choose.CharSet
+import Graphics.Text.Font.Choose.CharSet as CS hiding (map)
 import Graphics.Text.Font.Choose.Internal.FFI
 
 import Foreign.C.String (CString)
@@ -29,22 +29,27 @@ validFontSet :: FontSet -> Bool
 validFontSet = all validPattern
 
 fontSetList :: Config -> [FontSet] -> Pattern -> ObjectSet -> FontSet
-fontSetList a b c d =
+fontSetList a b c d | all validFontSet b =
     fromMessage0 $ arg d $ arg c $ arg b $ withForeignPtr' fcFontSetList a
+  | otherwise = []
 
 foreign import capi "fontconfig-wrap.h" fcFontSetList ::
         Ptr Config' -> CString -> Int -> CString -> Int -> CString -> Int ->
         Ptr Int -> CString
 
 fontSetMatch :: Config -> [FontSet] -> Pattern -> Maybe FontSet
-fontSetMatch a b c = fromMessage $ arg c $ arg b $ withForeignPtr' fcFontSetMatch a
+fontSetMatch a b c | all validFontSet b && validPattern c =
+        fromMessage $ arg c $ arg b $ withForeignPtr' fcFontSetMatch a
+    | otherwise = Nothing
 
 foreign import capi "fontconfig-wrap.h" fcFontSetMatch ::
         Ptr Config' -> CString -> Int -> CString -> Int -> Ptr Int -> CString
 
 fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> (Maybe FontSet, CharSet')
-fontSetSort a b c d = fromMessage0 $ flip withForeignPtr' a $ \a' ->
-        arg b $ \b' x -> arg c $ \c' y -> fcFontSetSort a' b' x c' y d
+fontSetSort a b c d | all validFontSet b && validPattern c =
+        fromMessage0 $ flip withForeignPtr' a $ \a' ->
+            arg b $ \b' x -> arg c $ \c' y -> fcFontSetSort a' b' x c' y d
+    | otherwise = (Nothing, CharSet' CS.empty)
 
 foreign import capi "fontconfig-wrap.h" fcFontSetSort ::
         Ptr Config' -> CString -> Int -> CString -> Int -> Bool -> Ptr Int -> CString
diff --git a/lib/Graphics/Text/Font/Choose/LangSet.hs b/lib/Graphics/Text/Font/Choose/LangSet.hs
index a16f1f5..7270a28 100644
--- a/lib/Graphics/Text/Font/Choose/LangSet.hs
+++ b/lib/Graphics/Text/Font/Choose/LangSet.hs
@@ -9,7 +9,7 @@ import qualified Data.Set as S
 import Data.MessagePack (MessagePack(..))
 import Test.QuickCheck (Arbitrary(..), elements, listOf)
 import Graphics.Text.Font.Choose.StrSet (StrSet(..))
-import Graphics.Text.Font.Choose.CharSet (CharSet')
+import Graphics.Text.Font.Choose.CharSet as CS (CharSet'(..), empty)
 
 import Foreign.C.String (CString)
 import Foreign.Ptr (Ptr)
@@ -21,9 +21,11 @@ type LangSet = Set String
 newtype LangSet' = LangSet' { unLangSet :: LangSet } deriving (Eq, Show, Read)
 
 validLangSet :: LangSet -> Bool
-validLangSet x = all (`elem` unStrSet langs) x && not (null x)
+validLangSet x = all validLang x && not (null x)
 validLangSet' :: LangSet' -> Bool
 validLangSet' = validLangSet . unLangSet
+validLang :: String -> Bool
+validLang = (`elem` unStrSet langs)
 
 instance MessagePack LangSet' where
     toObject = toObject . S.toList . unLangSet
@@ -39,12 +41,16 @@ i2cmp 2 = SameTerritory
 i2cmp _ = throw ErrOOM
 
 cmp :: LangSet' -> LangSet' -> LangComparison
-cmp a b = i2cmp $ withMessage fcLangSetCompare [a, b]
+cmp a b | valid a && valid b = i2cmp $ withMessage fcLangSetCompare [a, b]
+    | otherwise = DifferentLang
+  where valid = validLangSet'
 
 foreign import capi "fontconfig-wrap.h" fcLangSetCompare :: CString -> Int -> Int
 
 has :: LangSet' -> String -> LangComparison
-has a b = i2cmp $ flip withCString' b $ withMessage fcLangSetHasLang a
+has a b | validLangSet' a && validLang b =
+        i2cmp $ flip withCString' b $ withMessage fcLangSetHasLang a
+    | otherwise = DifferentLang
 
 foreign import capi "fontconfig-wrap.h" fcLangSetHasLang :: CString -> Int -> CString -> Int
 
@@ -64,6 +70,7 @@ normalize = peekCString' . withCString' fcLangNormalize
 foreign import capi "fontconfig-wrap.h" fcLangNormalize :: CString -> CString
 
 langCharSet :: String -> CharSet'
-langCharSet = fromMessage0 . withCString' fcLangGetCharSet
+langCharSet a | validLang a = fromMessage0 $ withCString' fcLangGetCharSet a
+    | otherwise = CharSet' CS.empty
 
 foreign import capi "fontconfig-wrap.h" fcLangGetCharSet :: CString -> Ptr Int -> CString
diff --git a/lib/Graphics/Text/Font/Choose/Pattern.hs b/lib/Graphics/Text/Font/Choose/Pattern.hs
index 35f4fef..72a839b 100644
--- a/lib/Graphics/Text/Font/Choose/Pattern.hs
+++ b/lib/Graphics/Text/Font/Choose/Pattern.hs
@@ -85,15 +85,18 @@ getValues :: ToValue v => Text -> Pattern -> [v]
 getValues key self = Mb.mapMaybe (fromValue . snd) $ fromMaybe [] $ M.lookup key self
 
 equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
-equalSubset a b os = case withMessage fcPatternEqualSubset [toObject a, toObject b, toObject os] of
-    0 -> False
-    1 -> True
-    _ -> throw ErrOOM
+equalSubset a b os | validPattern a && validPattern b =
+    case withMessage fcPatternEqualSubset [toObject a, toObject b, toObject os] of
+        0 -> False
+        1 -> True
+        _ -> throw ErrOOM
+  | otherwise = False
 
 foreign import capi "fontconfig-wrap.h" fcPatternEqualSubset :: CString -> Int -> Int
 
 defaultSubstitute :: Pattern -> Pattern
-defaultSubstitute = fromMessage0 . withMessage fcDefaultSubstitute
+defaultSubstitute a | validPattern a = fromMessage0 $ withMessage fcDefaultSubstitute a
+    | otherwise = a
 
 foreign import capi "fontconfig-wrap.h" fcDefaultSubstitute :: CString -> Int -> Ptr Int -> CString
 
@@ -103,12 +106,15 @@ nameParse = fromMessage0 . withCString' fcNameParse
 foreign import capi "fontconfig-wrap.h" fcNameParse :: CString -> Ptr Int -> CString
 
 nameUnparse :: Pattern -> String
-nameUnparse = peekCString' . withMessage fcNameUnparse
+nameUnparse a | validPattern a = peekCString' $ withMessage fcNameUnparse a
+    | otherwise = ""
 
 foreign import capi "fontconfig-wrap.h" fcNameUnparse :: CString -> Int -> CString
 
 nameFormat :: Pattern -> String -> String
-nameFormat a b = peekCString' $ flip withCString' b $ withMessage fcNameFormat a
+nameFormat a b
+    | validPattern a = peekCString' $ flip withCString' b $ withMessage fcNameFormat a
+    | otherwise = ""
 
 foreign import capi "fontconfig-wrap.h" fcNameFormat :: CString -> Int -> CString -> CString
 
-- 
2.30.2