Correct validation of unicode escapes (#1549)

Author: SiriusStarr

dhall/src/Dhall/Parser/Expression.hs

@@ -597,21 +597,28 @@ parsers embedded = Parsers {..}
 
                     let toNumber = Data.List.foldl' (\x y -> x * 16 + y) 0
 
-                    let fourCharacterEscapeSequence =
-                            fmap toNumber (Control.Monad.replicateM 4 hexNumber)
+                    let fourCharacterEscapeSequence = do
+                            ns <- Control.Monad.replicateM 4 hexNumber
+                            
+                            let number = toNumber ns
+
+                            Control.Monad.guard (validCodepoint number)
+                                <|> fail "Invalid Unicode code point"
+
+                            return number
 
                     let bracedEscapeSequence = do
                             _  <- char '{'
                             ns <- some hexNumber
 
                             let number = toNumber ns
 
-                            Control.Monad.guard (number <= 0x10FFFF && validCodepoint (Char.chr number))
+                            Control.Monad.guard (number <= 0x10FFFD && validCodepoint number)
                                 <|> fail "Invalid Unicode code point"
 
                             _  <- char '}'
 
-                            return (toNumber ns)
+                            return number
 
                     n <- bracedEscapeSequence <|> fourCharacterEscapeSequence
 

dhall/src/Dhall/Parser/Token.hs

@@ -110,6 +110,7 @@ module Dhall.Parser.Token (
 import           Dhall.Parser.Combinators
 
 import Control.Applicative (Alternative(..), optional)
+import Data.Bits ((.&.))
 import Data.Functor (void)
 import Data.Semigroup (Semigroup(..))
 import Data.Text (Text)
@@ -135,12 +136,14 @@ import Prelude hiding (const, pi)
 
 import qualified Text.Parser.Token
 
--- | Returns `True` if the given `Char` is a valid Unicode codepoint
-validCodepoint :: Char -> Bool
+-- | Returns `True` if the given `Int` is a valid Unicode codepoint
+validCodepoint :: Int -> Bool
 validCodepoint c =
-    not (category == Char.Surrogate || category == Char.NotAssigned)
+    not (category == Char.Surrogate 
+      || c .&. 0xFFFE == 0xFFFE 
+      || c .&. 0xFFFF == 0xFFFF)
   where
-    category = Char.generalCategory c
+    category = Char.generalCategory (Char.chr c)
 
 {-| Parse 0 or more whitespace characters (including comments)