diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Yuras Shumovich + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Yuras Shumovich nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,45 @@ +# hfd + +## About + +hfd is a console debugger for flash applications. +It is written in Haskell. + +## hfd vs fdb + +Flash debugger, included into flex sdk (fdb) lacks good readline interface. +Also it very often fails (and even crashes) when printing properties (at least linux version). +So the idea is to create flash debugger with user friendly interface and good properties support. + +## Installation + +You need Haskell Platform to install hfd. + + $ cd hfd + $ cabal update + $ cabal install + +## Current state + +hfd supports most of basic debugger features + +* set, list, delete breakpoints +* execution control: continue, step, next, finish +* inspect variable +* inspect properties (call getters) +* break on exception +* show call stack +* list source code (currently only around current position) +* haskeline user interface (commands history, basic completion) + +Features, that are not implemented still + +* improved listing of source code +* walk through call stack +* enable/disable breakpoints +* conditional breakpoints +* expression evaluation +* set variables +* print arguments when printing call stack +* improved completion + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hfd.cabal b/hfd.cabal new file mode 100644 --- /dev/null +++ b/hfd.cabal @@ -0,0 +1,39 @@ +Name: hfd +Version: 0.0.2 +Synopsis: Flash debugger +License: BSD3 +License-file: LICENSE +Author: Yuras Shumovich +Maintainer: shumovichy@gmail.com +Category: Development +Build-type: Simple +Extra-source-files: README.md +Cabal-version: >=1.6 +Description: Flash debugger. You need debug flash player installed to use it. + +Executable hfd + Hs-source-dirs: src + Main-is: hfd.hs + Build-depends: + base < 5, + network < 3.0.0.0, + haskeline < 0.7.0.0, + iteratee < 1.0.0.0, + bytestring < 1.0.0.0, + MonadCatchIO-transformers < 0.3.0.0, + transformers < 0.3.0.0, + MissingH < 2.0.0.0 + Other-modules: + App, + Inst, + IMsg, + OMsg, + UCmd, + Print, + Proto + Ghc-options: -Wall -fno-warn-orphans + +Source-repository head + Type: git + Location: git@github.com:Yuras/hfd.git + diff --git a/src/App.hs b/src/App.hs new file mode 100644 --- /dev/null +++ b/src/App.hs @@ -0,0 +1,140 @@ + +-- | This module defines App monad + +module App +( +App, +runApp, +AppState(..), +FileEntry(..), +StackFrame, +Breakpoint(..), +setStack, +addFileEntry, +getFileEntry, +setLastCmd, +setBreakpoints, +removeBreakpoint, +newBreakId +) +where + +import Data.ByteString (ByteString) +import Data.Iteratee (Iteratee, run) +import Data.Iteratee.IO (enumHandle) +import System.IO (Handle) +import System.Environment (getEnv) +import System.Console.Haskeline (InputT, runInputT, Settings(..), CompletionFunc, simpleCompletion) +import Control.Monad (liftM) +import Control.Monad.Trans.State (StateT, evalStateT, get, put) +import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class(MonadIO) + +import UCmd (UCmd(..), suggestBaseCmd) +import Inst () -- 'MonadCatchIO' instance for 'InputT' + +-- | App monad +type App m = Iteratee ByteString (InputT (StateT AppState m)) + +-- | Run App monad +runApp :: Handle -- ^ Input/Output stream to be used + -- to communicate with player + -> App IO a -- ^ Application + -> IO a +runApp h app = do + home <- getEnv "HOME" + let history = home ++ "/.hfd_history" + flip evalStateT (defaultState h) $ + runInputT (hlSettings history) (enumHandle 1 h app >>= run) + +-- | Make haskeline settings +hlSettings :: MonadIO m => String -> Settings (StateT AppState m) +hlSettings history = Settings {historyFile = Just history, complete = completeFunc, autoAddHistory = True} + +-- | Complete base commands +completeFunc :: MonadIO m => CompletionFunc (StateT AppState m) +completeFunc (s, _) = do + let s' = reverse s + let sgs = suggestBaseCmd s' + return (s, map (simpleCompletion . drop (length s')) sgs) + +-- | Application state +data AppState = AppState { + asFiles :: [(Int, FileEntry)], -- ^ map of file entries + asStack :: [StackFrame], -- ^ current stack if any + asBreaks :: [(Int, Breakpoint)], -- ^ list of breakpoints + asLastBreakId :: Int, -- ^ last used breakpoint id + asLastCmd :: Maybe UCmd, -- ^ last command entered by user + asHandle :: Handle -- ^ handle to player +} deriving Show + +-- | Represents single breakpoint +data Breakpoint = Breakpoint { + bpFileId :: Int, + bpLine :: Int +} deriving Show + +-- | Set breakpoints +setBreakpoints :: Monad m => [(Int, Breakpoint)] -> App m () +setBreakpoints bs = do + state <- lift . lift $ get + lift . lift $ put state {asBreaks = bs} + +-- | Remove breakpoint by id +removeBreakpoint :: Monad m => Int -> App m () +removeBreakpoint iD = do + state <- lift . lift $ get + let bs = filter ((/= iD) . fst) $ asBreaks state + setBreakpoints bs + +-- | Allocate id for new breakpoint +newBreakId :: Monad m => App m Int +newBreakId = do + state <- lift . lift $ get + let newId = asLastBreakId state + 1 + lift . lift $ put state {asLastBreakId = newId} + return newId + +-- | Default application state contains nothing +defaultState :: Handle -> AppState +defaultState = AppState [] [] [] 0 Nothing + +-- | File entry represents one source file +data FileEntry = FileEntry { + fePath :: String, -- ^ Path to file as recieved from player, + -- e.g. @\/home\/user\/proj;com\/example;Main.as@ + feContent :: [String] -- ^ File content +} deriving Show + +-- | Represents stack frame +-- file id, line and function name +type StackFrame = (Int, Int, String) + +-- | Returns `FileEntry` by id +getFileEntry :: Monad m => Int -> App m (Maybe FileEntry) +getFileEntry iD = do + fs <- lift . lift $ liftM asFiles get + return $ lookup iD fs + +-- | Set current stack +setStack :: Monad m => [StackFrame] -> App m () +setStack st = do + state <- lift $ lift get + lift . lift $ put state {asStack = st} + +-- | Add new file entry to app state +-- +-- XXX: check that ids are unique +addFileEntry :: Monad m => (Int, FileEntry) -> App m () +addFileEntry fe = do + state <- lift $ lift get + let fes = asFiles state + lift . lift $ put state {asFiles = fe : fes} + +-- | Set last cmd entered by user +setLastCmd :: Monad m => Maybe UCmd -> App m () +setLastCmd (Just UCmdEmpty) = return () +setLastCmd cmd = lift . lift $ do + state <- get + put $ state {asLastCmd = cmd} + diff --git a/src/IMsg.hs b/src/IMsg.hs new file mode 100644 --- /dev/null +++ b/src/IMsg.hs @@ -0,0 +1,353 @@ + +-- | This module defines messages from player to debugger + +module IMsg +( +IMsg(..), +AMF(..), +AMFValue(..), +amfUndecoratedName, +nextIMessage +) +where + +import Data.Word (Word8, Word16, Word32) +import Data.ByteString (ByteString, pack) +import qualified Data.ByteString.Char8 as BSChar +import qualified Data.Iteratee as I +import Data.Iteratee (Iteratee, Endian(LSB), endianRead4, endianRead2) +import Control.Monad (replicateM, when) + + +-- * Interface + +-- | Messages sent by player +data IMsg + -- | 00 or 00 + = IMsgMenuState Word32 Word32 + -- | 03 or 03 + | IMsgCreateAnonymObject Word32 + -- | 05 or 05 + | IMsgTrace String + -- | 0A or 10 + | IMsgSetField Word32 ByteString [Word8] + -- | 0B or 11 + | IMsgDeleteField Word32 ByteString + -- | 0C or 12 + | IMsgMovieAttr ByteString ByteString + -- | 0E or 14 + | IMsgSwdFileEntry Word32 Word32 ByteString ByteString Word32 + -- | 0F or 15 + | IMsgAskBreakpoints + -- | 10 or 16 + | IMsgBreakHit Word16 Word16 Word32 ByteString + -- | 11 or 17 + | IMsgBreak + -- | 12 or 18 + | IMsgSetLocalVars Word32 + -- | 13 or 19 + | IMsgBreakpoints [(Word16, Word16)] + -- | 14 or 20 + | IMsgNumSwdFileEntry Word32 Word32 + -- | 19 or 25 + | IMsgProcessTag + -- | 1A or 26 + | IMsgVersion Word32 Word8 + -- | 1B or 27 + | IMsgBreakHitEx Word16 Word16 [(Word16, Word16, Word32, String)] + -- | 1C or 28 + | IMsgSetField2 Word32 ByteString [Word8] + -- | 1E or 30 + | IMsgGetField AMF [AMF] + -- | 1F or 31 + | IMsgFunctionFrame Word32 Word32 AMF [AMF] + -- | 20 or 32 + | IMsgDebuggerOption ByteString ByteString + -- | 24 or 36 + | IMsgException Word32 String [Word8] + -- | All other + | IMsgUnknown Word32 [Word8] + deriving Show + +-- | Represents Action Message Format entry +data AMF = AMF { + amfParent :: Word32, + amfName :: String, + amfFlags :: Word32, + amfValue :: AMFValue +} deriving Show + +-- | Some objects (e.g. private members) could be decorated +amfUndecoratedName :: AMF -> String +amfUndecoratedName = reverse . takeWhile (/= ':') . reverse . amfName + +-- | Represents AMF value +data AMFValue = AMFDouble Double + | AMFBool Bool + | AMFString String + | AMFObject Word32 Word32 Word16 Word16 String + | AMFNull + | AMFUndefined + | AMFTrails + deriving Show + +-- | Read next message from player +nextIMessage :: Monad m => Iteratee ByteString m IMsg +nextIMessage = do + len <- endianRead4 e_ + idi <- endianRead4 e_ + case idi of + 00 -> iterMenuState len + 03 -> iterCreateAnonymObject len + 05 -> iterTrace len + 10 -> iterSetField len + 11 -> iterDeleteField len + 12 -> iterMovieAttr len + 14 -> iterSwdFileEntry len + 15 -> iterAskBreakpoints len + 16 -> iterBreakHit len + 17 -> iterBreak len + 18 -> iterSetLocalVars len + 19 -> iterBreakpoints len + 20 -> iterNumSwdFileEntry len + 25 -> iterProcessTag len + 26 -> iterVersion len + 27 -> iterBreakHitEx len + 28 -> iterSetField2 len + 30 -> iterGetField len + 31 -> iterFunctionFrame len + 32 -> iterDebuggerOption len + 36 -> iterException len + _ -> iterUnknown idi len + + +-- * Internals +-- ** Iteratees to parse messages + +iterGetField :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterGetField len = do + (amf, ln) <- takeAMF + children <- takeChildren (fromIntegral len - ln) [] + return $ IMsgGetField amf children + +iterDebuggerOption :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterDebuggerOption len = do + (op, ol) <- takeStr + (val, vl) <- takeStr + when (fromIntegral len /= ol + vl) (fail "iterDebuggerOption: wrong size") + return $ IMsgDebuggerOption op val + +iterFunctionFrame :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterFunctionFrame len = do + depth <- endianRead4 e_ + when (depth /= 0) (fail "iterFunctionFrame: depth != 0, not implemented") + addr <- endianRead4 e_ + (amf, ln) <- takeAMF + children <- takeChildren (fromIntegral len - 4 - 4 - ln) [] + return $ IMsgFunctionFrame depth addr amf children + +takeChildren :: Monad m => Int -> [AMF] -> Iteratee ByteString m [AMF] +takeChildren 0 res = return $ reverse res +takeChildren l res = do + when (l < 0) (fail "iterFunctionFrame: wrong size") + (amf, vl) <- takeAMF + takeChildren (fromIntegral l - vl) (amf : res) + +iterException :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterException len = do + arg1 <- endianRead4 e_ + (ex, ln) <- takeStr + arg3 <- replicateM (fromIntegral len - 4 - ln) I.head + return $ IMsgException arg1 (bs2s ex) arg3 + +iterTrace :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterTrace len = do + (msg, ln) <- takeStr + when (len /= fromIntegral ln) (fail "iterTrace: wrong length") + return $ IMsgTrace $ bs2s msg + +iterProcessTag :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterProcessTag len = do + when (len /= 0) (fail "iterProcessTag: wrong length") + return IMsgProcessTag + +iterDeleteField :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterDeleteField len = do + addr <- endianRead4 e_ + (name, ln) <- takeStr + when (len /= fromIntegral ln + 4) (fail "iterDeleteField: wrong length") + return $ IMsgDeleteField addr name + +iterSetField :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterSetField len = do + addr <- endianRead4 e_ + (name, ln) <- takeStr + amf <- replicateM (fromIntegral len - 4 - ln) I.head + return $ IMsgSetField addr name amf + +iterSetField2 :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterSetField2 len = do + addr <- endianRead4 e_ + (name, ln) <- takeStr + amf <- replicateM (fromIntegral len - 4 - ln) I.head + return $ IMsgSetField2 addr name amf + +iterMenuState :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterMenuState len = do + when (len /= 8) (fail "iterMenuState: wrong length") + arg1 <- endianRead4 e_ + arg2 <- endianRead4 e_ + return $ IMsgMenuState arg1 arg2 + +iterCreateAnonymObject :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterCreateAnonymObject len = do + when (len /= 4) (fail "iterCreateAnonymObject: wrong length") + addr <- endianRead4 e_ + return $ IMsgCreateAnonymObject addr + +iterSetLocalVars :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterSetLocalVars len = do + when (len /= 4) (fail "iterSetLocalVars: wrong length") + addr <- endianRead4 e_ + return $ IMsgSetLocalVars addr + +iterBreak :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterBreak len = do + when (len /= 0) (fail "iterBreak: wrong length") + return IMsgBreak + +-- XXX: Check length +iterBreakHitEx :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterBreakHitEx _ = do + fileId <- endianRead2 e_ + line <- endianRead2 e_ + depth <- endianRead4 e_ + stack <- replicateM (fromIntegral depth) iterFrame + return $ IMsgBreakHitEx fileId line stack + where + iterFrame = do + fileId <- endianRead2 e_ + line <- endianRead2 e_ + addr <- endianRead4 e_ + (entry, _) <- takeStr + return (fileId, line, addr, bs2s entry) + +iterBreakHit :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterBreakHit len = do + fileId <- endianRead2 e_ + line <- endianRead2 e_ + addr <- endianRead4 e_ + (function, ln) <- takeStr + when (len /= fromIntegral ln + 8) (fail "iterBreakHit: wrong length") + return $ IMsgBreakHit fileId line addr function + +iterAskBreakpoints :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterAskBreakpoints len = do + when (len /= 0) (fail "iterAskBreakpoints: wrong length") + return IMsgAskBreakpoints + +-- XXX: Check length +iterBreakpoints :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterBreakpoints _ = do + count <- endianRead4 e_ + l <- replicateM (fromIntegral count) iter' + return $ IMsgBreakpoints l + where + iter' = do + fileId <- endianRead2 e_ + line <- endianRead2 e_ + return (fileId, line) + +iterSwdFileEntry :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterSwdFileEntry len = do + fileId <- endianRead4 e_ + unIndex <- endianRead4 e_ + (name, ln1) <- takeStr + (source, ln2) <- takeStr + swfIndex <- endianRead4 e_ + when (len /= fromIntegral (ln1 + ln2) + 12) + (fail "iterSwdFileEntry: wrong length") + return $ IMsgSwdFileEntry fileId unIndex name source swfIndex + +iterUnknown :: Monad m => Word32 -> Word32 -> Iteratee ByteString m IMsg +iterUnknown idi len = do + dat <- replicateM (fromIntegral len) I.head + return $ IMsgUnknown idi dat + +iterVersion :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterVersion len = do + when (len /= 5) (fail "iterVersion: wrong length") + major <- endianRead4 e_ + minor <- I.head + return $ IMsgVersion major minor + +iterMovieAttr :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterMovieAttr len = do + (name, ln1) <- takeStr + (value, ln2) <- takeStr + when (len /= fromIntegral (ln1 + ln2)) (fail "iterMovieAttr: wrong length") + return $ IMsgMovieAttr name value + +iterNumSwdFileEntry :: Monad m => Word32 -> Iteratee ByteString m IMsg +iterNumSwdFileEntry len = do + when (len /= 8) (fail "iterNumSwdFileEntry: wrong length") + num <- endianRead4 e_ + index <- endianRead4 e_ + return $ IMsgNumSwdFileEntry num index + + +-- ** Utilities + +e_ :: Endian +e_ = LSB + +-- | Read zero terminated string +-- returns string and number of bytes read +takeStr :: Monad m => Iteratee ByteString m (ByteString, Int) +takeStr = takeStr' [] 0 + where + takeStr' :: Monad m => + [Word8] -> Int -> Iteratee ByteString m (ByteString, Int) + takeStr' cs len = do + c <- I.head + if c == 0 + then return . flip (,) (len + 1) . pack . reverse $ cs + else takeStr' (c:cs) (len + 1) + +-- | Read AMF +takeAMF :: Monad m => Iteratee ByteString m (AMF, Int) +takeAMF = do + parent <- endianRead4 e_ + (name, nl) <- takeStr + vtype <- endianRead2 e_ + flags <- endianRead4 e_ + (value, vl) <- takeAMFValue vtype + return (AMF parent (bs2s name) flags value, 4 + nl + 2 + 4 + vl) + +-- | Read AMF value +takeAMFValue :: Monad m => Word16 -> Iteratee ByteString m (AMFValue, Int) +takeAMFValue 0 = do + (str, ln) <- takeStr + return (AMFDouble . read . bs2s $ str, ln) +takeAMFValue 1 = do + v <- I.head + return (AMFBool (v /= 0), 1) +takeAMFValue 2 = do + (str, ln) <- takeStr + return (AMFString (bs2s str), ln) +takeAMFValue 3 = do + oid <- endianRead4 e_ + tp <- endianRead4 e_ + isF <- endianRead2 e_ + r <- endianRead2 e_ + (typeName, tl) <- takeStr + return (AMFObject oid tp isF r (bs2s typeName), 4 + 4 + 2 + 2 + tl) +takeAMFValue 5 = return (AMFNull, 0) +takeAMFValue 6 = return (AMFUndefined, 0) +takeAMFValue 19 = return (AMFTrails, 0) +takeAMFValue tp = fail $ "takeAMFValue: not implemented: " ++ show tp + +-- | ByteString to String +bs2s :: ByteString -> String +bs2s = BSChar.unpack + diff --git a/src/Inst.hs b/src/Inst.hs new file mode 100644 --- /dev/null +++ b/src/Inst.hs @@ -0,0 +1,17 @@ + +-- | This module defines 'MonadCatchIO' instance for 'InputT' + +module Inst +( +) +where + +import qualified System.Console.Haskeline as HL +import System.Console.Haskeline (InputT, MonadException) +import Control.Monad.CatchIO (MonadCatchIO(..)) + +instance (MonadCatchIO m, MonadException m) => MonadCatchIO (InputT m) where + catch = HL.catch + block = HL.block + unblock = HL.unblock + diff --git a/src/OMsg.hs b/src/OMsg.hs new file mode 100644 --- /dev/null +++ b/src/OMsg.hs @@ -0,0 +1,91 @@ + +-- | This module defines output messages, sent to player + +module OMsg +( +OMsg(..), +binOMsg +) +where + +import qualified Data.ByteString as BS +import Data.ByteString (ByteString, empty, pack, append) +import qualified Data.ByteString.Char8 as BSChar +import Data.Word (Word32, Word16) +import Data.Bits (shiftR) + +-- | Messages that debugger can send to player +data OMsg + -- | 0F or 15 + = OMsgContinue + -- | 11 or 17 + | OMsgSetBreakpoint Word16 Word16 + -- | 12 or 18 + | OMsgClearBreakpoint Word16 Word16 + -- | 13 or 19 + | OMsgClearBreakpoints + -- | 14 or 20 + | OMsgNext + -- | 15 or 21 + | OMsgStep + -- | 16 or 22 + | OMsgFinish + -- | 17 or 23 + | OMsgProcessTag + -- | 19 or 25 + | OMsgGetField Word32 String + -- | 1A or 26 + | OMsgGetFunctionFrame Word32 + -- | 1C or 28 + | OMsgSetDebuggerOptions String String + deriving Show + +-- | Convert `OMsg` to `ByteString` +binOMsg :: OMsg -> ByteString +binOMsg OMsgContinue = mkBin 15 empty +binOMsg (OMsgSetBreakpoint fl ln) = mkBin 17 (mkBinWord32 0 `append` mkBinWord16 fl `append` mkBinWord16 ln) +binOMsg (OMsgClearBreakpoint fl ln) = mkBin 18 (mkBinWord32 0 `append` mkBinWord16 fl `append` mkBinWord16 ln) +binOMsg OMsgClearBreakpoints = mkBin 19 empty +binOMsg OMsgNext = mkBin 20 empty +binOMsg OMsgStep = mkBin 21 empty +binOMsg OMsgFinish = mkBin 22 empty +binOMsg OMsgProcessTag = mkBin 23 empty +binOMsg (OMsgGetField addr name) = mkBin 25 (mkBinWord32 addr `append` s2bs name `append` pack [0] `append` mkBinWord32 15) +binOMsg (OMsgGetFunctionFrame depth) = mkBin 26 (mkBinWord32 depth) +binOMsg (OMsgSetDebuggerOptions n v) = mkBin 28 (s2bs n `append` pack [0] `append` s2bs v `append` pack [0]) + +-- | Make binary message +-- +-- Format: length (4b) + message id (4b) + message +-- +-- All data is little endian +mkBin :: Word32 -> ByteString -> ByteString +mkBin idi msg = BS.concat [l, i, msg] + where + i = mkBinWord32 idi + l = mkBinWord32 $ fromIntegral $ BS.length msg + +-- | Convert `Word32` to `ByteString` using little endian encoding +mkBinWord32 :: Word32 -> ByteString +mkBinWord32 i = pack w + where + w = + [ fromIntegral i + , fromIntegral (i `shiftR` 8) + , fromIntegral (i `shiftR` 16) + , fromIntegral (i `shiftR` 24) + ] + +-- | Convert `Word16` to `ByteString` using little endian encoding +mkBinWord16 :: Word16 -> ByteString +mkBinWord16 i = pack w + where + w = + [ fromIntegral i + , fromIntegral (i `shiftR` 8) + ] + +-- | Convert `String` to `ByteString` +s2bs :: String -> ByteString +s2bs = BSChar.pack + diff --git a/src/Print.hs b/src/Print.hs new file mode 100644 --- /dev/null +++ b/src/Print.hs @@ -0,0 +1,75 @@ + +module Print +( +doPrint +) +where + +import Data.Bits (testBit) +import Data.Maybe (isJust, fromJust) +import Control.Monad (unless, liftM) +import Control.Monad.IO.Class(liftIO, MonadIO) + +import App (App) +import Proto (getFrame, getField, getProp) +import IMsg (AMF(..), AMFValue(..), amfUndecoratedName) + +-- | Print variable +doPrint :: MonadIO m => [String] -> App m () +doPrint v = do + vs <- getFrame + let vs' = filter (\a -> amfUndecoratedName a == head v) vs + unless (null vs') (doPrintProps (tail v) (head vs')) + +-- | Print object properties as requested +doPrintProps :: MonadIO m => [String] -> AMF -> App m () +doPrintProps [] v = callGetter v >>= liftIO . putStrLn . prettyAMF +doPrintProps (name:ns) (AMF _ _ _ (AMFObject ptr _ _ _ _)) = do + vs <- liftM (filter notTrails) $ getField ptr "" + if name == "" + then printAll vs + else find' vs + where + notTrails (AMF _ _ _ AMFTrails) = False + notTrails _ = True + printAll vs = mapM callGetter vs >>= liftIO . mapM_ (putStrLn . prettyAMF) + find' vs = + let vs' = filter (\a -> amfUndecoratedName a == name) vs in + case vs' of + [] -> liftIO $ putStrLn "Not found" + [v] -> if null ns + then callGetter v >>= (liftIO . putStrLn . prettyAMF) + else callGetter v >>= doPrintProps ns + _ -> liftIO $ putStrLn "Multiple" +doPrintProps _ _ = liftIO $ putStrLn "Not found" + +-- | Check wether AMF value has getter +hasGetter :: AMF -> Bool +hasGetter amf = amfFlags amf `testBit` 19 + +-- | Call getter if exists +callGetter :: MonadIO m => AMF -> App m AMF +callGetter amf = if hasGetter amf + then call amf + else return amf + where + call a@(AMF ptr _ _ _) = do + res <- getProp ptr (amfUndecoratedName a) + if isJust res + then return $ fromJust res + else return a + +-- | Show AMF for user +prettyAMF :: AMF -> String +prettyAMF amf@(AMF _ _ _ v) = amfUndecoratedName amf ++ " = " ++ prettyAMVValue v + +-- | Show AMF value for user +prettyAMVValue :: AMFValue -> String +prettyAMVValue (AMFDouble v) = show v +prettyAMVValue (AMFBool v) = show v +prettyAMVValue (AMFString v) = show v +prettyAMVValue (AMFObject _ _ _ _ n) = n +prettyAMVValue AMFNull = "null" +prettyAMVValue AMFUndefined = "undefined" +prettyAMVValue v = show v + diff --git a/src/Proto.hs b/src/Proto.hs new file mode 100644 --- /dev/null +++ b/src/Proto.hs @@ -0,0 +1,156 @@ + +module Proto +( +setBreakpoint, +deleteBreakpoint, +-- deleteBreakpoints, +setDebuggerOption, +execFinish, +execContinue, +execStep, +execNext, +getFrame, +getField, +getProp, +nextMsg +) +where + +import Data.Maybe (isJust) +import Data.List (find) +import Data.Word (Word32) +import Data.ByteString (hPut) +import Control.Monad (liftM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State (get) +import Control.Monad.IO.Class(liftIO, MonadIO) +import System.IO (hFlush) + +import App (App, AppState(..), Breakpoint(..), setBreakpoints, newBreakId) +import OMsg (OMsg(..), binOMsg) +import IMsg (IMsg(..), AMF(..), nextIMessage) + +-- | Set breakpoint +setBreakpoint :: MonadIO m + => Int -- ^ File id + -> Int -- ^ Line number + -> App m () +setBreakpoint fl ln = do + bs <- lift . lift $ liftM asBreaks get + let exists = isJust $ find (\(_, b) -> (bpFileId b == fl) && (bpLine b == ln)) bs + if exists + then liftIO $ putStrLn "Breakpoint exists. Multiple breakpoints at the same line are not supported." + else do + sendMsg (OMsgSetBreakpoint (fromIntegral fl) (fromIntegral ln)) + msg <- nextMsg + case msg of + IMsgBreakpoints bs' -> do + let exists' = isJust $ find (== (fromIntegral fl, fromIntegral ln)) bs' + if exists' + then do + newId <- newBreakId + setBreakpoints $ (newId, Breakpoint fl ln) : bs + else + liftIO $ putStrLn "Can't resolve breakpoint (the line is not executable?)" + _ -> liftIO $ putStrLn "doSetBreakpoint: Unexpected message from player" + + +-- | Delete breakpoint +deleteBreakpoint :: MonadIO m => Int -> Int -> App m () +deleteBreakpoint fl ln = + sendMsg (OMsgClearBreakpoint (fromIntegral fl) (fromIntegral ln)) + +-- | Delete all breakpoints +-- Hmm... Doesn't work... Use `deleteBreakpoint` for now +{-deleteBreakpoints :: MonadIO m => App m () +deleteBreakpoints = + sendMsg OMsgClearBreakpoints-} + +-- | Set debuger option +setDebuggerOption :: MonadIO m + => String -- ^ Option name + -> String -- ^ Option value + -> App m () +setDebuggerOption op val = do + sendMsg (OMsgSetDebuggerOptions op val) + msg <- nextMsg + case msg of + IMsgDebuggerOption _ _ -> return () + _ -> liftIO $ putStrLn "doSetDebuggerOption: Unexpected message from player" + + +-- | Send @finish@ command to player +execFinish :: MonadIO m => App m () +execFinish = sendMsg OMsgFinish + +-- | Send @continue@ command to player +execContinue :: MonadIO m => App m () +execContinue = sendMsg OMsgContinue + +-- | Send @step@ command to player +execStep :: MonadIO m => App m () +execStep = sendMsg OMsgStep + +-- | Send @next@ command to player +execNext :: MonadIO m => App m () +execNext = sendMsg OMsgNext + +-- | Get function frame +getFrame :: MonadIO m => App m [AMF] +getFrame = do + sendMsg (OMsgGetFunctionFrame 0) + msg <- nextMsg + case msg of + IMsgFunctionFrame _ _ _ vs -> return vs + _ -> liftIO (putStrLn "doPrint: Unexpected message from player") >> + return [] + +-- | Get field value +getField :: MonadIO m + => Word32 -- ^ Object address + -> String -- ^ Field name + -> App m [AMF] +getField ptr name = do + sendMsg (OMsgGetField ptr name) + msg <- nextMsg + case msg of + IMsgGetField _ vs -> return vs + _ -> liftIO (putStrLn "Unexpected message from player") >> + return [] + +-- | Get property by calling getter +getProp :: MonadIO m => Word32 -> String -> App m (Maybe AMF) +getProp ptr name = do + sendMsg (OMsgGetField ptr name) + msg <- nextMsg + case msg of + IMsgGetField v _ -> return $ Just v + _ -> liftIO (putStrLn "Unexpected message from player") >> + return Nothing + +-- | Take next message +-- This function is just a wrapper around nextIMessage, +-- the only difference is that it responses to `IMsgProcessTag` message +-- and prints traces +nextMsg :: MonadIO m => App m IMsg +nextMsg = do + msg <- nextIMessage + -- liftIO $ print msg + case msg of + IMsgCreateAnonymObject _ -> nextMsg + IMsgSetLocalVars _ -> nextMsg + IMsgDeleteField _ _ -> nextMsg + IMsgSetField _ _ _ -> nextMsg + IMsgSetField2 _ _ _ -> nextMsg + IMsgProcessTag -> sendMsg OMsgProcessTag >> nextMsg + IMsgTrace str -> liftIO (putStrLn $ " [trace] " ++ str) >> nextMsg + _ -> return msg + +-- | Send message to player +sendMsg :: MonadIO m => OMsg -> App m () +sendMsg msg = do + -- liftIO $ print msg + h <- lift . lift $ liftM asHandle get + liftIO $ hPut h (binOMsg msg) >> hFlush h + return () + diff --git a/src/UCmd.hs b/src/UCmd.hs new file mode 100644 --- /dev/null +++ b/src/UCmd.hs @@ -0,0 +1,155 @@ + +-- | This modele defines user comands +module UCmd +( +UCmd(..), +parseUCmd, +InfoCmd(..), +suggestBaseCmd +) +where + +import Data.List (isPrefixOf, find) +import Data.Char (isDigit) +import Control.Monad (when, unless) + +-- | User commands +data UCmd + = UCmdEmpty -- ^ empty command, previous command should be used + | UCmdContinue + | UCmdStep + | UCmdNext + | UCmdFinish + | UCmdQuit + | UCmdInfo InfoCmd + | UCmdPrint [String] + | UCmdBreakpoint Int Int + | UCmdHelp + | UCmdStack + | UCmdList + | UCmdDelete (Maybe Int) + | UCmdTest -- ^ Just for tests + deriving Show + +-- | Parse user command +parseUCmd :: String -> Maybe UCmd +parseUCmd = parse . words + where + parse [] = Just UCmdEmpty + parse (c:cs) = do + cmd <- parseBaseCmd c + case cmd of + "continue" | cs == [] -> Just UCmdContinue + "step" | cs == [] -> Just UCmdStep + "next" | cs == [] -> Just UCmdNext + "finish" | cs == [] -> Just UCmdFinish + "quit" | cs == [] -> Just UCmdQuit + "help" | cs == [] -> Just UCmdHelp + "info" -> fmap UCmdInfo (parseInfoCmd cs) + "print" -> fmap UCmdPrint (parsePrintCmd cs) + "breakpoint" -> parseBreakpointCmd cs + "b" -> parseBreakpointCmd cs + "backtrace" | cs == [] -> Just UCmdStack + "bt" | cs == [] -> Just UCmdStack + "list" -> parseListCmd cs + "delete" -> parseDeleteCmd cs + "test" -> Just UCmdTest + _ -> Nothing + +-- | Parse @delete@ command +parseDeleteCmd :: [String] -> Maybe UCmd +parseDeleteCmd [] = Just $ UCmdDelete Nothing +parseDeleteCmd [iD] = + if all isDigit iD + then Just $ UCmdDelete $ Just $ read iD + else Nothing +parseDeleteCmd _ = Nothing + +-- | Parse @list@ command +parseListCmd :: [String] -> Maybe UCmd +parseListCmd [] = Just UCmdList +parseListCmd _ = Nothing + +-- | Parse @breakpoint@ command +-- +-- XXX: very pure code, rewrite +parseBreakpointCmd :: [String] -> Maybe UCmd +parseBreakpointCmd [pos] = do + (m, res) <- head' pos + when (m /= '#') Nothing + let fl = takeWhile isDigit res + when (null fl) Nothing + let res1 = drop (length fl) res + (m1, ln) <- head' res1 + when (null ln) Nothing + when (m1 /= ':') Nothing + unless (all isDigit ln) Nothing + return $ UCmdBreakpoint (read fl) (read ln) + where + head' [] = Nothing + head' (x:xs) = Just (x, xs) +parseBreakpointCmd _ = Nothing + +-- | Parse base command +parseBaseCmd :: String -> Maybe String +parseBaseCmd s = + if length condidates == 1 + then Just $ head condidates + else find (== s) condidates + where + condidates = suggestBaseCmd s + +-- | Returns list commands that maches the given prefix +suggestCmd :: [String] -- ^ Possible commands + -> String -- ^ Prefix + -> [String] -- ^ suggestions +suggestCmd cmds s = filter (isPrefixOf s) cmds + +-- | List of base commands +baseCommands :: [String] +baseCommands = ["continue", "step", "next", "finish", "quit", "info", "print", + "breakpoint", "help", "backtrace", "bt", "b", "list", "delete"] + +-- | Returns list of base commands that maches the given prefix +suggestBaseCmd :: String -> [String] +suggestBaseCmd = suggestCmd baseCommands + +-- | Parse @print@ commands +-- Just name of varible to print +parsePrintCmd :: [String] -> Maybe [String] +parsePrintCmd [v] = Just $ props v + where + props s = let (l, s') = break (== '.') s + in l : case s' of + [] -> [] + (_:s'') -> props s'' +parsePrintCmd _ = Nothing + +-- | Info commands +data InfoCmd = ICFiles -- ^ @info files@ + | ICBreakpoints -- ^ @info breakpoints@ + deriving Show + +-- | Parse info commands +parseInfoCmd :: [String] -> Maybe InfoCmd +parseInfoCmd [] = Nothing +parseInfoCmd (c:cs) = do + cmd <- mcmd + case cmd of + "files" | cs == [] -> Just ICFiles + "breakpoints" | cs == [] -> Just ICBreakpoints + _ -> Nothing + where + condidates = suggestInfoCmd c + mcmd = if length condidates == 1 + then Just $ head condidates + else Nothing + +-- | List of info commands +infoCommands :: [String] +infoCommands = ["files", "breakpoints"] + +-- | Returns list of info commands that maches the given prefix +suggestInfoCmd :: String -> [String] +suggestInfoCmd = suggestCmd infoCommands + diff --git a/src/hfd.hs b/src/hfd.hs new file mode 100644 --- /dev/null +++ b/src/hfd.hs @@ -0,0 +1,248 @@ + +-- | Main module + +module Main +( +main +) +where + +import Data.Tuple.Utils (fst3) +import Data.Maybe +import Data.Word (Word32, Word16) +import Data.ByteString.Char8 (unpack) +import System.IO (Handle, hClose, hSetBinaryMode) +import System.Console.Haskeline (getInputLine) +import Control.Monad (unless, liftM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State (get) +import Control.Monad.IO.Class(liftIO, MonadIO) +import Control.Exception (bracket) +import Network (withSocketsDo, PortNumber, PortID(PortNumber), HostName, + sClose, accept, listenOn) + +import App (App, runApp, FileEntry(..), addFileEntry, getFileEntry, + AppState(..), setLastCmd, setStack, Breakpoint(..), removeBreakpoint) +import IMsg (IMsg(..)) +import UCmd (UCmd(..), parseUCmd, InfoCmd(..)) +import Print (doPrint) +import Proto (setDebuggerOption, nextMsg, execContinue, execNext, execStep, execFinish, + setBreakpoint, deleteBreakpoint) + +-- | Entry point +main :: IO () +main = withSocketsDo $ printHello >> bracket + acceptPlayer + (hClose . fst3) + (start . fst3) + where + start h = do + putStrLn "Enter \'help\' for list of commands" + hSetBinaryMode h True + runApp h app + +-- | Print hello message +printHello :: IO () +printHello = do + putStrLn "HFB: Flash Debugger version 0.0.1" + putStrLn "Copyright (c) 2011 Yuras Shumovich" + putStrLn "mailto:shumovichy@gmail.com" + +-- | Print list of commands +printHelp :: IO () +printHelp = do + printHello + putStrLn "List of commands:" + putStrLn "\thelp print this help" + putStrLn "\tquit quit hfd" + putStrLn "\tcontinue continue execution until breakpoint hit" + putStrLn "\tstep continue execution until different source line reached" + putStrLn "\tnext continue execution until next source line reached" + putStrLn "\tinfo files show all source files" + putStrLn "\tinfo breakpoints show all breakpoints" + putStrLn "\tbreakpoint : set breakpoint at the location, e.g. \'b #1:23\'" + putStrLn "\t use \'info files\' to get fileID" + putStrLn "\tdelete delete breakpoint by ID" + putStrLn "\t use \'info breakpoints\' to get breakpoint ID" + putStrLn "\tdelete delete all breakpoints" + putStrLn "\tprint [.name]* inspect variables" + putStrLn "\tbacktrace (bt) show call stack" + putStrLn "Shortcuts are allowed, e.g. \'c\', \'co\', \'cont\', etc will mean \'continue\'" + +-- | Listen on port, accept just one client and close socket +acceptPlayer :: IO (Handle, HostName, PortNumber) +acceptPlayer = bracket + (listenOn (PortNumber 7935)) + sClose + (\s -> putStrLn "Waiting for player..." >> accept s) + +-- | Main app +app :: App IO () +app = do + processUntillBreak + setDebuggerOption "break_on_fault" "on" + -- doSetDebuggerOption "disable_script_stuck" "on" + -- doSetDebuggerOption "disable_script_stuck_dialog" "on" + -- doSetDebuggerOption "enumerate_override" "on" + setDebuggerOption "notify_on_failure" "on" + -- doSetDebuggerOption "invoke_setters" "on" + -- doSetDebuggerOption "swf_load_messages" "on" + loop + where + loop = do + exit <- processUserInput + unless exit (processUntillBreak >> loop) + +-- | Process player's messages until 'IMsgBreakHitEx' received +processUntillBreak :: App IO () +processUntillBreak = do + msg <- nextMsg + case msg of + IMsgBreakHitEx _ _ stack -> processBreak stack >> printSourceLine msg + IMsgSwdFileEntry _ _ _ _ _ -> processFileEntry msg >> processUntillBreak + IMsgException _ _ _ -> processException msg >> processUntillBreak + _ -> processUntillBreak + +-- | Save current stack +processBreak :: Monad m => [(Word16, Word16, Word32, String)] -> App m () +processBreak = setStack . map toStack + where + toStack (fl, ln, _, fn) = (fromIntegral fl, fromIntegral ln, fn) + +-- | Print information about exception +processException :: MonadIO m => IMsg -> App m () +processException (IMsgException _ msg _) = do + liftIO $ putStrLn " [exception]" + liftIO $ putStrLn msg +processException _ = error "processException: something is wrong" + +-- | Print current source line +printSourceLine :: IMsg -> App IO () +printSourceLine (IMsgBreakHitEx file line _) = do + files <- lift . lift $ fmap asFiles get + let mln = srcLine files + if isJust mln + then liftIO $ putStrLn $ " " ++ show line ++ ": " ++ fromJust mln + else liftIO $ putStrLn "No source" + where + srcLine files = do + FileEntry _ content <- lookup (fromIntegral file) files + let lln = take 1 $ drop (fromIntegral line - 1) content + if null lln + then Nothing + else Just $ head lln +printSourceLine _ = error "printSourceLine: something is wrong..." + +-- | Read file content and add new file entry +processFileEntry :: MonadIO m => IMsg -> App m () +processFileEntry (IMsgSwdFileEntry idi _ nm _ _) = do + content <- liftIO readFile' + addFileEntry (fromIntegral idi, FileEntry name (lines content)) + where + name = unpack nm + path = map fixup name + fixup ';' = '/' + fixup ch = ch + readFile' = catch (readFile path) (const $ return "") +processFileEntry _ = error "processFileEntry: something is wrong..." + +-- | Read user command and process it +processUserInput :: App IO Bool +processUserInput = do + l <- lift $ getInputLine "hfb> " + let cmd = l >>= parseUCmd + setLastCmd cmd + if isNothing cmd + then liftIO (putStrLn "Unknown command") >> processUserInput + else processCmd (fromJust cmd) + +-- | Actualy process user command +processCmd :: UCmd -- ^ User command + -> App IO Bool -- ^ whether to exit +processCmd UCmdEmpty = do + cmd <- lift . lift $ liftM asLastCmd get + if isJust cmd + then processCmd (fromJust cmd) + else processUserInput +processCmd UCmdQuit = return True +processCmd UCmdContinue = execContinue >> return False +processCmd UCmdStep = execStep >> return False +processCmd UCmdNext = execNext >> return False +processCmd UCmdFinish = execFinish >> return False +processCmd (UCmdInfo cmd) = processInfoCmd cmd >> processUserInput +processCmd (UCmdPrint v) = doPrint v >> processUserInput +processCmd (UCmdBreakpoint fl ln) = setBreakpoint fl ln >> processUserInput +processCmd UCmdStack = printStack >> processUserInput +processCmd UCmdList = listSource >> processUserInput +processCmd (UCmdDelete (Just iD)) = deleteBP iD >> processUserInput +processCmd (UCmdDelete Nothing) = deleteAll >> processUserInput +processCmd UCmdTest = processUserInput +processCmd UCmdHelp = liftIO printHelp >> processUserInput + +-- | Delete breakpoint by id +deleteBP :: MonadIO m => Int -> App m () +deleteBP iD = do + bs <- lift . lift $ liftM asBreaks get + let bp = lookup iD bs + if isJust bp + then do + let Breakpoint fl ln = fromJust bp + deleteBreakpoint fl ln + removeBreakpoint iD + else liftIO $ putStrLn "Unknown breakpoint id. Type \"info breakpoints\" for list of all breakpoints" + +-- | Delete all breakpoints +deleteAll :: MonadIO m => App m () +deleteAll = do + bs <- lift . lift $ liftM asBreaks get + mapM_ (deleteBP . fst) bs + +-- | Print source around current position +listSource :: MonadIO m => App m () +listSource = do + stack <- lift . lift $ liftM asStack get + if null stack + then liftIO $ putStrLn "No source" + else print' $ head stack + where + print' (fl, ln, _) = do + fs <- lift . lift $ liftM asFiles get + let f = lookup fl fs + if isNothing f + then liftIO $ putStrLn "No source" + else liftIO $ mapM_ printLine $ take 11 $ drop (ln - 6) (zip allLines $ feContent $ fromJust f) + printLine (ln, cont) = putStrLn $ " " ++ show ln ++ ": " ++ cont + allLines :: [Int] + allLines = [1..] + +-- | Print current stack +printStack :: MonadIO m => App m () +printStack = do + state <- lift . lift $ get + let stack = asStack state + let files = asFiles state + liftIO $ mapM_ (print' files) stack + where + print' fs (fl, ln, fn) = putStrLn $ fn ++ "() at " ++ file fs fl ++ ":" ++ show ln + file fs fl = let fe = lookup fl fs in + if isJust fe + then fePath (fromJust fe) + else "(no source)" + +-- | Process @info@ command +processInfoCmd :: MonadIO m => InfoCmd -> App m () +processInfoCmd ICFiles = printFiles + where + printFiles = do + files <- lift . lift $ liftM asFiles get + liftIO $ mapM_ printFile files + printFile (idi, FileEntry name _) = + putStrLn $ "#" ++ show idi ++ ": " ++ name +processInfoCmd ICBreakpoints = do + bs <- lift . lift $ liftM asBreaks get + mapM_ printBP bs + where + printBP (iD, Breakpoint fl ln) = do + fe <- liftM fromJust $ getFileEntry fl + liftIO $ putStrLn $ " " ++ show iD ++ "\t: " ++ fePath fe ++ " at line " ++ show ln +