implemented assert_malformed assertion and added NFData instances for all parsing types

README.md

@@ -20,3 +20,9 @@
   * [ ] Compile Core Tests to Tasty test cases and pass all tests
   * [ ] Command line tool for calling interpreter/compiler/validator
   * [ ] Codegen interface for type enforced generating valid WASM code
+
+## Development
+Clond sources to directory and use `stack` for running tests:
+```
+stack && stack test
+```

src/Language/Wasm/Binary.hs

@@ -96,8 +96,10 @@ skipCustomSection :: Get ()
 skipCustomSection = do
     byteGuard 0x00
     size <- getULEB128
-    getByteString size
+    content <- getByteString size
-    return ()
+    case runGet getName content of
+        Right _name -> return ()
+        Left _ -> fail "invalid UTF-8 encoding"
 
 getSection :: SectionType -> Get a -> a -> Get a
 getSection sectionType parser def = do
@@ -111,6 +113,7 @@ getSection sectionType parser def = do
         parseSection op
             | op == 0 = skipCustomSection >> getSection sectionType parser def
             | op == fromEnum sectionType = getWord8 >> (getULEB128 :: Get Natural) >> parser
+            | op > fromEnum DataSection = fail "invalid section id"
             | op > fromEnum sectionType = return def
             | otherwise =
                 fail $ "Incorrect order of sections. Expected " ++ show sectionType
@@ -126,7 +129,9 @@ getName :: Get TL.Text
 getName = do
     len <- getULEB128
     bytes <- getLazyByteString len
-    return $ TLEncoding.decodeUtf8 bytes
+    case TLEncoding.decodeUtf8' bytes of
+        Right name -> return name
+        Left _ -> fail "invalid UTF-8 encoding"
 
 putResultType :: ResultType -> Put
 putResultType [] = putWord8 0x40
@@ -230,7 +235,7 @@ instance Serialize GlobalType where
         case op of
             0x00 -> return $ Const valType
             0x01 -> return $ Mut valType
-            _ -> fail "Unexpected byte in place of Global type opcode"
+            _ -> fail "invalid mutability"
 
 instance Serialize ImportDesc where
     put (ImportFunc typeIdx) = putWord8 0x00 >> putULEB128 typeIdx
@@ -770,10 +775,10 @@ instance Serialize Module where
         putSection DataSection $ putVec $ datas mod
         
     get = do
-        -- magic
+        magic <- getWord32be
-        mapM_ byteGuard [0x00, 0x61, 0x73, 0x6D]
+        if magic == 0x0061736D then return () else fail "magic header not detected"
-        -- version
+        version <- getWord32be
-        mapM_ byteGuard [0x01, 0x00, 0x00, 0x00]
+        if version == 0x01000000 then return () else fail "unknown binary version"
         types <- getSection TypeSection getVec []
         imports <- getSection ImportSection getVec []
         funcTypes <- getSection FunctionSection getVec []

src/Language/Wasm/Parser.y

@@ -3,6 +3,8 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 module Language.Wasm.Parser (
     parseModule,
@@ -73,6 +75,8 @@ import Data.Word (Word32, Word64)
 import Data.Bits ((.|.))
 import Numeric.IEEE (infinity, nan)
 import Language.Wasm.FloatUtils (doubleToFloat)
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
 
 import Language.Wasm.Lexer (
         Token (
@@ -1143,7 +1147,7 @@ integerToWord64 i
     | i < 0 && i >= -(2 ^ 63) = 0xFFFFFFFFFFFFFFFF - (fromIntegral (abs i)) + 1
     | otherwise = error "I64 is out of bounds."
 
-data FuncType = FuncType { params :: [ParamType], results :: [ValueType] } deriving (Show, Eq)
+data FuncType = FuncType { params :: [ParamType], results :: [ValueType] } deriving (Show, Eq, Generic, NFData)
 
 emptyFuncType :: FuncType
 emptyFuncType = FuncType [] []
@@ -1151,11 +1155,11 @@ emptyFuncType = FuncType [] []
 data ParamType = ParamType {
         ident :: Maybe Ident,
         paramType :: ValueType
-    } deriving (Show, Eq)
+    } deriving (Show, Eq, Generic, NFData)
 
-newtype Ident = Ident TL.Text deriving (Show, Eq)
+newtype Ident = Ident TL.Text deriving (Show, Eq, Generic, NFData)
 
-data Index = Named Ident | Index Natural deriving (Show, Eq)
+data Index = Named Ident | Index Natural deriving (Show, Eq, Generic, NFData)
 
 type LabelIndex = Index
 type FuncIndex = Index
@@ -1234,14 +1238,14 @@ data PlainInstr =
     | F64PromoteF32
     | IReinterpretF BitSize
     | FReinterpretI BitSize
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
-data TypeDef = TypeDef (Maybe Ident) FuncType deriving (Show, Eq)
+data TypeDef = TypeDef (Maybe Ident) FuncType deriving (Show, Eq, Generic, NFData)
 
 data TypeUse =
     IndexedTypeUse TypeIndex (Maybe FuncType)
     | AnonimousTypeUse FuncType
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 data Instruction =
     PlainInstr PlainInstr
@@ -1261,25 +1265,25 @@ data Instruction =
         trueBranch :: [Instruction],
         falseBranch :: [Instruction]
     }
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 data Import = Import {
         sourceModule :: TL.Text,
         name :: TL.Text,
         desc :: ImportDesc
-    } deriving (Show, Eq)
+    } deriving (Show, Eq, Generic, NFData)
 
 data ImportDesc =
     ImportFunc (Maybe Ident) TypeUse
     | ImportTable (Maybe Ident) TableType
     | ImportMemory (Maybe Ident) Limit
     | ImportGlobal (Maybe Ident) GlobalType
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 data LocalType = LocalType {
         ident :: Maybe Ident,
         localType :: ValueType
-    } deriving (Show, Eq)
+    } deriving (Show, Eq, Generic, NFData)
 
 data Function = Function {
         ident :: Maybe Ident,
@@ -1287,7 +1291,7 @@ data Function = Function {
         locals :: [LocalType],
         body :: [Instruction]
     }
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 emptyFunction :: Function
 emptyFunction =
@@ -1303,40 +1307,40 @@ data Global = Global {
         globalType :: GlobalType,
         initializer :: [Instruction]
     }
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
-data Memory = Memory (Maybe Ident) Limit deriving (Show, Eq)
+data Memory = Memory (Maybe Ident) Limit deriving (Show, Eq, Generic, NFData)
 
-data Table = Table (Maybe Ident) TableType deriving (Show, Eq)
+data Table = Table (Maybe Ident) TableType deriving (Show, Eq, Generic, NFData)
 
 data ExportDesc =
     ExportFunc (Maybe FuncIndex)
     | ExportTable (Maybe TableIndex)
     | ExportMemory (Maybe MemoryIndex)
     | ExportGlobal (Maybe GlobalIndex)
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 data Export = Export {
         name :: TL.Text,
         desc :: ExportDesc
     }
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
-data StartFunction = StartFunction FuncIndex deriving (Show, Eq)
+data StartFunction = StartFunction FuncIndex deriving (Show, Eq, Generic, NFData)
 
 data ElemSegment = ElemSegment {
         tableIndex :: TableIndex,
         offset :: [Instruction],
         funcIndexes :: [FuncIndex]
     }
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 data DataSegment = DataSegment {
         memIndex :: MemoryIndex,
         offset :: [Instruction],
         datastring :: TL.Text
     }
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 data ModuleField =
     MFType TypeDef
@@ -1349,7 +1353,7 @@ data ModuleField =
     | MFStart StartFunction
     | MFElem ElemSegment
     | MFData DataSegment
-    deriving(Show, Eq)
+    deriving(Show, Eq, Generic, NFData)
 
 happyError (Lexeme _ EOF : []) = error $ "Error occuried during parsing phase at the end of file"
 happyError (Lexeme (AlexPn abs line col) tok : tokens) = error $

src/Language/Wasm/Script.hs

@@ -9,6 +9,7 @@ import qualified Data.Vector as Vector
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TLEncoding
 import Numeric.IEEE (identicalIEEE)
+import qualified Control.DeepSeq as DeepSeq
 
 import Language.Wasm.Parser (
         Ident(..),
@@ -197,6 +198,14 @@ runScript onAssertFail script = do
                                 ++ ", but actual is "
                                 ++ show (getFailureString reason)
                         in onAssertFail msg assert
+        runAssert st assert@(AssertMalformed (TextModDef _ textRep) failureString) =
+            case DeepSeq.force $ Parser.parseModule <$> Lexer.scanner (TLEncoding.encodeUtf8 textRep) of
+                Right _ -> onAssertFail ("Module parsing should fail with failure string " ++ show failureString) assert
+                Left _ -> return ()
+        runAssert st assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) =
+            case Binary.decodeModuleLazy binaryRep of
+                Right _ -> onAssertFail ("Module decoding should fail with failure string " ++ show failureString) assert
+                Left _ -> return ()
         runAssert _ _ = return ()
 
         runCommand :: ScriptState -> Command -> IO ScriptState

src/Language/Wasm/Structure.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 module Language.Wasm.Structure (
     Module(..),
@@ -44,10 +46,12 @@ import Numeric.Natural (Natural)
 import Data.Word (Word32, Word64)
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text.Lazy as TL
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
 
-data BitSize = BS32 | BS64 deriving (Show, Eq)
+data BitSize = BS32 | BS64 deriving (Show, Eq, Generic, NFData)
 
-data IUnOp = IClz | ICtz | IPopcnt deriving (Show, Eq)
+data IUnOp = IClz | ICtz | IPopcnt deriving (Show, Eq, Generic, NFData)
 
 data IBinOp =
     IAdd
@@ -65,17 +69,17 @@ data IBinOp =
     | IShrS
     | IRotl
     | IRotr
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
-data IRelOp = IEq | INe | ILtU | ILtS | IGtU | IGtS | ILeU | ILeS | IGeU | IGeS deriving (Show, Eq)
+data IRelOp = IEq | INe | ILtU | ILtS | IGtU | IGtS | ILeU | ILeS | IGeU | IGeS deriving (Show, Eq, Generic, NFData)
 
-data FUnOp = FAbs | FNeg | FCeil | FFloor | FTrunc | FNearest | FSqrt deriving (Show, Eq)
+data FUnOp = FAbs | FNeg | FCeil | FFloor | FTrunc | FNearest | FSqrt deriving (Show, Eq, Generic, NFData)
 
-data FBinOp = FAdd | FSub | FMul | FDiv | FMin | FMax | FCopySign deriving (Show, Eq)
+data FBinOp = FAdd | FSub | FMul | FDiv | FMin | FMax | FCopySign deriving (Show, Eq, Generic, NFData)
 
-data FRelOp = FEq | FNe | FLt | FGt | FLe | FGe deriving (Show, Eq)
+data FRelOp = FEq | FNe | FLt | FGt | FLe | FGe deriving (Show, Eq, Generic, NFData)
 
-data MemArg = MemArg { offset :: Natural, align :: Natural } deriving (Show, Eq)
+data MemArg = MemArg { offset :: Natural, align :: Natural } deriving (Show, Eq, Generic, NFData)
 
 type LabelIndex = Natural
 type FuncIndex = Natural
@@ -90,13 +94,13 @@ data ValueType =
     | I64
     | F32
     | F64
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 type ResultType = [ValueType]
 type ParamsType = [ValueType]
 type LocalsType = [ValueType]
 
-data FuncType = FuncType { params :: ParamsType, results :: ResultType } deriving (Show, Eq)
+data FuncType = FuncType { params :: ParamsType, results :: ResultType } deriving (Show, Eq, Generic, NFData)
 
 data Instruction =
     -- Control instructions
@@ -170,7 +174,7 @@ data Instruction =
     | F64PromoteF32
     | IReinterpretF BitSize
     | FReinterpretI BitSize
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 type Expression = [Instruction]
 
@@ -178,63 +182,63 @@ data Function = Function {
     funcType :: TypeIndex,
     localTypes :: LocalsType,
     body :: Expression
-} deriving (Show, Eq)
+} deriving (Show, Eq, Generic, NFData)
 
-data Limit = Limit Natural (Maybe Natural) deriving (Show, Eq)
+data Limit = Limit Natural (Maybe Natural) deriving (Show, Eq, Generic, NFData)
 
-data ElemType = AnyFunc deriving (Show, Eq)
+data ElemType = AnyFunc deriving (Show, Eq, Generic, NFData)
 
-data TableType = TableType Limit ElemType deriving (Show, Eq)
+data TableType = TableType Limit ElemType deriving (Show, Eq, Generic, NFData)
 
-data Table = Table TableType deriving (Show, Eq)
+data Table = Table TableType deriving (Show, Eq, Generic, NFData)
 
-data Memory = Memory Limit deriving (Show, Eq)
+data Memory = Memory Limit deriving (Show, Eq, Generic, NFData)
 
-data GlobalType = Const ValueType | Mut ValueType deriving (Show, Eq)
+data GlobalType = Const ValueType | Mut ValueType deriving (Show, Eq, Generic, NFData)
 
 data Global = Global {
     globalType :: GlobalType,
     initializer :: Expression
-} deriving (Show, Eq)
+} deriving (Show, Eq, Generic, NFData)
 
 data ElemSegment = ElemSegment {
     tableIndex :: TableIndex,
     offset :: [Instruction],
     funcIndexes :: [FuncIndex]
-} deriving (Show, Eq)
+} deriving (Show, Eq, Generic, NFData)
 
 data DataSegment = DataSegment {
     memIndex :: MemoryIndex,
     offset :: Expression,
     chunk :: LBS.ByteString
-} deriving (Show, Eq)
+} deriving (Show, Eq, Generic, NFData)
 
-data StartFunction = StartFunction FuncIndex deriving (Show, Eq)
+data StartFunction = StartFunction FuncIndex deriving (Show, Eq, Generic, NFData)
 
 data ExportDesc =
     ExportFunc FuncIndex
     | ExportTable TableIndex
     | ExportMemory MemoryIndex
     | ExportGlobal GlobalIndex
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 data Export = Export {
     name :: TL.Text,
     desc :: ExportDesc
-} deriving (Show, Eq)
+} deriving (Show, Eq, Generic, NFData)
 
 data ImportDesc =
     ImportFunc TypeIndex
     | ImportTable TableType
     | ImportMemory Limit
     | ImportGlobal GlobalType
-    deriving (Show, Eq)
+    deriving (Show, Eq, Generic, NFData)
 
 data Import = Import {
     sourceModule :: TL.Text,
     name :: TL.Text,
     desc :: ImportDesc
-} deriving (Show, Eq)
+} deriving (Show, Eq, Generic, NFData)
 
 isFuncImport :: Import -> Bool
 isFuncImport (Import _ _ (ImportFunc _)) = True
@@ -263,7 +267,7 @@ data Module = Module {
     start :: Maybe StartFunction,
     imports :: [Import],
     exports :: [Export]
-} deriving (Show, Eq)
+} deriving (Show, Eq, Generic, NFData)
 
 emptyModule :: Module
 emptyModule = Module {

wasm.cabal

@@ -32,6 +32,7 @@ library
     , cereal >= 0.5
     , vector >= 0.12
     , ieee754 >= 0.8
+    , deepseq >= 1.4
   build-tools:
       alex >=3.1.3
     , happy >=1.9.4