msyds/haskell-wasm
1
0
Fork 0
forked from GitHub/haskell-wasm
Code Pull Requests Activity

check if name is valid utf8 string

Browse Source
This commit is contained in:
Ilya Rezvov
2018-04-16 14:35:05 -07:00
parent be47aa7d43
commit 035ffe05da
3 changed files with 42 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Lexer.x
+12 -6
View File
@@ -15,6 +15,7 @@ import Control.Applicative ((<$>))
import Control.Monad (when)
import Numeric.IEEE (infinity, nan)
import Language.Wasm.FloatUtils (makeNaN)
import Data.Word (Word8)
import qualified Debug.Trace as Debug
@@ -190,7 +191,7 @@ appendFromHead (_pos, _rest, inp, _) _len = do
appendDoubleHexChar :: AlexAction Lexeme
appendDoubleHexChar (_pos, _rest, inp, _) _len = do
addCharToLexerStringValue $ Char.chr $ fromIntegral $ readHexFromPrefix 2 $ LBSUtf8.drop 1 inp
addCharCodeToLexerStringValue $ fromIntegral $ readHexFromPrefix 2 $ LBSUtf8.drop 1 inp
alexMonadScan
-- TODO: add a predicate with code ranges check
@@ -209,8 +210,8 @@ endStringLiteral :: AlexAction Lexeme
endStringLiteral (pos, _, _inp, _) _len = do
alexSetStartCode defaultStartCode
setLexerStringFlag False
str <- LBSUtf8.fromString . reverse <$> getLexerStringValue
setLexerStringValue ""
str <- LBS.pack . reverse <$> getLexerStringValue
setLexerStringValue []
return $ Lexeme pos $ TStringLit str
tokenStr :: (LBS.ByteString -> Token) -> AlexAction Lexeme
@@ -236,7 +237,7 @@ data Lexeme = Lexeme { pos :: AlexPosn, tok :: Token } deriving (Show, Eq)
data AlexUserState = AlexUserState {
lexerCommentDepth :: Int,
lexerStringValue :: String,
lexerStringValue :: [Word8],
lexerIsString :: Bool
}
@@ -262,15 +263,20 @@ setLexerStringFlag :: Bool -> Alex ()
setLexerStringFlag isString = Alex $ \s ->
Right (s{ alex_ust=(alex_ust s){ lexerIsString = isString } }, ())
getLexerStringValue :: Alex String
getLexerStringValue :: Alex [Word8]
getLexerStringValue = Alex $ \s@AlexState{alex_ust=ust} -> Right (s, lexerStringValue ust)
setLexerStringValue :: String -> Alex ()
setLexerStringValue :: [Word8] -> Alex ()
setLexerStringValue ss = Alex $ \s ->
Right (s{ alex_ust=(alex_ust s){ lexerStringValue = ss } }, ())
addCharToLexerStringValue :: Char -> Alex ()
addCharToLexerStringValue c = Alex $ \s ->
let ust = alex_ust s in
Right (s{ alex_ust = ust{ lexerStringValue = (reverse $ LBS.unpack $ LBSUtf8.fromString [c]) ++ lexerStringValue ust } }, ())
addCharCodeToLexerStringValue :: Word8 -> Alex ()
addCharCodeToLexerStringValue c = Alex $ \s ->
let ust = alex_ust s in
Right (s{ alex_ust = ust{ lexerStringValue = c : lexerStringValue ust } }, ())
src/Language/Wasm/Parser.y
+29 -38
View File
@@ -330,11 +330,18 @@ unrestricted_int { Lexeme _ (TIntLit $$) }
f64 { Lexeme _ (TFloatLit $$) }
offset { Lexeme _ (TKeyword (asOffset -> Just $$)) }
align { Lexeme _ (TKeyword (asAlign -> Just $$)) }
string { Lexeme _ (TStringLit (asString -> Just $$)) }
str { Lexeme _ (TStringLit $$) }
EOF { Lexeme _ EOF }
%%
string :: { TL.Text }
: str {%
case TLEncoding.decodeUtf8' $1 of
Right t -> Right t
Left err -> Left "invalid utf8 string"
}
name :: { TL.Text }
: string { $1 }
@@ -619,40 +626,16 @@ paramsresulttypeuse :: { FuncType }
| 'result' list(valtype) ')' { FuncType [] $2 }
memarg1 :: { MemArg }
: opt(offset) opt(align) {%
let offset = fromMaybe 0 $1 in
let align = unpackAlign 1 $2 in
if offset >= 2 ^ 32 || align >= 2 ^ 32
then Left "u32 is out of boundaries"
else return $ MemArg offset align
}
: opt(offset) opt(align) {% parseMemArg 1 $1 $2 }
memarg2 :: { MemArg }
: opt(offset) opt(align) {%
let offset = fromMaybe 0 $1 in
let align = unpackAlign 2 $2 in
if offset >= 2 ^ 32 || align >= 2 ^ 32
then Left "u32 is out of boundaries"
else return $ MemArg offset align
}
: opt(offset) opt(align) {% parseMemArg 2 $1 $2 }
memarg4 :: { MemArg }
: opt(offset) opt(align) {%
let offset = fromMaybe 0 $1 in
let align = unpackAlign 4 $2 in
if offset >= 2 ^ 32 || align >= 2 ^ 32
then Left "u32 is out of boundaries"
else return $ MemArg offset align
}
: opt(offset) opt(align) {% parseMemArg 4 $1 $2 }
memarg8 :: { MemArg }
: opt(offset) opt(align) {%
let offset = fromMaybe 0 $1 in
let align = unpackAlign 8 $2 in
if offset >= 2 ^ 32 || align >= 2 ^ 32
then Left "u32 is out of boundaries"
else return $ MemArg offset align
}
: opt(offset) opt(align) {% parseMemArg 8 $1 $2 }
instruction :: { [Instruction] }
: raw_instr { $1 }
@@ -932,8 +915,8 @@ memory_limits_export_import :: { Maybe Ident -> [ModuleField] }
: memory_limits { $1 }
| '(' memory_limits_export_import1 { $2 }
datastring :: { TL.Text }
: list(string) { TL.concat $1 }
datastring :: { LBS.ByteString }
: list(str) { LBS.concat $1 }
memory_limits_export_import1 :: { Maybe Ident -> [ModuleField] }
: 'export' name ')' memory_limits_export_import {
@@ -944,7 +927,7 @@ memory_limits_export_import1 :: { Maybe Ident -> [ModuleField] }
}
| 'data' datastring ')' ')' {
\ident ->
let m = fromIntegral $ TL.length $2 in
let m = fromIntegral $ LBS.length $2 in
[
MFMem $ Memory ident $ Limit m $ Just m,
MFData $ DataSegment (fromMaybe (Index 0) $ Named `fmap` ident) [PlainInstr $ I32Const 0] $2
@@ -1058,7 +1041,7 @@ command1 :: { Command }
| meta1 { Meta $1 }
module1 :: { ModuleDef }
: 'module' opt(ident) 'binary' list(string) ')' { BinaryModDef $2 (LBSChar8.pack $ TL.unpack $ TL.concat $4) }
: 'module' opt(ident) 'binary' datastring ')' { BinaryModDef $2 $4 }
| 'module' opt(ident) 'quote' list(string) ')' { TextModDef $2 (TL.concat $4) }
| 'module' opt(ident) list(modulefield) ')' { RawModDef $2 (desugarize $ concat $3) }
| modulefield1 list(modulefield) { RawModDef Nothing (desugarize $ $1 ++ concat $2) }
@@ -1145,8 +1128,13 @@ asAlign str = do
num <- TL.stripPrefix "align=" $ TLEncoding.decodeUtf8 str
fromIntegral . fst <$> eitherToMaybe (TLRead.decimal num)
unpackAlign :: Natural -> (Maybe Natural) -> Natural
unpackAlign def = fromIntegral . round . logBase 2 . fromIntegral . fromMaybe def
parseMemArg :: Natural -> Maybe Natural -> Maybe Natural -> Either String MemArg
parseMemArg defAlign optOffset optAlign =
let offset = fromMaybe 0 optOffset in
let align = fromIntegral $ round $ logBase 2 $ fromIntegral $ fromMaybe defAlign optAlign in
if offset >= 2 ^ 32 || align >= 2 ^ 32
then Left "u32 is out of boundaries"
else return $ MemArg offset align
-- TODO: check name conditions.
-- Presuming the source text is itself encoded correctly,
@@ -1155,7 +1143,10 @@ asName :: LBS.ByteString -> Maybe TL.Text
asName = Just . TLEncoding.decodeUtf8
asString :: LBS.ByteString -> Maybe TL.Text
asString = Just . TLEncoding.decodeUtf8
asString bs =
case TLEncoding.decodeUtf8' bs of
Right t -> Just t
Left err -> Nothing
eitherToMaybe :: Either left right -> Maybe right
eitherToMaybe = either (const Nothing) Just
@@ -1363,7 +1354,7 @@ data ElemSegment = ElemSegment {
data DataSegment = DataSegment {
memIndex :: MemoryIndex,
offset :: [Instruction],
datastring :: TL.Text
datastring :: LBS.ByteString
}
deriving (Show, Eq, Generic, NFData)
@@ -1806,7 +1797,7 @@ desugarize fields =
let ctx = FunCtx mod [] [] [] in
let offsetInstrs = map (synInstrToStruct ctx) offset in
let idx = fromJust $ getMemIndex mod memIndex in
S.DataSegment idx offsetInstrs $ LBSChar8.pack $ TL.unpack datastring
S.DataSegment idx offsetInstrs datastring
extractDataSegment :: [DataSegment] -> ModuleField -> [DataSegment]
extractDataSegment datas (MFData dataSegment) = dataSegment : datas
tests/Test.hs
+1 -1
View File
@@ -34,7 +34,7 @@ compile file = do
main :: IO ()
main = do
files <- Directory.listDirectory "tests/samples"
-- let files = ["data.wast"]
-- let files = ["utf8-invalid-encoding.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
content <- LBS.readFile $ "tests/samples/" ++ file
let Right script = Lexer.scanner content >>= Parser.parseScript