packages feed

hfd (empty) → 0.0.2

raw patch · 12 files changed

+1351/−0 lines, 12 filesdep +MissingHdep +MonadCatchIO-transformersdep +basesetup-changed

Dependencies added: MissingH, MonadCatchIO-transformers, base, bytestring, haskeline, iteratee, network, transformers

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hfd.cabal view
@@ -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+
+ src/App.hs view
@@ -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}+
+ src/IMsg.hs view
@@ -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+
+ src/Inst.hs view
@@ -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+
+ src/OMsg.hs view
@@ -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+
+ src/Print.hs view
@@ -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+
+ src/Proto.hs view
@@ -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 ()+
+ src/UCmd.hs view
@@ -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+
+ src/hfd.hs view
@@ -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 <fileID>:<line>    set breakpoint at the location, e.g. \'b #1:23\'"+  putStrLn "\t                              use \'info files\' to get fileID"+  putStrLn "\tdelete <breakpointID>         delete breakpoint by ID"+  putStrLn "\t                              use \'info breakpoints\' to get breakpoint ID"+  putStrLn "\tdelete                        delete all breakpoints"+  putStrLn "\tprint <name>[.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+