diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 437aae1..86c3881 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -614,16 +614,16 @@ paramsresulttypeuse :: { FuncType } | 'result' list(valtype) ')' { FuncType [] $2 } memarg1 :: { MemArg } - : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 1 $2) } + : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (unpackAlign 1 $2) } memarg2 :: { MemArg } - : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 2 $2) } + : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (unpackAlign 2 $2) } memarg4 :: { MemArg } - : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 4 $2) } + : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (unpackAlign 4 $2) } memarg8 :: { MemArg } - : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 8 $2) } + : opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (unpackAlign 8 $2) } instruction :: { [Instruction] } : raw_instr { $1 } @@ -1116,6 +1116,9 @@ 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 + -- TODO: check name conditions. -- Presuming the source text is itself encoded correctly, -- strings that do not contain any uses of hexadecimal byte escapes are always valid names. @@ -1673,10 +1676,7 @@ desugarize fields = Nothing -> let isIdent (LocalType ident _) = ident == Just id in fromIntegral . (+ length ctxParams) <$> findIndex isIdent ctxLocals - getLocalIndex FunCtx {ctxParams, ctxLocals} (Index idx) = - if (length ctxParams + length ctxLocals > fromIntegral idx) - then Just idx - else Nothing + getLocalIndex FunCtx {ctxParams, ctxLocals} (Index idx) = Just idx isFuncImport :: Import -> Bool isFuncImport Import { desc = ImportFunc _ _ } = True @@ -1690,11 +1690,7 @@ desugarize fields = Nothing -> let isIdent (Function { ident }) = ident == Just id in fromIntegral . (+ length funImports) <$> findIndex isIdent functions - getFuncIndex Module { imports, functions } (Index idx) = - let funImports = filter isFuncImport imports in - if length funImports + length functions > fromIntegral idx - then Just idx - else Nothing + getFuncIndex Module { imports, functions } (Index idx) = Just idx -- tables synTableToStruct :: Table -> S.Table @@ -1716,11 +1712,7 @@ desugarize fields = Nothing -> let isIdent (Table (Just id) _) = True in fromIntegral . (+ length tableImports) <$> findIndex isIdent tables - getTableIndex Module { imports, tables } (Index idx) = - let tableImports = filter isTableImport imports in - if length tableImports + length tables > fromIntegral idx - then Just idx - else Nothing + getTableIndex Module { imports, tables } (Index idx) = Just idx -- memory synMemoryToStruct :: Memory -> S.Memory @@ -1742,11 +1734,7 @@ desugarize fields = Nothing -> let isIdent (Memory (Just id) _) = True in fromIntegral . (+ length memImports) <$> findIndex isIdent mems - getMemIndex Module { imports, mems } (Index idx) = - let memImports = filter isMemImport imports in - if length memImports + length mems > fromIntegral idx - then Just idx - else Nothing + getMemIndex Module { imports, mems } (Index idx) = Just idx -- global synGlobalToStruct :: Module -> Global -> S.Global @@ -1770,11 +1758,7 @@ desugarize fields = Nothing -> let isIdent (Global { ident }) = ident == Just id in fromIntegral . (+ length globalImports) <$> findIndex isIdent globals - getGlobalIndex Module { imports, globals } (Index idx) = - let globalImports = filter isGlobalImport imports in - if length globalImports + length globals > fromIntegral idx - then Just idx - else Nothing + getGlobalIndex Module { imports, globals } (Index idx) = Just idx -- elem segment synElemToStruct :: Module -> ElemSegment -> S.ElemSegment diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index facd4c9..9efd8af 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -139,6 +139,36 @@ runScript onAssertFail script = do then return () else onAssertFail ("Expected NaN, but action returned " ++ show v) assert _ -> onAssertFail ("Expected NaN, but action returned " ++ show result) assert + + buildModule :: ModuleDef -> (Maybe Ident, Struct.Module) + buildModule (RawModDef ident m) = (ident, m) + buildModule (TextModDef ident textRep) = + let Right m = Parser.parseModule <$> Lexer.scanner (TLEncoding.encodeUtf8 textRep) in + (ident, m) + buildModule (BinaryModDef ident binaryRep) = + let Right m = Binary.decodeModuleLazy binaryRep in + (ident, m) + + checkModuleInvalid :: Struct.Module -> IO () + checkModuleInvalid _ = return () + + getFailureString :: Validate.ValidationResult -> TL.Text + getFailureString (Validate.TypeMismatch _ _) = "type mismatch" + getFailureString Validate.MoreThanOneMemory = "multiple memories" + getFailureString Validate.MoreThanOneTable = "multiple tables" + getFailureString Validate.LocalIndexOutOfRange = "unknown local" + getFailureString Validate.MemoryIndexOutOfRange = "unknown memory" + getFailureString Validate.TableIndexOutOfRange = "unknown table" + getFailureString Validate.FunctionIndexOutOfRange = "unknown function" + getFailureString Validate.GlobalIndexOutOfRange = "unknown global" + getFailureString Validate.LabelIndexOutOfRange = "unknown label" + getFailureString Validate.MinMoreThanMaxInMemoryLimit = "size minimum must not be greater than maximum" + getFailureString Validate.MemoryLimitExceeded = "memory size must be at most 65536 pages (4GiB)" + getFailureString Validate.AlignmentOverflow = "alignment must not be larger than natural" + getFailureString (Validate.DuplicatedExportNames _) = "duplicate export name" + getFailureString Validate.InvalidConstantExpr = "constant expression required" + -- getFailureString Validate.ImportedGlobalIsNotConst = "global is immutable" + getFailureString _ = "not implemented" runAssert :: ScriptState -> Assertion -> IO () runAssert st assert@(AssertReturn action expected) = do @@ -148,15 +178,24 @@ runScript onAssertFail script = do else onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert runAssert st assert@(AssertReturnCanonicalNaN action) = isNaNReturned st action assert runAssert st assert@(AssertReturnArithmeticNaN action) = isNaNReturned st action assert + runAssert st assert@(AssertInvalid moduleDef failureString) = + let (_, m) = buildModule moduleDef in + case Validate.validate m of + Validate.Valid -> onAssertFail "Invalid module pass validation" assert + reason -> + if getFailureString reason == failureString + then return () + else + let msg = "Module invalid for other reason. Expected " + ++ show failureString + ++ ", but actual is " + ++ show (getFailureString reason) + in onAssertFail msg assert runAssert _ _ = return () runCommand :: ScriptState -> Command -> IO ScriptState - runCommand st (ModuleDef (RawModDef ident m)) = addModule ident m st - runCommand st (ModuleDef (TextModDef ident textRep)) = - let Right m = Parser.parseModule <$> Lexer.scanner (TLEncoding.encodeUtf8 textRep) in - addModule ident m st - runCommand st (ModuleDef (BinaryModDef ident binaryRep)) = - let Right m = Binary.decodeModuleLazy binaryRep in + runCommand st (ModuleDef moduleDef) = + let (ident, m) = buildModule moduleDef in addModule ident m st runCommand st (Register name i) = return $ addToRegistery name i st runCommand st (Action action) = runAction st action >> return st diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index e4c5e42..a8626a7 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -25,13 +25,19 @@ import Debug.Trace as Debug data ValidationResult = DuplicatedExportNames [String] | InvalidTableType - | InvalidMemoryLimit + | MinMoreThanMaxInMemoryLimit + | MemoryLimitExceeded + | AlignmentOverflow | MoreThanOneMemory | MoreThanOneTable - | IndexOutOfRange + | FunctionIndexOutOfRange + | TableIndexOutOfRange + | MemoryIndexOutOfRange + | LocalIndexOutOfRange + | GlobalIndexOutOfRange + | LabelIndexOutOfRange + | TypeIndexOutOfRange | ResultTypeDoesntMatch - | NoTableInModule - | NoMemoryInModule | TypeMismatch { actual :: Arrow, expected :: Arrow } | InvalidConstantExpr | InvalidStartFunctionType @@ -144,9 +150,6 @@ maybeToEither :: ValidationResult -> Maybe a -> Checker a maybeToEither _ (Just a) = return a maybeToEither l Nothing = throwError l -isIndexValid :: (Integral idx, Integral len) => idx -> len -> ValidationResult -isIndexValid idx len = if fromIntegral idx < fromIntegral len then Valid else IndexOutOfRange - asType :: GlobalType -> VType asType (Const v) = Val v asType (Mut v) = Val v @@ -155,12 +158,21 @@ getLabel :: LabelIndex -> Checker (Maybe ValueType) getLabel lbl = do Ctx { labels } <- ask case labels !? lbl of - Nothing -> throwError IndexOutOfRange + Nothing -> throwError LabelIndexOutOfRange Just v -> return v withLabel :: [ValueType] -> Checker a -> Checker a withLabel result = withReaderT (\ctx -> ctx { labels = safeHead result : labels ctx }) +isMemArgValid :: Int -> MemArg -> Checker () +isMemArgValid sizeInBytes MemArg { align } = if 2 ^ align <= sizeInBytes then return () else throwError AlignmentOverflow + +checkMemoryInstr :: Int -> MemArg -> Checker () +checkMemoryInstr size memarg = do + isMemArgValid size memarg + Ctx { mems } <- ask + if length mems < 1 then throwError MemoryIndexOutOfRange else return () + getInstrType :: Instruction -> Checker Arrow getInstrType Unreachable = return $ Any ==> Any getInstrType Nop = return $ empty ==> empty @@ -202,13 +214,13 @@ getInstrType Return = do return $ (Any : (map Val $ maybeToList returns)) ==> Any getInstrType (Call fun) = do Ctx { funcs } <- ask - maybeToEither IndexOutOfRange $ asArrow <$> funcs !? fun + maybeToEither FunctionIndexOutOfRange $ asArrow <$> funcs !? fun getInstrType (CallIndirect sign) = do Ctx { types, tables } <- ask if length tables < 1 - then throwError NoTableInModule + then throwError TableIndexOutOfRange else do - Arrow from to <- maybeToEither IndexOutOfRange $ asArrow <$> types !? sign + Arrow from to <- maybeToEither FunctionIndexOutOfRange $ asArrow <$> types !? sign return $ (from ++ [Val I32]) ==> to getInstrType Drop = do var <- freshVar @@ -218,100 +230,99 @@ getInstrType Select = do return $ [var, var, Val I32] ==> var getInstrType (GetLocal local) = do Ctx { locals } <- ask - t <- maybeToEither IndexOutOfRange $ locals !? local + t <- maybeToEither LocalIndexOutOfRange $ locals !? local return $ empty ==> Val t getInstrType (SetLocal local) = do Ctx { locals } <- ask - t <- maybeToEither IndexOutOfRange $ locals !? local + t <- maybeToEither LocalIndexOutOfRange $ locals !? local return $ Val t ==> empty getInstrType (TeeLocal local) = do Ctx { locals } <- ask - t <- maybeToEither IndexOutOfRange $ locals !? local + t <- maybeToEither LocalIndexOutOfRange $ locals !? local return $ Val t ==> Val t getInstrType (GetGlobal global) = do Ctx { globals } <- ask - t <- maybeToEither IndexOutOfRange $ asType <$> globals !? global + t <- maybeToEither LocalIndexOutOfRange $ asType <$> globals !? global return $ empty ==> t getInstrType (SetGlobal global) = do Ctx { globals } <- ask - t <- maybeToEither IndexOutOfRange $ asType <$> globals !? global + t <- maybeToEither LocalIndexOutOfRange $ asType <$> globals !? global return $ t ==> empty --- TODO: check memory alignment -getInstrType (I32Load _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32 -getInstrType (I64Load _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64 -getInstrType (F32Load _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> F32 -getInstrType (F64Load _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> F64 -getInstrType (I32Load8S _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32 -getInstrType (I32Load8U _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32 -getInstrType (I32Load16S _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32 -getInstrType (I32Load16U _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32 -getInstrType (I64Load8S _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64 -getInstrType (I64Load8U _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64 -getInstrType (I64Load16S _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64 -getInstrType (I64Load16U _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64 -getInstrType (I64Load32S _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64 -getInstrType (I64Load32U _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I64 -getInstrType (I32Store _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I32] ==> empty -getInstrType (I64Store _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I64] ==> empty -getInstrType (F32Store _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ [I32, F32] ==> empty -getInstrType (F64Store _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ [I32, F64] ==> empty -getInstrType (I32Store8 _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I32] ==> empty -getInstrType (I32Store16 _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I32] ==> empty -getInstrType (I64Store8 _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I64] ==> empty -getInstrType (I64Store16 _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I64] ==> empty -getInstrType (I64Store32 _) = do - Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ [I32, I64] ==> empty +getInstrType (I32Load memarg) = do + checkMemoryInstr 4 memarg + return $ I32 ==> I32 +getInstrType (I64Load memarg) = do + checkMemoryInstr 8 memarg + return $ I32 ==> I64 +getInstrType (F32Load memarg) = do + checkMemoryInstr 4 memarg + return $ I32 ==> F32 +getInstrType (F64Load memarg) = do + checkMemoryInstr 8 memarg + return $ I32 ==> F64 +getInstrType (I32Load8S memarg) = do + checkMemoryInstr 1 memarg + return $ I32 ==> I32 +getInstrType (I32Load8U memarg) = do + checkMemoryInstr 1 memarg + return $ I32 ==> I32 +getInstrType (I32Load16S memarg) = do + checkMemoryInstr 2 memarg + return $ I32 ==> I32 +getInstrType (I32Load16U memarg) = do + checkMemoryInstr 2 memarg + return $ I32 ==> I32 +getInstrType (I64Load8S memarg) = do + checkMemoryInstr 1 memarg + return $ I32 ==> I64 +getInstrType (I64Load8U memarg) = do + checkMemoryInstr 1 memarg + return $ I32 ==> I64 +getInstrType (I64Load16S memarg) = do + checkMemoryInstr 2 memarg + return $ I32 ==> I64 +getInstrType (I64Load16U memarg) = do + checkMemoryInstr 2 memarg + return $ I32 ==> I64 +getInstrType (I64Load32S memarg) = do + checkMemoryInstr 4 memarg + return $ I32 ==> I64 +getInstrType (I64Load32U memarg) = do + checkMemoryInstr 8 memarg + return $ I32 ==> I64 +getInstrType (I32Store memarg) = do + checkMemoryInstr 4 memarg + return $ [I32, I32] ==> empty +getInstrType (I64Store memarg) = do + checkMemoryInstr 8 memarg + return $ [I32, I64] ==> empty +getInstrType (F32Store memarg) = do + checkMemoryInstr 4 memarg + return $ [I32, F32] ==> empty +getInstrType (F64Store memarg) = do + checkMemoryInstr 8 memarg + return $ [I32, F64] ==> empty +getInstrType (I32Store8 memarg) = do + checkMemoryInstr 1 memarg + return $ [I32, I32] ==> empty +getInstrType (I32Store16 memarg) = do + checkMemoryInstr 2 memarg + return $ [I32, I32] ==> empty +getInstrType (I64Store8 memarg) = do + checkMemoryInstr 1 memarg + return $ [I32, I64] ==> empty +getInstrType (I64Store16 memarg) = do + checkMemoryInstr 2 memarg + return $ [I32, I64] ==> empty +getInstrType (I64Store32 memarg) = do + checkMemoryInstr 4 memarg + return $ [I32, I64] ==> empty getInstrType CurrentMemory = do Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ empty ==> I32 + if length mems < 1 then throwError MemoryIndexOutOfRange else return $ empty ==> I32 getInstrType GrowMemory = do Ctx { mems } <- ask - if length mems < 1 then throwError NoMemoryInModule else return $ I32 ==> I32 + if length mems < 1 then throwError MemoryIndexOutOfRange else return $ I32 ==> I32 getInstrType (I32Const _) = return $ empty ==> I32 getInstrType (I64Const _) = return $ empty ==> I64 getInstrType (F32Const _) = return $ empty ==> F32 @@ -494,7 +505,10 @@ memoryShouldBeValid Module { imports, mems } = else MoreThanOneMemory where isValidLimit :: Limit -> ValidationResult - isValidLimit (Limit min max) = if min <= fromMaybe min max then Valid else InvalidMemoryLimit + isValidLimit (Limit min max) = + let minMax = if min <= fromMaybe min max then Valid else MinMoreThanMaxInMemoryLimit in + let maxLim = if fromMaybe min max <= 65536 then Valid else MemoryLimitExceeded in + minMax <> maxLim globalsShouldBeValid :: Validator globalsShouldBeValid m@Module { imports, globals } = @@ -537,11 +551,11 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } = let isTableIndexValid = if tableIdx < (fromIntegral $ length tableImports + length tables) then Valid - else IndexOutOfRange + else TableIndexOutOfRange in let funImports = filter isFuncImport imports in let funsLength = fromIntegral $ length functions + length funImports in - let isFunsValid = foldMap (\i -> if i < funsLength then Valid else IndexOutOfRange) funs in + let isFunsValid = foldMap (\i -> if i < funsLength then Valid else FunctionIndexOutOfRange) funs in isIniterValid <> isFunsValid <> isTableIndexValid datasShouldBeValid :: Validator @@ -563,7 +577,7 @@ datasShouldBeValid m@Module { datas, mems, imports } = let memImports = filter isMemImport imports in if memIdx < (fromIntegral $ length memImports + length mems) then isOffsetValid - else IndexOutOfRange + else MemoryIndexOutOfRange startShouldBeValid :: Validator startShouldBeValid Module { start = Nothing } = Valid @@ -572,7 +586,7 @@ startShouldBeValid m@Module { start = Just (StartFunction idx) } = let i = fromIntegral idx in if length types > i then if FuncType [] [] == types !! i then Valid else InvalidStartFunctionType - else IndexOutOfRange + else TableIndexOutOfRange exportsShouldBeValid :: Validator exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals } = @@ -585,13 +599,13 @@ exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals isExportValid :: Export -> ValidationResult isExportValid (Export _ (ExportFunc funIdx)) = - isIndexValid funIdx $ length funcImports + length functions + if fromIntegral funIdx < length funcImports + length functions then Valid else FunctionIndexOutOfRange isExportValid (Export _ (ExportTable tableIdx)) = - isIndexValid tableIdx $ length tableImports + length tables + if fromIntegral tableIdx < length tableImports + length tables then Valid else TableIndexOutOfRange isExportValid (Export _ (ExportMemory memIdx)) = - isIndexValid memIdx $ length memImports + length mems + if fromIntegral memIdx < length memImports + length mems then Valid else MemoryIndexOutOfRange isExportValid (Export _ (ExportGlobal globalIdx)) = - isIndexValid globalIdx $ length globalImports + length globals + if fromIntegral globalIdx < length globalImports + length globals then Valid else GlobalIndexOutOfRange areExportNamesUnique :: ValidationResult areExportNamesUnique = @@ -610,7 +624,7 @@ importsShouldBeValid Module { imports, types } = foldMap isImportValid imports where isImportValid :: Import -> ValidationResult - isImportValid (Import _ _ (ImportFunc typeIdx)) = isIndexValid typeIdx $ length types + isImportValid (Import _ _ (ImportFunc typeIdx)) = if fromIntegral typeIdx < length types then Valid else TypeIndexOutOfRange isImportValid (Import _ _ (ImportTable _)) = Valid -- checked in tables section isImportValid (Import _ _ (ImportMemory _)) = Valid -- checked in mems section isImportValid (Import _ _ (ImportGlobal (Const _))) = Valid diff --git a/tests/Test.hs b/tests/Test.hs index 6d7f582..f98a53e 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -34,7 +34,7 @@ compile file = do main :: IO () main = do files <- Directory.listDirectory "tests/samples" - -- let files = ["float_literals.wast"] + -- let files = ["memory.wast"] scriptTestCases <- (`mapM` files) $ \file -> do content <- LBS.readFile $ "tests/samples/" ++ file let Right script = Parser.parseScript <$> Lexer.scanner content