-- | Parser for ActionScript byte code. -- -- Some parts of the grammar are not documented in the AVM2 specification. -- In particular: -- * generics: http://www.n-heptane.com/nhlab/repos/haskell-swf/ module Parser(parseAbcFile,parseSwfFile,parseAbcAsSwf,parseAnyAsSwf) where import Data.Bits import Data.ByteString.Lazy(ByteString) import qualified Data.ByteString.Lazy as B import Data.ByteString.Lazy.UTF8(fromString) import Data.Word import System.IO import ParseUtil import ByteCode import InstrLocFilter import Codec.Archive.Zip import System.FilePath -- -- SWF parsing -- pSwfFile :: Parser SwfFile pSwfFile = do compressed <- pSwfHead version <- pU8 length <- pW32 let checkFinished p = p <* pEnd pTail | compressed = pDecompress length . checkFinished | otherwise = checkFinished pTail $ do size <- padded pRect rate <- pU16 count <- pU16 tags <- pTags return (SwfFile_File compressed version length size rate count tags) pSwfHead :: Parser Bool pSwfHead = pTable [ 0x46 .> return False , 0x43 .> return True ] <* pByte 0x57 <* pByte 0x53 "SWF head" pRect :: Bit Rect pRect = do size <- fromIntegral <$> takeBits 5 x1 <- takeBits size y1 <- takeBits size x2 <- takeBits size y2 <- takeBits size return (Rect_Rect size x1 x2 y1 y2) pTags :: Parser Tags pTags = do t <- pTag case t of Tag_End -> return [t] _ -> do ts <- pTags return (t : ts) pTag :: Parser Tag pTag = do key <- pU16 let code = shiftR key 6 len' = key .&. 0x3F len <- if len' == 0x3F then pW32 else return (fromIntegral len') let kind = toTagKind code pInfo ("Tag: " ++ show kind ++ ", len: " ++ show len) case kind of TagKind_DoABC -> Tag_Abc <$> pAbcFlags <*> pNullString <*> pAbcFile TagKind_End -> return Tag_End TagKind_FileAttributes -> padded $ do takeBit direct <- takeBit gpu <- takeBit meta <- takeBit as3 <- takeBit takeBits 2 net <- takeBit takeBits 24 return $ Tag_FileAttributes direct gpu meta as3 net _ -> Tag_Opaque kind len . B.fromChunks . return <$> getBytes (fromIntegral len) "tag" pAbcFlags :: Parser AbcFlags pAbcFlags = do n <- pW32 case n of 0 -> return [] 1 -> return [AbcFlag_LazyInit] _ -> fail ("Unknown ABC flags: " ++ show n) toTagKind :: Word16 -> TagKind toTagKind c = case c of 0 -> TagKind_End 1 -> TagKind_ShowFrame 2 -> TagKind_DefineShape 4 -> TagKind_PlaceObject 5 -> TagKind_RemoveObject 6 -> TagKind_DefineBits 7 -> TagKind_DefineButton 8 -> TagKind_JPEGTables 9 -> TagKind_SetBackgroundColor 10 -> TagKind_DefineFont 11 -> TagKind_DefineText 12 -> TagKind_DoAction 13 -> TagKind_DefineFontInfo 14 -> TagKind_DefineSound 15 -> TagKind_StartSound 17 -> TagKind_DefineButtonSound 18 -> TagKind_SoundStreamHead 19 -> TagKind_SoundStreamBlock 20 -> TagKind_DefineBitsLossless 21 -> TagKind_DefineBitsJPEG2 22 -> TagKind_DefineShape2 23 -> TagKind_DefineButtonCxform 24 -> TagKind_Protect 26 -> TagKind_PlaceObject2 28 -> TagKind_RemoveObject2 32 -> TagKind_DefineShape3 33 -> TagKind_DefineText2 34 -> TagKind_DefineButton2 35 -> TagKind_DefineBitsJPEG3 36 -> TagKind_DefineBitsLossless2 37 -> TagKind_DefineEditText 39 -> TagKind_DefineSprite 43 -> TagKind_FrameLabel 45 -> TagKind_SoundStreamHead2 46 -> TagKind_DefineMorphShape 48 -> TagKind_DefineFont2 56 -> TagKind_ExportAssets 57 -> TagKind_ImportAssets 58 -> TagKind_EnableDebugger 59 -> TagKind_DoInitAction 60 -> TagKind_DefineVideoStream 61 -> TagKind_VideoFrame 62 -> TagKind_DefineFontInfo2 64 -> TagKind_EnableDebugger2 65 -> TagKind_ScriptLimits 66 -> TagKind_SetTabIndex 69 -> TagKind_FileAttributes 70 -> TagKind_PlaceObject3 71 -> TagKind_ImportAssets2 73 -> TagKind_DefineFontAlignZones 74 -> TagKind_CSMTextSettings 75 -> TagKind_DefineFont3 76 -> TagKind_SymbolClass 77 -> TagKind_Metadata 78 -> TagKind_DefineScalingGrid 82 -> TagKind_DoABC 83 -> TagKind_DefineShape4 84 -> TagKind_DefineMorphShape2 86 -> TagKind_DefineSceneAndFrameLabelData 87 -> TagKind_DefineBinaryData 88 -> TagKind_DefineFontName 89 -> TagKind_StartSound2 90 -> TagKind_DefineBitsJPEG4 91 -> TagKind_DefineFont4 _ -> TagKind_Other c -- fallback case -- -- ABC parsing -- pAbcFile :: Parser AbcFile pAbcFile = do major <- pU16 "major version" minor <- pU16 "minor version" pool <- pPoolInfo methods <- pCountU30 pMethodInfo metas <- pCountU30 pMetaInfo classCount <- fromIntegral <$> pU30 instances <- pCount pInstanceInfo classCount classes <- pCount pClassInfo classCount scripts <- pCountU30 pScriptInfo bodies <- pCountU30 pBodyInfo return (AbcFile_File major minor pool methods metas instances classes scripts bodies) "abc file" pPoolInfo :: Parser PoolInfo pPoolInfo = PoolInfo_Info <$> pCount1U30 pS32 <*> pCount1U30 pU32 <*> pCount1U30 pD64 <*> pCount1U30 pString <*> pCount1U30 pNamespaceInfo <*> pCount1U30 pSetInfo <*> pCount1U30 pMultinameInfo "pool info" pNamespaceInfo :: Parser NamespaceInfo pNamespaceInfo = NamespaceInfo_Info <$> pNamespaceKind <*> pNamespaceIndex "namespace info" pNamespaceKind :: Parser NamespaceKind pNamespaceKind = pTable [ 0x08 .> return NamespaceKind_General , 0x16 .> return NamespaceKind_Package , 0x17 .> return NamespaceKind_Internal , 0x18 .> return NamespaceKind_Protected , 0x19 .> return NamespaceKind_Explicit , 0x1A .> return NamespaceKind_Static , 0x05 .> return NamespaceKind_Private ] "namespace kind" pNamespaceIndex :: Parser Word32 pNamespaceIndex = pU30 "namespace name index" pSetInfo :: Parser SetInfo pSetInfo = SetInfo_Info <$> pCountU30 pU30 "namespace set info" pMultinameInfo :: Parser MultinameInfo pMultinameInfo = pTable [ 0x07 .> MultinameInfo_QName <$> pNamespaceIndex <*> pNameIndex , 0x0D .> MultinameInfo_QNameA <$> pNamespaceIndex <*> pNameIndex , 0x0F .> MultinameInfo_RTQName <$> pNameIndex , 0x10 .> MultinameInfo_RTQNameA <$> pNameIndex , 0x11 .> return MultinameInfo_RTQNameL , 0x12 .> return MultinameInfo_RTQNameLA , 0x09 .> MultinameInfo_Multiname <$> pNameIndex <*> pSetIndex , 0x0E .> MultinameInfo_MultinameA <$> pNameIndex <*> pSetIndex , 0x1B .> MultinameInfo_MultinameL <$> pSetIndex , 0x1C .> MultinameInfo_MultinameLA <$> pSetIndex , 0x1D .> MultinameInfo_Generic <$> pNameIndex <*> pCountU30 pNameIndex ] "multiname info" pNameIndex :: Parser Word32 pNameIndex = pU30 "name index" pSetIndex :: Parser Word32 pSetIndex = pU30 "set index" pMethodInfo :: Parser MethodInfo pMethodInfo = do nParams <- pLength rt <- pMultinameIndex paramTps <- pCount pMultinameIndex nParams nm <- pNameIndex flags <- pMethodFlags options <- if MethodFlag_HasOptionals `elem` flags then pCountU30 pOptional else return [] paramNames <- if MethodFlag_HasParamNames `elem` flags then pCount pNameIndex nParams else return [] return (MethodInfo_Info rt paramTps nm flags options paramNames) "method info" pLength :: Parser Int pLength = fromIntegral <$> pU30 "length" pMultinameIndex :: Parser Word32 pMultinameIndex = pU30 "multiname index" pMethodFlags :: Parser MethodFlags pMethodFlags = pFlags [ (0x01, MethodFlag_NeedArgs) , (0x02, MethodFlag_NeedAct) , (0x04, MethodFlag_NeedRest) , (0x08, MethodFlag_HasOptionals) , (0x40, MethodFlag_SetDXNS) , (0x80, MethodFlag_HasParamNames) ] pFlags :: [(Word8,a)] -> Parser [a] pFlags flags = matchFlags flags <$> pU8 "flags" -- | takes those flags that have corresponding bits in the word matchFlags :: [(Word8,a)] -> Word8 -> [a] matchFlags flags b = map snd $ filter (\(x,_) -> x .&. b > 0) flags pOptional :: Parser Optional pOptional = Optional_Detail <$> pU32 <*> pValueKind "optional" pValueKind :: Parser ValueKind pValueKind = pTable [ 0x03 .> return ValueKind_Int , 0x04 .> return ValueKind_UInt , 0x06 .> return ValueKind_Double , 0x01 .> return ValueKind_Utf8 , 0x0B .> return ValueKind_True , 0x0A .> return ValueKind_False , 0x0C .> return ValueKind_Null , 0x00 .> return ValueKind_Undefined , 0x08 .> return ValueKind_Namespace , 0x16 .> return ValueKind_Package , 0x17 .> return ValueKind_Internal , 0x18 .> return ValueKind_Protected , 0x19 .> return ValueKind_Explicit , 0x1A .> return ValueKind_Static , 0x05 .> return ValueKind_Private ] "constant kind" pMetaInfo :: Parser MetaInfo pMetaInfo = MetaInfo_Info <$> pNameIndex <*> pCountU30 pMetaItem "meta info" pMetaItem :: Parser MetaItem pMetaItem = MetaItem_Item <$> pNameIndex <*> pNameIndex "meta item" pInstanceInfo :: Parser InstanceInfo pInstanceInfo = do name <- pMultinameIndex super <- pMultinameIndex flags <- pFlags [ (0x01, InstanceFlag_ClassSealed) , (0x02, InstanceFlag_ClassFinal) , (0x04, InstanceFlag_ClassInterface) , (0x08, InstanceFlag_ClassProtected) ] protected <- if InstanceFlag_ClassProtected `elem` flags then (pNamespaceIndex "protected") else return 0 itfs <- pCountU30 pMultinameIndex con <- pMethodIndex traits <- pCountU30 pTrait return (InstanceInfo_Info name super flags protected itfs con traits) "instance info" pMethodIndex :: Parser Word32 pMethodIndex = pU30 "method index" pTrait :: Parser Trait pTrait = do name <- pMultinameIndex info <- pU8 pInfo ("trait info: " ++ show info) let tp = info .&. 0x0F body <- case tp of 0 -> pTraitSlot TraitData_Slot 1 -> pTraitMethod TraitData_Method 2 -> pTraitMethod TraitData_Getter 3 -> pTraitMethod TraitData_Setter 4 -> pTraitClass 5 -> pTraitFun 6 -> pTraitSlot TraitData_Const _ -> fail ("unknown trait type: " ++ show info) let flags = shiftR info 4 attrs = matchFlags [ (0x1, TraitAttr_Final) , (0x2, TraitAttr_Override) , (0x4, TraitAttr_Metadata) ] flags meta <- if TraitAttr_Metadata `elem` attrs then pCountU30 pMetadataIndex else return [] return (Trait_Trait name body attrs meta) "trait" pTraitSlot :: (Word32 -> Word32 -> Word32 -> ValueKind -> TraitData) -> Parser TraitData pTraitSlot f = do slotId <- pSlotId typeName <- pMultinameIndex vindex <- (pU30 "vindex") vkind <- if vindex > 0 then pValueKind else return ValueKind_Undefined return (f slotId typeName vindex vkind) "trait slot" pTraitMethod :: (Word32 -> Word32 -> TraitData) -> Parser TraitData pTraitMethod f = f <$> pDispId <*> pMethodIndex "trait method" pTraitClass :: Parser TraitData pTraitClass = TraitData_Class <$> pSlotId <*> pClassIndex "trait class" pTraitFun :: Parser TraitData pTraitFun = TraitData_Function <$> pSlotId <*> pMethodIndex "trait fun" pDispId :: Parser Word32 pDispId = pU30 "dispatch id" pSlotId :: Parser Word32 pSlotId = pU30 "slot id" pClassIndex :: Parser Word32 pClassIndex = pU30 "class index" pMetadataIndex :: Parser Word32 pMetadataIndex = pU30 "metadata index" pClassInfo :: Parser ClassInfo pClassInfo = ClassInfo_Info <$> pMethodIndex <*> pCountU30 pTrait "class info" pScriptInfo :: Parser ScriptInfo pScriptInfo = ScriptInfo_Info <$> pMethodIndex <*> pCountU30 pTrait "script info" -- | Parses a method body and filters out the location information such that only -- those remain that are targets of branch instructions, and those that -- give location info to branching instructions. pBodyInfo :: Parser BodyInfo pBodyInfo = instrLocFilter <$> pBodyInfo' -- | Parses a method body with an abundance of location information pBodyInfo' :: Parser BodyInfo pBodyInfo' = BodyInfo_Info <$> pMethodIndex <*> (pU30 "max stack") <*> (pU30 "local count") <*> (pU30 "init scope depth") <*> (pU30 "max scope depth") <*> pInstrs <*> pCountU30 pException <*> pCountU30 pTrait "method body" pInstrs :: Parser [Instruction] pInstrs = do n <- pU30 p <- pPos pInstrArray p (p + fromIntegral n) -- | Parses the next instruction, only if its pInstrArray :: Int -> Int -> Parser [Instruction] pInstrArray beginPos endPos = rec where rec = do p <- pPos if p < endPos then (\i is -> Instruction_Location (p - beginPos) : i : is) <$> pInstr <*> rec else return [] pInstr :: Parser Instruction pInstr = pTable table "instruction" table :: [(Word8, Parser Instruction)] table = [ 0xA0 .> return Instruction_Add , 0xC5 .> return Instruction_Add_i , 0x9B .> return Instruction_Add_d , 0x53 .> Instruction_ApplyType <$> pIndex , 0x86 .> Instruction_AsType <$> pMultinameIndex , 0x87 .> return Instruction_AsTypeLate , 0xA8 .> return Instruction_BitAnd , 0x97 .> return Instruction_BitNot , 0xA9 .> return Instruction_BitOr , 0xAA .> return Instruction_BitXor , 0x01 .> return Instruction_Breakpoint , 0xF2 .> Instruction_BreakLine <$> pLine , 0x41 .> Instruction_Call <$> pArgCount , 0x4D .> Instruction_CallInterface <$> pNameIndex <*> pArgCount , 0x43 .> Instruction_CallMethod <$> pIndex <*> pArgCount , 0x46 .> Instruction_CallProp <$> pNameIndex <*> pArgCount , 0x4C .> Instruction_CallPropLex <$> pNameIndex <*> pArgCount , 0x4F .> Instruction_CallPropVoid <$> pNameIndex <*> pArgCount , 0x44 .> Instruction_CallStatic <$> pMethodIndex <*> pArgCount , 0x45 .> Instruction_CallSuper <$> pNameIndex <*> pArgCount , 0x4B .> return Instruction_CallSuperId , 0x4E .> Instruction_CallSuperVoid <$> pNameIndex <*> pArgCount , 0x78 .> return Instruction_CheckFilter , 0x80 .> Instruction_Coerce <$> pNameIndex , 0x81 .> return Instruction_Coerce_b , 0x82 .> return Instruction_Coerce_a , 0x83 .> return Instruction_Coerce_i , 0x84 .> return Instruction_Coerce_d , 0x85 .> return Instruction_Coerce_s , 0x88 .> return Instruction_Coerce_u , 0x89 .> return Instruction_Coerce_o , 0x9A .> return Instruction_Concat , 0x42 .> Instruction_Construct <$> pArgCount , 0x4A .> Instruction_ConstructProp <$> pNameIndex <*> pArgCount , 0x49 .> Instruction_ConstructSuper <$> pArgCount , 0x76 .> return Instruction_Convert_b , 0x73 .> return Instruction_Convert_i , 0x75 .> return Instruction_Convert_d , 0x77 .> return Instruction_Convert_o , 0x74 .> return Instruction_Convert_u , 0x70 .> return Instruction_Convert_s , 0xEF .> Instruction_Debug <$> pDebugType <*> pNameIndex <*> pRegIndex <*> pU30 , 0xF1 .> Instruction_DebugFile <$> pNameIndex , 0xF0 .> Instruction_DebugLine <$> pLine , 0x94 .> Instruction_DecLocal <$> pRegIndex , 0xC3 .> Instruction_DecLocal_i <$> pRegIndex , 0x93 .> return Instruction_Decrement , 0xC1 .> return Instruction_Decrement_i , 0x6A .> Instruction_DeleteProperty <$> pNameIndex , 0x6B .> return Instruction_DeletePropertyLate , 0xA3 .> return Instruction_Divide , 0x2A .> return Instruction_Dup , 0x06 .> Instruction_Dxns <$> pNameIndex , 0x07 .> return Instruction_DxnsLate , 0xAB .> return Instruction_Equals , 0x72 .> return Instruction_EscXAttr , 0x71 .> return Instruction_EscXElem , 0x5F .> Instruction_FindDef <$> pNameIndex , 0x5B .> Instruction_FindPropertyGlobalStrict <$> pNameIndex , 0x5C .> Instruction_FindPropertyGlobal <$> pNameIndex , 0x5E .> Instruction_FindProperty <$> pNameIndex , 0x5D .> Instruction_FindPropStrict <$> pNameIndex , 0x59 .> Instruction_GetDescendants <$> pNameIndex , 0x64 .> return Instruction_GetGlobalScope , 0x6E .> Instruction_GetGlobalSlot <$> pSlotIndex , 0x60 .> Instruction_GetLex <$> pNameIndex , 0x62 .> Instruction_GetLocal <$> pRegIndex , 0xD0 .> return Instruction_GetLocal0 , 0xD1 .> return Instruction_GetLocal1 , 0xD2 .> return Instruction_GetLocal2 , 0xD3 .> return Instruction_GetLocal3 , 0x67 .> Instruction_GetOuterScope <$> pNameIndex , 0x66 .> Instruction_GetProperty <$> pNameIndex , 0x65 .> Instruction_GetScopeObject <$> (pU8 "scope index") , 0x6C .> Instruction_GetSlot <$> pSlotIndex , 0x04 .> Instruction_GetSuper <$> pNameIndex , 0xB0 .> return Instruction_GreaterEquals , 0xAF .> return Instruction_GreaterThan , 0x1F .> return Instruction_HasNext , 0x32 .> Instruction_HasNext2 <$> pRegIndex <*> pRegIndex , 0x13 .> Instruction_IfEq <$> pOffset , 0x12 .> Instruction_IfFalse <$> pOffset , 0x18 .> Instruction_IfGe <$> pOffset , 0x17 .> Instruction_IfGt <$> pOffset , 0x16 .> Instruction_IfLe <$> pOffset , 0x15 .> Instruction_IfLt <$> pOffset , 0x0F .> Instruction_IfNGe <$> pOffset , 0x0E .> Instruction_IfNGt <$> pOffset , 0x0D .> Instruction_IfNLe <$> pOffset , 0x0C .> Instruction_IfNLt <$> pOffset , 0x14 .> Instruction_IfNe <$> pOffset , 0x19 .> Instruction_IfStrictEq <$> pOffset , 0x1A .> Instruction_IfStrictNe <$> pOffset , 0x11 .> Instruction_IfTrue <$> pOffset , 0xB4 .> return Instruction_In , 0x92 .> Instruction_IncLocal <$> pRegIndex , 0xC2 .> Instruction_IncLocal_i <$> pRegIndex , 0x91 .> return Instruction_Increment , 0xC0 .> return Instruction_Increment_i , 0x68 .> Instruction_InitProperty <$> pNameIndex , 0xB1 .> return Instruction_InstanceOf , 0xB2 .> Instruction_IsType <$> pNameIndex , 0xB3 .> return Instruction_IsTypeLate , 0x10 .> Instruction_Jump <$> pOffset , 0x08 .> Instruction_Kill <$> pRegIndex , 0x09 .> return Instruction_Label , 0xAE .> return Instruction_LessEquals , 0xAD .> return Instruction_LessThan , 0x38 .> return Instruction_LoadFloat32 , 0x39 .> return Instruction_LoadFloat64 , 0x35 .> return Instruction_LoadIndirect8 , 0x36 .> return Instruction_LoadIndirect16 , 0x37 .> return Instruction_LoadIndirect32 , 0x1B .> Instruction_LookupSwitch <$> pOffset <*> (pU30 >>= pCount pOffset . (+1) . fromIntegral) , 0xA5 .> return Instruction_Lshift , 0xA4 .> return Instruction_Modulo , 0xA2 .> return Instruction_Multiply , 0xC7 .> return Instruction_Multiply_i , 0x90 .> return Instruction_Negate , 0xC4 .> return Instruction_Negate_i , 0x57 .> return Instruction_NewActivation , 0x56 .> Instruction_NewArray <$> pArgCount , 0x5A .> Instruction_NewCatch <$> pExceptionIndex , 0x58 .> Instruction_NewClass <$> pClassIndex , 0x40 .> Instruction_NewFunction <$> pMethodIndex , 0x55 .> Instruction_NewObject <$>pArgCount , 0x1E .> return Instruction_NextName , 0x23 .> return Instruction_NextValue , 0x02 .> return Instruction_Nop , 0x96 .> return Instruction_Not , 0x29 .> return Instruction_Pop , 0x1D .> return Instruction_PopScope , 0x24 .> Instruction_PushByte <$> pU8 , 0x2F .> Instruction_PushDouble <$> pDoubleIndex , 0x27 .> return Instruction_PushFalse , 0x2D .> Instruction_PushInt <$> pU30 , 0x31 .> Instruction_PushNamespace <$> pNamespaceIndex , 0x28 .> return Instruction_PushNaN , 0x20 .> return Instruction_PushNull , 0x30 .> return Instruction_PushScope , 0x25 .> Instruction_PushShort <$> pU30 , 0x2C .> Instruction_PushString <$> pStringIndex , 0x26 .> return Instruction_PushTrue , 0x2E .> Instruction_PushUInt <$> pIntIndex , 0x21 .> return Instruction_PushUndefined , 0x1C .> return Instruction_PushWith , 0x48 .> return Instruction_ReturnValue , 0x47 .> return Instruction_ReturnVoid , 0xA6 .> return Instruction_Rshift , 0x63 .> Instruction_SetLocal <$> pRegIndex , 0xD4 .> return Instruction_SetLocal0 , 0xD5 .> return Instruction_SetLocal1 , 0xD6 .> return Instruction_SetLocal2 , 0xD7 .> return Instruction_SetLocal3 , 0x6F .> Instruction_SetGlobalSlot <$> pSlotIndex , 0x61 .> Instruction_SetProperty <$> pNameIndex , 0x69 .> return Instruction_SetPropertyLate , 0x6D .> Instruction_SetSlot <$> pSlotIndex , 0x05 .> Instruction_SetSuper <$> pNameIndex , 0x50 .> return Instruction_SignExtend1 , 0x51 .> return Instruction_SignExtend8 , 0x52 .> return Instruction_SignExtend16 , 0x3D .> return Instruction_StoreFloat32 , 0x3E .> return Instruction_StoreFloat64 , 0x3A .> return Instruction_StoreIndirect8 , 0x3B .> return Instruction_StoreIndirect16 , 0x3C .> return Instruction_StoreIndirect32 , 0xAC .> return Instruction_StrictEquals , 0xA1 .> return Instruction_Substract , 0xC6 .> return Instruction_Substract_i , 0x2B .> return Instruction_Swap , 0x03 .> return Instruction_Throw , 0xF3 .> return Instruction_Timestamp , 0x95 .> return Instruction_TypeOf , 0xA7 .> return Instruction_Urshift ] infix 2 .> (.>) :: Word8 -> Parser a -> (Word8, Parser a) k .> v = (k, v) pArgCount :: Parser Word32 pArgCount = pU30 "argument count" pIndex :: Parser Word32 pIndex = pU30 "index" pSlotIndex :: Parser Word32 pSlotIndex = pU30 "slot" pRegIndex :: Parser Word32 pRegIndex = pU30 "register" pOffset :: Parser Word32 pOffset = pS24 "offset" pLine :: Parser Word32 pLine = pU30 "line nr" pExceptionIndex :: Parser Word32 pExceptionIndex = pU30 "exception index" pIntIndex :: Parser Word32 pIntIndex = pU30 "int index" pDoubleIndex :: Parser Word32 pDoubleIndex = pU30 "double index" pStringIndex :: Parser Word32 pStringIndex = pU30 "string index" pDebugType :: Parser DebugType pDebugType = DebugType_Local <$ pByte 0x01 "debug type" pException :: Parser Exception pException = Exception_Info <$> (pU30 "from index") <*> (pU30 "to index") <*> (pU30 "target index") <*> pNameIndex <*> pNameIndex "exception" parseAbcFile :: FilePath -> IO AbcFile parseAbcFile = parseIt (pAbcFile <* pEnd) parseSwfFile :: FilePath -> IO SwfFile parseSwfFile = parseIt pSwfFile parseAbcAsSwf :: FilePath -> IO SwfFile parseAbcAsSwf = parseIt (abcToSwf <$> pAbcFile <* pEnd) abcToSwf :: AbcFile -> SwfFile abcToSwf abc = swf where swf = SwfFile_File False 9 0 rect 15 0 tags rect = Rect_Rect 15 0 0 10000 7500 tags = [begin, code, end] begin = Tag_FileAttributes True True False True False end = Tag_End code = Tag_Abc [] (fromString "abc") abc parseAnyAsSwf :: FilePath -> IO SwfFile parseAnyAsSwf = parseAny [ \str -> if B.take 2 str == hPkZip then let str' = decompress str in str' `seq` Just (str', pSwfFile) else Nothing , \str -> let hd = B.take 3 str in if hd == hUSwf || hd == hCSwf then Just (str, pSwfFile) else Nothing , \str -> if B.take 4 str == hAbc then Just (str, abcToSwf <$> pAbcFile <* pEnd) else Nothing ] where hPkZip = B.pack [0x50,0x4B] hUSwf = B.pack [0x46,0x57,0x53] hCSwf = B.pack [0x43,0x57,0x53] hAbc = B.pack [0x10,0x00,0x2E,0x00] decompress str = let archive = toArchive str swfFiles = filter (\file -> takeExtension file == ".swf") (filesInArchive archive) nFiles = length swfFiles file = head swfFiles in case nFiles of 0 -> error "no .swf file in archive." 1 -> case findEntryByPath file archive of Nothing -> error ".swf entry not found" Just e -> fromEntry e _ -> error "too many .swf files in archive"