9.10

Opentype/Fileformat/Cmap.hs

@@ -2,8 +2,7 @@ module Opentype.Fileformat.Cmap where
 import Opentype.Fileformat.Types
 import Data.Binary
 import Data.Binary.Put
-import Data.List (sort, mapAccumL, foldl')
-import Data.Either (either)
+import Data.List (sort, mapAccumL)
 import Control.Monad
 import Data.Traversable (for)
 import Data.Foldable (for_, traverse_)
@@ -28,7 +27,7 @@ import Data.Int
 -- subtables are present. Each subtable is in one of seven possible
 -- formats and begins with a format code indicating the format
 -- used.
--- 
+--
 -- The `platformID` and platform-specific `encodingID` in the header
 -- entry (and, in the case of the Macintosh platform, the `macLanguage`
 -- field in the subtable itself) are used to specify a particular
@@ -37,7 +36,7 @@ import Data.Int
 -- `CmapTable`.
 --
 -- When `platformID` is `UnicodePlatform`, `encodingID` is interpreted as follows:
--- 
+--
 --  * 0: Default semantics
 --  * 1: Version 1.1 semantics
 --  * 2: ISO 10646 1993 semantics (deprecated)
@@ -47,7 +46,7 @@ import Data.Int
 --  * 6: Full Unicode coverage (used with type 13.0 cmaps by OpenType)
 --
 -- When `platformID` `MacintoshPlatform`, the `encodingID` is a QuickDraw script code.
--- 
+--
 -- Note that the use of the Macintosh platformID is currently
 -- discouraged. Subtables with a Macintosh platformID are only
 -- required for backwards compatibility with QuickDraw and will be
@@ -92,7 +91,7 @@ instance Eq CMap where
   (CMap pfID encID lang _ _ _) == (CMap pfID2 encID2 lang2 _ _ _) =
     (pfID, encID, lang) == (pfID2, encID2, lang2)
 
-data MapFormat = 
+data MapFormat =
   -- | 8 bit encoding, contiguous block of bytes.  /LEGACY ONLY./
   MapFormat0 |
   -- | mixed 8\/16 bit encoding with gaps.  /LEGACY ONLY./
@@ -135,7 +134,7 @@ readCmapTable :: Strict.ByteString -> Either String CmapTable
 readCmapTable bs = do
   version <- index16 bs 0
   when (version /= 0) $
-    fail "unsupported cmap version."
+    Left "unsupported cmap version."
   n <- index16 bs 1
   entries <- for [0..n-1] $ \i -> do
     pfID <- toPf =<< (index16 bs $ 2 + i*4)
@@ -166,16 +165,15 @@ readCmap bs_ = do
   c <- index16 bs_ 0
   let bs | (c >= 8 && c < 14) = Strict.drop 8 bs_
          | otherwise = Strict.drop 4 bs_
-  either fail return $
-    case c of 
-      0 -> getMap0 bs
-      2 -> getMap2 bs
-      4 -> getMap4 bs
-      6 -> getMap6 bs
-      8 -> getMap8 bs
-      10 -> getMap10 bs
-      12 -> getMap12 bs
-      i -> fail $ "unsupported map encoding " ++ show i
+  case c of
+    0 -> getMap0 bs
+    2 -> getMap2 bs
+    4 -> getMap4 bs
+    6 -> getMap6 bs
+    8 -> getMap8 bs
+    10 -> getMap10 bs
+    12 -> getMap12 bs
+    i -> Left $ "unsupported map encoding " ++ show i
 
 subIntMap :: Word32 -> Word32 -> WordMap GlyphID -> WordMap GlyphID
 subIntMap from to intMap =
@@ -193,7 +191,7 @@ putCodes start end _
 putCodes start end [] = do
   putWord16be 0
   putCodes (start+1) end []
-      
+
 putCodes start end l@((i, code):rest)
   | start < i = do putWord16be 0
                    putCodes (start+1) end l
@@ -253,13 +251,13 @@ putMap2 cmap = do
         IS.toList $ fst $
         IS.split 255 (multiByte cmap)
       subTableCodes =
-        filter ((/= 0) . entryCount) $ 
+        filter ((/= 0) . entryCount) $
         flip map highBytes $ \hb ->
         let subMap = subIntMap (fromIntegral hb `shift` 8)
                      (fromIntegral hb `shift` 8 .|. 0xff) $
                      glyphMap cmap
             (fstCode, lstCode)
-              | M.null subMap = (0, -1)
+              | M.null subMap = (0, maxBound)
               | otherwise = (fst $ M.findMin subMap,
                              fst $ M.findMax subMap)
             ec = lstCode - fstCode + 1
@@ -273,7 +271,7 @@ putMap2 cmap = do
       size :: Word16
       size = 518 + 8 * (fromIntegral $ length subTables) + 2 * sum (map entryCount subTables)
       calcOffset prev st = st { rangeOffset = rangeOffset prev - 8 + 2*entryCount prev }
-        
+
 getMap2 :: Strict.ByteString -> Either String CMap
 getMap2 bs = do
   lang <- index16 bs 0
@@ -290,8 +288,8 @@ getMap2 bs = do
       Right (fromIntegral $ fstCode + entry, if p == 0 then 0 else p + delta)
   let im = M.fromAscList $ filter ((/= 0).snd) $ concat l
       is = IS.fromAscList $ map fromIntegral highBytes
-  Right $ CMap UnicodePlatform 0 lang MapFormat2 is im      
-      
+  Right $ CMap UnicodePlatform 0 lang MapFormat2 is im
+
 data Segment4 = RangeSegment Word16 Word16 Word16
               | CodeSegment Word16 Word16 [Word16]
               deriving Show
@@ -316,7 +314,7 @@ getSegments :: [(Word32, Word16)] -> [Segment4]
 getSegments [] = [RangeSegment 0xffff 1 0]
 getSegments l@((start, c):_)
   | fromIntegral end - start >= 4 ||
-    lc <= end-start+1 = 
+    lc <= end-start+1 =
       RangeSegment (fromIntegral start) (fromIntegral end-fromIntegral start+1) c :
       getSegments r
   | otherwise =
@@ -334,7 +332,7 @@ data Segment4layout = Segment4layout {
   s4idRangeOffset :: Word16,
   s4glyphIndex :: [GlyphID] }
   deriving Show
-  
+
 putMap4 :: CMap -> PutM ()
 putMap4 cmap = do
   putWord16be 4
@@ -401,7 +399,7 @@ putMap6 cmap = do
     lastCode = fromIntegral $
       min (fromIntegral (maxBound :: Word16)::Word32) $
       fst $ M.findMax (glyphMap cmap)
-    
+
 getMap6 :: Strict.ByteString -> Either String CMap
 getMap6 bs = do
   lang <- index16 bs 0
@@ -431,13 +429,13 @@ readPacked bs =
    i <- [0..7],
    a .&. (1 `shift` i) /= 0
   ]
-      
+
 
 findRanges :: [(Word32, GlyphID)] -> [(Word32, Word32, GlyphID)]
 findRanges [] = []
 findRanges l@((i,c):_) = (i, i2, c) : findRanges next
   where (i2, next) = findRange i (fromIntegral c-fromIntegral i) l
-  
+
 putMap8 :: CMap -> PutM ()
 putMap8 cmap = do
   putWord16be 8
@@ -524,4 +522,3 @@ getMap12 bs = do
     glyph <- index32 bs (i*3 + 4)
     return [(fromIntegral c, fromIntegral $ glyph+c-start) | c <- [start .. end]]
   Right $ CMap UnicodePlatform 0 lang MapFormat8 IS.empty gmap
-

Opentype/Fileformat/Name.hs

@@ -1,7 +1,7 @@
 module Opentype.Fileformat.Name
 where
 import Opentype.Fileformat.Types
-import Data.List (sort, foldl')
+import Data.List (sort)
 import Data.Maybe (fromMaybe)
 import Data.Word
 import Control.Monad
@@ -54,7 +54,7 @@ instance Ord NameRecord where
 instance Eq NameRecord where
   (NameRecord pID eID lang nID _) ==
     (NameRecord pID2 eID2 lang2 nID2 _) =
-    (pID, eID, lang, nID) == (pID2, eID2, lang2, nID2)    
+    (pID, eID, lang, nID) == (pID2, eID2, lang2, nID2)
 
 putNameTable :: NameTable -> Put
 putNameTable (NameTable records_) = do
@@ -76,29 +76,29 @@ putNameTable (NameTable records_) = do
           (\(offset, (noDups2, mp)) r ->
              if HM.member (nameString r) mp
              then (offset, (noDups2, mp))
-             else (Strict.length (nameString r) + offset, 
+             else (Strict.length (nameString r) + offset,
                     (nameString r:noDups2, HM.insert (nameString r) offset mp)))
           (0, ([], HM.empty)) records
-        
+
 
 readNameTable :: Strict.ByteString -> Either String NameTable
 readNameTable bs = do
   version <- index16 bs 0
-  when (version > 0) $ fail "Unsupported name table format."
-  len <- index16 bs 1 
+  when (version > 0) $ Left "Unsupported name table format."
+  len <- index16 bs 1
   storage <- index16 bs 2
   records <- for [0..len-1] $ \i -> do
     pf <- toPf =<< index16 bs (3 + i*6)
     enc <- index16 bs $ 3 + i*6 + 1
     lang <- index16 bs $ 3 + i*6 + 2
     nID <- index16 bs $ 3 + i*6 + 3
-    len2 <- index16 bs $ 3 + i*6 + 4 
+    len2 <- index16 bs $ 3 + i*6 + 4
     offset <- index16 bs $ 3 + i*6 + 5
     Right (offset, len2, NameRecord pf enc lang nID)
   records2 <- for records $
     \(offset, len2, r) ->
-      if storage+offset+len2 > fromIntegral (Strict.length bs)
-        then Left "string storage bounds exceeded"
+      if fromIntegral (storage+offset+len2) > Strict.length bs
+        then Left $ "overflow error: name record in storage at (" <> show storage <> ") at offset (" <> show offset <> ") with length (" <> show len2 <> ") exceeds input length (" <> show (Strict.length bs) <> ")"
         else Right $ r (Strict.take (fromIntegral len2) $
                         Strict.drop (fromIntegral $ offset+storage) bs)
   return $ NameTable records2

opentype.cabal

@@ -13,18 +13,18 @@ description: This library supports loading and writing of opentype files.
 category: Typography
 author: Kristof Bastiaensen
 data-dir: ""
- 
+
 source-repository head
   type: git
   location: https://github.com/kuribas/haskell-opentype
- 
+
 library
   build-depends:
                 base >=3 && <5,
                 binary >=0.8.1.0,
                 bytestring >0.10.0,
                 containers >=0.5.3,
-                ghc >=7.10.0,
+                ghc >=9.10.0,
                 microlens > 0.4.0.0,
                 microlens-th > 0.4.0.0,
                 mtl >= 2.2.1,
@@ -49,11 +49,12 @@ library
     Opentype.Fileformat.Post
     Opentype.Fileformat.Kern
     Opentype.Fileformat.OS2
-    Opentype.Fileformat.Unicode.PostNames    
+    Opentype.Fileformat.Unicode.PostNames
   ghc-options: -Wall
- 
+
 test-suite test
   type: exitcode-stdio-1.0
   main-is: test.hs
   buildable: True
   hs-source-dirs: tests
+  build-depends: base