Make get @Char fail on invalid encodings

src/Data/Binary/Class.hs

@@ -2,11 +2,12 @@
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE Trustworthy #-}
 
 #if MIN_VERSION_base(4,10,0)
 {-# LANGUAGE MultiWayIf #-}
@@ -57,6 +58,7 @@
 import Prelude hiding (Foldable(..))
 import Data.Foldable (Foldable(..))
 
+import Data.Char (chr)
 import Data.Word
 import Data.Bits
 import Data.Int
@@ -499,35 +501,44 @@
 
 ------------------------------------------------------------------------
 
--- Char is serialised as UTF-8
+-- | Uses WTF-8 (like UTF-8, but surrogates are allowed).
 instance Binary Char where
     put = putCharUtf8
     putList str = put (length str) <> putStringUtf8 str
     get = do
-        let getByte = liftM (fromIntegral :: Word8 -> Int) get
-            shiftL6 = flip shiftL 6 :: Int -> Int
-        w <- getByte
-        r <- case () of
-                _ | w < 0x80  -> return w
-                  | w < 0xe0  -> do
-                                    x <- liftM (xor 0x80) getByte
-                                    return (x .|. shiftL6 (xor 0xc0 w))
-                  | w < 0xf0  -> do
-                                    x <- liftM (xor 0x80) getByte
-                                    y <- liftM (xor 0x80) getByte
-                                    return (y .|. shiftL6 (x .|. shiftL6
-                                            (xor 0xe0 w)))
-                  | otherwise -> do
-                                x <- liftM (xor 0x80) getByte
-                                y <- liftM (xor 0x80) getByte
-                                z <- liftM (xor 0x80) getByte
-                                return (z .|. shiftL6 (y .|. shiftL6
-                                        (x .|. shiftL6 (xor 0xf0 w))))
-        getChr r
+        w <- fmap fromIntegral getWord8
+        if
+            | w < 0x80 -> getChr w
+            | w < 0xc2 -> invalid -- continuation byte or overlong encoding
+            | w < 0xe0 -> do
+                x <- getWord8 >>= continuationByte
+                getChr ((x .&. 0x3f) .|. ((w .&. 0x1f) `shiftL` 6))
+            | w < 0xf0  -> do
+                x <- getWord8 >>= continuationByte
+                when (w == 0xe0 && x < 0xa0) invalid -- overlong encoding
+                y <- getWord8 >>= continuationByte
+                getChr ((y .&. 0x3f) .|. ((x .&. 0x3f) `shiftL` 6) .|. ((w .&. 0x0f) `shiftL` 12))
+            | w < 0xf5 -> do
+                x <- getWord8 >>= continuationByte
+                when (w == 0xf0 && x < 0x90) invalid -- overlong encoding
+                when (w == 0xf4 && x > 0x8f) invalid -- outside of Unicode range
+                y <- getWord8 >>= continuationByte
+                z <- getWord8 >>= continuationByte
+                getChr ((z .&. 0x3f) .|. ((y .&. 0x3f) `shiftL` 6) .|. ((x .&. 0x3f) `shiftL` 12) .|. ((w .&. 0x07) `shiftL` 18))
+            | otherwise -> invalid
       where
-        getChr w
-          | w <= 0x10ffff = return $! toEnum $ fromEnum w
-          | otherwise = fail "Not a valid Unicode code point!"
+        invalid :: Get a
+        invalid = fail "invalid Char encoding"
+
+        continuationByte :: Word8 -> Get Int
+        continuationByte x =
+            let x' = x .&. 0xc0
+            in if x' == 0x80
+                then pure (fromIntegral x)
+                else invalid -- no continuation byte
+
+        getChr :: Int -> Get Char
+        getChr i = pure $! chr i
 
 ------------------------------------------------------------------------
 -- Instances for the first few tuples
@@ -844,9 +855,9 @@
 
 #if __GLASGOW_HASKELL__ < 901
 -- | @since 0.8.4.0
 instance Binary a => Binary (Semigroup.Option a) where
   get = fmap Semigroup.Option get
   put = put . Semigroup.getOption
 #endif
 
 -- | @since 0.8.4.0

tests/QC.hs

@@ -19,7 +19,7 @@
 import           Data.ByteString.Short                (ShortByteString)
 import           Data.Int
 import           Data.Ratio
 import           Data.Typeable
 import           Data.Word
 import           System.IO.Unsafe
 
@@ -29,7 +29,7 @@
 import           Numeric.Natural
 #endif
 
 import           GHC.Exts (Array#, Word#)
 import           GHC.Fingerprint
 import           GHC.Generics (Generic)
 
@@ -187,7 +187,7 @@
     , typeRep (Proxy :: Proxy (Array# Int))
     ]
 
 instance Arbitrary TypeRep where
     arbitrary = elements atomicTypeReps
 #else
 testTypeable :: Test
@@ -742,6 +742,14 @@
         , testTypeable
 
         , testGroup "Generic"
-            [ testProperty "Generic256" $ prop_Generic256
+            [ testProperty "Generic256" prop_Generic256
+            ]
+
+        , testGroup "Char"
+            [ testProperty "encodings are unique" $
+                withMaxSize 4 $ \bs ->
+                  case runGetOrFail (get :: Get Char) bs of
+                    Left _ -> discard
+                    Right (_, n, x) -> runPut (put x) === L.take n bs
             ]
         ]