AndroidViewHierarchyImporter (empty) → 0.1.0.0

raw patch · 10 files changed

+899/−0 lines, 10 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, cmdtheline, containers, mtl, network, opml, pretty, process, split, transformers, xml

Files

• Adb.hs +143/−0
• AndroidViewHierarchyImporter.cabal +42/−0
• Graphviz.hs +42/−0
• LICENSE +30/−0
• Main.hs +195/−0
• OPML.hs +35/−0
• Output.hs +50/−0
• Setup.hs +2/−0
• Types.hs +154/−0
• ViewServer.hs +206/−0

@@ -0,0 +1,143 @@+{-# LANGUAGE OverloadedStrings #-}+{- | Utility functions to launch and connect to the view server++-}+module Adb(+      startViewServer+    , stopViewServer +    , isViewServerRunning+    , whenViewServer+    , adbForward+    ) where +++import System.Process +import Control.Concurrent.MVar+import qualified Control.Exception as C+import System.IO+import System.Exit      ( ExitCode(..) )+import Control.Concurrent hiding(yield)+import Control.Monad(when)+import Control.Monad.Writer +import Types++-- | Run a command using arguments and a standard input +-- Return a result or an error+maybeProcess +    :: FilePath                 -- ^ command to run+    -> [String]                 -- ^ any arguments+    -> String                   -- ^ standard input+    -> IO (Either String String)                -- ^ stdout+maybeProcess cmd args input = do+    (Just inh, Just outh, _, pid) <-+        createProcess (proc cmd args){ std_in  = CreatePipe,+                                       std_out = CreatePipe,+                                       std_err = CreatePipe }++    -- fork off a thread to start consuming the output+    output  <- hGetContents outh+    outMVar <- newEmptyMVar+    _ <- forkIO $ C.evaluate (length output) >> putMVar outMVar ()++    -- now write and flush any input+    when (not (null input)) $ do hPutStr inh input; hFlush inh+    hClose inh -- done with stdin++    -- wait on the output+    takeMVar outMVar+    hClose outh++    -- wait on the process+    ex <- waitForProcess pid++    case ex of+     ExitSuccess   -> return (Right output)+     ExitFailure r -> return (Left (show r))++-- | Android command to start the view server on a given port+startViewServer :: Config -> IO ()+startViewServer c = do +    maybeProcess "adb" ["shell","service","call","window","1","i32",show (port c)] ""+    return ()++-- | Android command to stop the view server+stopViewServer :: IO ()+stopViewServer = do +    maybeProcess "adb" ["shell","service","call","window","2"] ""+    return ()++-- | Android command to forward a port+adbForward :: Config -> IO ()+adbForward c = do +    maybeProcess "adb" ["forward", "tcp:" ++ show (port c), "tcp:" ++ show (port c)] ""+    return ()++-- | Android command to test if the view server is running+-- (the code to parse the result is quick and dirty)+isViewServerRunning :: IO Bool +isViewServerRunning = do+    r <- maybeProcess "adb" ["shell","service","call","window","3"] ""+    either (const $ return False) (const $ return True) $ do +        mp <- r+        let nb = read . take 8 . drop 1 . drop 8 . drop 15 $ mp+        if nb == 1 +            then Right ""+            else Left ""++-- | When the view server is running, execute the action.+whenViewServer :: IO a -> IO ()+whenViewServer action = do +    r <- isViewServerRunning +    if r +        then do +            action +            return ()+        else return ()+++-- adb shell service call window 1 i32 4939 +-- adb shell service call window 3+-- adb shell service call window 2+-- adb forward tcp:4939 tcp:4939++-- base/core/java/Android/view/ViewDebug.java+--    private static final String REMOTE_COMMAND_CAPTURE = "CAPTURE";+--    private static final String REMOTE_COMMAND_DUMP = "DUMP";+--    private static final String REMOTE_COMMAND_INVALIDATE = "INVALIDATE";+--    private static final String REMOTE_COMMAND_REQUEST_LAYOUT = "REQUEST_LAYOUT";+--    private static final String REMOTE_PROFILE = "PROFILE";+--    private static final String REMOTE_COMMAND_CAPTURE_LAYERS = "CAPTURE_LAYERS";+--    private static final String REMOTE_COMMAND_OUTPUT_DISPLAYLIST = "OUTPUT_DISPLAYLIST";++-- Dump give property:length,value (length is length of value)+-- Number of front spaces before the view name are used to define the tree structure of this view with parents+--        id = namedProperties.get("mID").value;+--+--        left = getInt("mLeft", 0);+--        top = getInt("mTop", 0);+--        width = getInt("getWidth()", 0);+--        height = getInt("getHeight()", 0);+--        scrollX = getInt("mScrollX", 0);+--        scrollY = getInt("mScrollY", 0);+--        paddingLeft = getInt("mPaddingLeft", 0);+--        paddingRight = getInt("mPaddingRight", 0);+--        paddingTop = getInt("mPaddingTop", 0);+--        paddingBottom = getInt("mPaddingBottom", 0);+--        marginLeft = getInt("layout_leftMargin", Integer.MIN_VALUE);+--        marginRight = getInt("layout_rightMargin", Integer.MIN_VALUE);+--        marginTop = getInt("layout_topMargin", Integer.MIN_VALUE);+--        marginBottom = getInt("layout_bottomMargin", Integer.MIN_VALUE);+--        baseline = getInt("getBaseline()", 0);+--        willNotDraw = getBoolean("willNotDraw()", false);+--        hasFocus = getBoolean("hasFocus()", false);+--+--        hasMargins = marginLeft != Integer.MIN_VALUE &&+--                marginRight != Integer.MIN_VALUE &&+--                marginTop != Integer.MIN_VALUE &&+--                marginBottom != Integer.MIN_VALUE;++++++

@@ -0,0 +1,42 @@+-- Initial AndroidViewHierarchyImporter.cabal generated by cabal init.  For+--  further documentation, see http://haskell.org/cabal/users-guide/++name:                AndroidViewHierarchyImporter+version:             0.1.0.0+synopsis:            Tool to import a description of an Android view hierarchy through Abd and the Android view server+description: Tool to import a description of an Android view hierarchy through Abd and the Android view server.+ You can find more documentation in the @Main@ file.        +license:             BSD3+license-file:        LICENSE+author:              alpheccar+maintainer:          misc@alpheccar.org+copyright:           2012, alpheccar+category:            Development+build-type:          Simple+cabal-version:       >=1.8++executable AndroidViewHierarchyImporter+  main-is:  +    Main.hs           +  other-modules: +    Adb   +    ViewServer+    Types+    Output+    OPML+    Graphviz+  ghc-options: -threaded+  build-depends:       +     base ==4.5.*,+     mtl ==2.1.*,+     bytestring ==0.9.*,+     transformers ==0.3.*,+     network ==2.3.*,+     process ==1.1.*,+     split ==0.1.*,+     containers ==0.4.*,+     QuickCheck ==2.4.*,+     opml ==0.4,+     xml ==1.3.*,+     cmdtheline ==0.1.*,+     pretty ==1.1.*

@@ -0,0 +1,42 @@+{- | Generation of a raphviz description of the view tree++-}+module Graphviz(+	  graphviz+	, viewName+	) where++import Data.Tree(drawTree,Tree(..))+import Types+import Data.List.Split+import Control.Monad.Trans.Writer.Lazy++_graphviz :: Show a => Tree a -> Writer String ()+_graphviz (Node a []) = return ()+_graphviz (Node a l) = do +	let printEdge startN (Node endN _) = do +		tell (show startN)+		tell " -> "+		tell (show endN)+		tell ";\n"+	mapM_ (printEdge a) l+	mapM_ _graphviz l+++-- | Convert the view tree to a textual description in graphviz format+graphviz :: Tree String -> String+graphviz r = execWriter $ do +	tell "digraph view {\n"+	_graphviz r+	tell "};\n"++-- | Get the shortened name of a view (class name with hexadecimal number identifying the object)+viewName :: (String,View) -> String+viewName (viewName,_) = shortName viewName++shortName :: String -> String +shortName = mkName . reverse . wordsBy (`elem` ".@")+ where + 	mkName (a:b:_) = b ++ "@" ++ a + 	mkName s = error $ "at least two name should be contained in the list : " ++ show s+

@@ -0,0 +1,30 @@+Copyright (c) 2012, alpheccar++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 alpheccar 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.

@@ -0,0 +1,195 @@+{- | Android View Hierarchy importer++-}+module Main(+    -- * Android View Hierarchy Importer +    -- $doc+    main+    ) where+{-# LANGUAGE OverloadedStrings #-}++import Adb+import ViewServer +import Control.Monad(when)+import qualified Data.ByteString.Char8 as B+import Data.Tree(drawTree,Tree(..))+import Output +import Types++import System.Console.CmdTheLine+import Control.Applicative+import Data.Maybe(isJust,fromJust)++termInfo :: TermInfo+termInfo = def { termName = "AndroidViewHierarchyImporter", version = "1.0" }++-- | Print the string with the configuration.+-- Depending on the confuration the result will either go+-- to stdout or into a file+printWithOutputFile :: Config -> String -> IO ()+printWithOutputFile c s | isJust (outputFile c) = do +              writeFile (fromJust . outputFile $ c) s+                        | otherwise = putStr s++-- | Convert a view to a string+drawView :: (Int,(String,View)) -> IO String +drawView (_,(name,view)) = return $ name ++ "\n" ++ show view ++ "\n"++-- | Display the view hierarchy using the right format+dumpWindow config windowHash = do +        let lViews = listViews config windowHash+        case (outputFormat config) of +            Raw -> rawViews config windowHash >>= printWithOutputFile config+            Views -> lViews >>= mapM drawView >>= return . concat >>= printWithOutputFile config+            Graphviz -> do +                v <- lViews +                let t = mkTree v +                printWithOutputFile config $ graphviz (fmap viewName t)+            Opml -> do +                v <- lViews +                let t = mkTree v +                printWithOutputFile config $ opml t++-- | Connect to the view server+connectWith config = do +    r <- isViewServerRunning +    when (forward config) $ do+       adbForward config+    when (not r) $ do +        startViewServer config+    whenViewServer $ do+        when ((mustListWindows config) && not (isJust (mustListViews config))) $ do+            l <- listWindows config+            print l+        maybe (return ()) (dumpWindow config) $ (mustListViews config)+    stopViewServer +    return ()++-- | Do we want to dump a window+windowOption :: Term (Maybe WindowHash)+windowOption = opt Nothing $ (optInfo ["windowhash", "w"]) { argDoc = "Window hash"+                                                           , argName = "windowhash"+                                                           }++-- | Format of the output+outputFormatOption :: Term OutputFormat +outputFormatOption = opt Opml $ (optInfo ["format","f"]) { argDoc = "Output format for the view list"+                                                         , argName = "raw / view / graphviz / opml"}++-- | Do we want an output file or do we use stdout+outputFileOption :: Term (Maybe FilePath)+outputFileOption = opt Nothing $ (optInfo ["output","o"]) { argDoc = "Output file or stdout if nothing"+                                                          , argName = "filepath"+                                                          }++-- | Do we disable adb port forwarding (required with a board)+doNotForwardOption :: Term Bool +doNotForwardOption = flag $ (optInfo ["donotforward"]) {argDoc = "Do not forward the port"}+++-- | Port to use for the view server+-- (you can telnet to this port)+portOption :: Term Int +portOption = opt 4939 $ (optInfo ["portid", "p"]) { argDoc = "Port ID"+                                                  , argName = "integer"+                                                  }+-- | Hostname for the view server+hostOption :: Term String +hostOption = opt "127.0.0.1" $ (optInfo ["host", "h"]) { argDoc = "Host"+                                                       , argName = "IP or hostname"+                                                       }++-- | Option processing+term :: Term (IO ())+term = connectWith <$> config + where +    changeWindowOption :: Maybe WindowHash -> Config -> Config +    changeWindowOption s c = c {mustListViews = s}+    changeOutputFormat :: OutputFormat -> Config -> Config +    changeOutputFormat s c = c {outputFormat = s}+    changeOutputFile :: Maybe FilePath -> Config -> Config +    changeOutputFile s c = c {outputFile = s}+    changeForwardOption :: Bool -> Config -> Config +    changeForwardOption s c = c {forward = s}+    changePortOption :: Int -> Config -> Config +    changePortOption s c = c {port = s}+    changeHostOption :: String -> Config -> Config +    changeHostOption s c = c {hostname = s}+    config = liftA2 changeHostOption hostOption .+             liftA2 changePortOption portOption .+             liftA2 changeForwardOption doNotForwardOption .+             liftA2 changeOutputFile outputFileOption .+             liftA2 changeOutputFormat outputFormatOption .+             liftA2 changeWindowOption windowOption $+             pure defaultConfig++main :: IO ()+main = run ( term, termInfo )++{- $doc ++This command line tool will connect to an Android device (real or virtual), start the view server+and dump view hierarchies. It needs much more testing.++The view server is requiring a development board or an Android Virtual Device. If you're on a final product,+you may have to root your device to enable the view server.++So, by default this tool is configured to communicate with a local AVD. It has not yet been tested with+a board.++Here are some examples of how to use it:++@+AndroidViewHierarchyImporter+@++This command will connect to abd and forward the abd port (required when an AVD is used to be able to map the AVD port+to a port of the computer). Then, the command will launch the view server and list the windows on the plaform.++A window for this tool is defined as an hash (generated by the view server) and the activity +name.++If you want to dump the view hierarchy of a window, use the tool with a different option++@+AndroidViewHierarchyImporter -w b57b5078+@++The -w option is using the hash of a window to dump its hierarchy.++Note that it is very slow to dump a view hierarchy. And it may not always work.+For instance, on Jelly Bean, I have attempted to dump the hierarchy of the Image Wallpaper and either it is failing+or it is taking too much time for my patience. It is not a problem with this tool. The same behavior can be observed by+telneting to the view server and sending the right commands.++The dump format is OPML with by default only the width, height and layer type for the view. If you want more info+in the OPML you'll have to modify the source code of this tool !++But, if you want all the infos, you can use different output formats like raw and view++@+AndroidViewHierarchyImporter -w b57b5078 -f raw+@  ++Thus previous command is just dumping the result of the view server without any processing.++@+AndroidViewHierarchyImporter -w b57b5078 -f view+@++The previous command is parsing the result of the view server and is resulting view datatypes.++@+AndroidViewHierarchyImporter -w b57b5078 -f graphviz+@++The previous command is generating a graphviz file containing only shortened names for the views (only the +class name without the package and an hexadecimal number identifying the object).++@+AndroidViewHierarchyImporter --help+@++The previous command is listing all options.++-}

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+{- | Convert the view hierarchy to OPML++-}+module OPML(+	  opml+	) where +++import Prelude hiding (head, id, div)+import qualified Data.ByteString.Lazy as L +import Data.Tree +import Text.OPML.Syntax+import Text.OPML.Writer+import Types+import Text.XML.Light.Types++-- | Convert the view hierarchy into a textural description using the OPML format+opml :: Tree (String,View)  -> String+opml = serializeOPML . genOpml++genOpml :: Tree (String,View)  -> OPML +genOpml t = nullOPML { opmlBody = [htmlTree t]}++htmlTree :: Tree (String,View) -> Outline+htmlTree (Node a []) = node a []+htmlTree (Node a children) =  node a (map htmlTree children)++node :: (String,View) -> [Outline] -> Outline +node (name,v) childen = +	let attr s k = Attr (blank_name {qName = s}) k+	    attrs = [attr "Width" (show $ width v),attr "Height" (show $ height v), attr "Layer" (layerType v)]+	in+	(nullOutline name) {opmlOutlineChildren = childen, opmlOutlineAttrs = reverse attrs}+

@@ -0,0 +1,50 @@+{- | Test functions for tree generation++(should no more be in an output file ...)++-}+module Output(+	  graphviz+	, viewName +	, opml+	) where++import Data.Tree(drawTree,Tree(..))+import Types+import Data.List.Split+import Test.QuickCheck +import ViewServer(mkTree)+import OPML +import Graphviz++randomTree :: Arbitrary a => Int -> Gen (Tree a)+randomTree level | level == 0 = do +	 a <- arbitrary +	 return $ Node a []+                 | otherwise = do +   	 a <- arbitrary+   	 nb <- choose (1,5)+   	 children <- sequence (replicate nb (randomTree (level-1)))+   	 return $ Node a children++instance Arbitrary a => Arbitrary (Tree a) where +   arbitrary = do +   	 level <- choose (1,4)+   	 randomTree level++newtype Name = N String deriving(Eq,Show)++toString (N s) = s++instance Arbitrary Name where +	arbitrary = do +		n <- choose (1,5)+		let c = choose ('a','z')+		r <- sequence (replicate n c)+		return (N r)++reconstruct_prop :: Tree Name -> Bool+reconstruct_prop a = mkTree (flattenTree 0 a) == a +  +flattenTree nb (Node a l) = (nb,a):concatMap (flattenTree (nb+1)) (reverse l)+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,154 @@+{- | Types used by the tool++-}+module Types(+	-- * Types +	-- ** Identification of the windows and views+	  ViewServerPort(..)+	, WindowHash(..)+	, ActivityName +	-- ** Description of the windows and views+	, Window+	, View(..)+	-- ** Configuration and output format+	, Config(..)+	, OutputFormat(..)+	-- * Functions+	, mkWindow+	, windowHash +	, activityName+	, setViewProperty+	, emptyView+	, defaultConfig+	) where++import System.Console.CmdTheLine.ArgVal+import Text.PrettyPrint++-- | Port ID+type ViewServerPort = Int++-- | Window hash generated by Android+type WindowHash = String ++-- | Activity name+type ActivityName = String ++-- | Output format+data OutputFormat = Raw -- ^ Raw text as generated +                  | Views +                  | Graphviz +                  | Opml ++instance ArgVal OutputFormat where +   pp Raw = text "raw" +   pp Views = text "view"+   pp Graphviz = text "graphviz"+   pp Opml = text "opml"+  +   parser "raw" = Right Raw +   parser "view" = Right Views+   parser "graphviz" = Right Graphviz+   parser "opml" = Right Opml+   parser _ = Left (text "Error parsing the output format")+++-- | Configuration for a run of the tool+data Config = Config {+	          hostname :: String +	        , port :: ViewServerPort +	        , forward :: Bool+	        , mustListWindows :: Bool +	        , mustListViews :: Maybe WindowHash+	        , outputFormat :: OutputFormat+	        , outputFile :: Maybe FilePath+            }++defaultConfig = Config {+	            hostname = "127.0.0.1"+	          , port = 4939 +	          , forward = True+	          , mustListWindows = True +	          , mustListViews = Nothing+	          , outputFormat = Opml+	          , outputFile = Nothing+              }++-- | Description of a window+data Window = W {windowHash :: !WindowHash, activityName :: !ActivityName} deriving(Eq,Read,Show)++mkWindow :: WindowHash -> ActivityName -> Window+mkWindow = W ++type ViewID = String++-- | Description of a view+data View = V { mID :: ViewID+	          , top :: Int +	          , left :: Int +	          , height :: Int +	          , width :: Int +	          , scrollX :: Int +	          , scrollY :: Int +	          , paddingLeft :: Int +	          , paddingRight :: Int +	          , paddingTop :: Int +	          , paddingBottom :: Int+	          , marginLeft :: Int +	          , marginRight :: Int +	          , marginTop :: Int +	          , marginBottom :: Int+	          , baseline :: Int +	          , willNotDraw :: Bool +	          , hasFocus :: Bool+	          , layerType :: String+              }+              deriving(Eq,Show,Read)++emptyView = V { mID = ""+	          , top = 0+	          , left = 0+	          , height = 0+	          , width = 0+	          , scrollX = 0+	          , scrollY = 0+	          , paddingLeft = 0+	          , paddingRight = 0+	          , paddingTop = 0+	          , paddingBottom = 0+	          , marginLeft = minBound+	          , marginRight = minBound+	          , marginTop = minBound+	          , marginBottom = minBound+	          , baseline = 0+	          , willNotDraw = False+	          , hasFocus = False+	          , layerType ="NONE"+              }++-- | Parse a view property and update the corresponding view field.+-- a property genrated by the view server is key=value converted to (key,value)+setViewProperty :: View -> (String,String) -> View +setViewProperty v ("layout:mLeft",theData) = v {left = read theData}+setViewProperty v ("layout:mTop",theData) = v {top = read theData}+setViewProperty v ("layout:getWidth()",theData) = v {width = read theData}+setViewProperty v ("layout:getHeight()",theData) = v {height = read theData}+setViewProperty v ("padding:mPaddingLeft",theData) = v {paddingLeft = read theData}+setViewProperty v ("padding:mPaddingRight",theData) = v {paddingRight = read theData}+setViewProperty v ("padding:mPaddingBottom",theData) = v {paddingBottom = read theData}+setViewProperty v ("padding:mPaddingTop",theData) = v {paddingTop = read theData}+setViewProperty v ("scrolling:mScrollX", theData) = v {scrollX = read theData}+setViewProperty v ("scrolling:mScrollY", theData) = v {scrollY = read theData}+setViewProperty v ("layout:layout_leftMargin",theData) = v {marginLeft = read theData}+setViewProperty v ("layout:layout_rightMargin",theData) = v {marginRight = read theData}+setViewProperty v ("layout:layout_bottomMargin",theData) = v {marginTop = read theData}+setViewProperty v ("layout:layout_topMargin",theData) = v {marginBottom = read theData}+setViewProperty v ("layout:getBaseline()",theData) = v {baseline = read theData}+setViewProperty v ("drawing:willNotDraw()","false") = v {willNotDraw = False}+setViewProperty v ("drawing:willNotDraw()","true") = v {willNotDraw = True}+setViewProperty v ("focus:hasFocus()","false") = v {hasFocus = False}+setViewProperty v ("focus:hasFocus()","true") = v {hasFocus = True}+setViewProperty v ("drawing:mLayerType",theData) = v {layerType = theData}+setViewProperty v _ = v++

@@ -0,0 +1,206 @@+{-# LANGUAGE OverloadedStrings #-}+{- | Utility functions for interacting with the view server+  +-}+module ViewServer(+      listWindows+    , listViews+    , rawViews+    , mkTree+    , test+    ) where++import Network.Socket +import qualified Network.Socket.ByteString as SB+import Control.Monad.IO.Class+import qualified Data.ByteString.Char8 as B+import Control.Monad.Writer +import Data.List.Split +import Types+import Data.List(foldl')+import Data.Tree++-- | Stack used for reconstructing a tree from the flattened trace generated by the view server+newtype Stack a = Stack [a] deriving(Show)++isEmpty :: Stack a -> Bool +isEmpty (Stack s) = null s ++push :: a -> Stack a -> Stack a +push a (Stack s) = Stack $ (a:s)++pop :: Stack a -> (Stack a,a)+pop (Stack (s:l)) = (Stack l,s)+pop _ = error "Can't pop and empty stack"++emptyStack :: Stack a+emptyStack = Stack []++stackLength :: Stack a -> Int +stackLength (Stack l) = length l+++-- Low level command+-- Do we list the windows of dump the views+data Cmd = ListCmd +         | Dump B.ByteString ++-- Result of a command+data Result = WList [B.ByteString]+            | WProperties B.ByteString +            deriving(Eq,Show,Read)++-- | Get result from the view server+recvAll :: Socket -> IO B.ByteString +recvAll sock = do+    f <- r_ sock id+    return (f B.empty) +  where +    r_ s current = do +        msg <- SB.recv s 1024+        if (B.null msg) +            then return current +            else do +                r_ s (current . B.append msg)++-- | Send a command to the view server and read the full result.+processCmd :: Socket +           -> B.ByteString +           -> IO B.ByteString+processCmd sock s = do +    SB.sendAll sock $ B.append s (B.pack "\n")+    recvAll sock++-- | Connect to the view server and send a command+genericCmd c s = do+       let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] } +       addrinfos <- getAddrInfo Nothing (Just (hostname c)) (Just $ show (port c))+       let serveraddr = head addrinfos+       sock <- socket (addrFamily serveraddr) Stream defaultProtocol+       connect sock (addrAddress serveraddr)+       r <- processCmd sock s+       sClose sock+       return r++-- | Some of the commands recognized by the view server+command :: Config -> Cmd -> IO Result+command p ListCmd = genericCmd p "LIST" >>= return . WList . B.lines+command p (Dump a) = genericCmd p (B.append (B.pack "DUMP ")  a) >>= return . WProperties++-- | List of windows+listWindows :: Config -> IO [Window]+listWindows p = do +    WList l <- command p ListCmd +    return . map toWindow . filter (/= "DONE.") $ l++-- | List of view for a window+-- The int is used to reconstruct the tree. In the view server trace it is encoded+-- as the number of spaces before the view name.+listViews :: Config -> WindowHash -> IO [(Int,(String,View))]+listViews p wh = do+    WProperties l <- command p (Dump (B.pack $ wh))+    let views = filter (\(_,(vn,_)) -> vn /= "DONE." && vn /= "DONE") . map toProperties $ lines . B.unpack $ l+    return views++-- | Raw result from the view server+rawViews :: Config -> WindowHash -> IO String+rawViews p wh = do+    WProperties l <- command p (Dump (B.pack $ wh))+    let views = B.unpack $ l+    return views ++test :: Monad m => B.ByteString -> m [(Int,(String,View))]+test l = do +    let theViews = map toProperties $ lines . B.unpack $ l+    return theViews++-- | Parse the window description from the view server+toWindow :: B.ByteString -> Window +toWindow l = +    let [hash,name] = splitOn " " . B.unpack $ l+    in +    mkWindow hash name++-- | Parse a view description from the view server+toProperties :: String -> (Int,(String,View))+toProperties l = +    let (nb,viewName,propertyTags) = getNbFrontSpace 0 l+    in +    (nb, (viewName, foldl' setViewProperty emptyView propertyTags))++-- | Get the number of leading spaces before a view name+getNbFrontSpace nb [] = (nb,"",[])+getNbFrontSpace nb (' ':l) = getNbFrontSpace (nb+1) l +getNbFrontSpace nb l = let (name,otherLines) = break (== ' ') $ l+                           r = getValues "" otherLines+                       in +                       (nb,name,r)++-- | Get the values for the view fields+getValues current [] = [] +getValues current ('=':r) = +    let (nbS,remaining) = break (== ',') r +        nb = read nbS +        value = take nb . drop 1 $ remaining +    in +    (dropWhile (== ' ') . reverse $ current,value):getValues "" (drop (nb+1) remaining)+getValues current (a:r) = getValues (a:current) r++reverseStack nb (Stack s) = +    let addChild (nb,((Node a l):r)) (_,c) = (nb,(Node a (c ++ l)):r)+        nodeNb = fst+        connectAll (a:b:l) | nodeNb a >= nb && nodeNb b < nb = connectAll ((addChild b a):l)+        connectAll l = l+        connected = reverse $ connectAll (reverse s)+    in +    Stack connected++testb = +    let node (x,y) = (x,Node (show y) [])+        bb = [(0,0),(1,1),(2,2),(1,4)]+    in +    map node bb ++{-++Algorithm for reconstructing a tree from the trace+(not the most elegant - but not enough time to do differently)+-}+data StackElem a = SE { nodeNb :: Int+                      , valueNb :: Tree a+                      } deriving(Show)++addChild :: Tree a -> Tree a -> Tree a +addChild aChild (Node root children) = Node root (aChild:children)++concatSE :: StackElem a -> StackElem a -> StackElem a +concatSE first@(SE _ f) second@(SE nb s) = SE nb (addChild f s)+++concatStack :: Int -> StackElem a -> [StackElem a] -> [StackElem a]+concatStack nb val (first:second:r) | nb <= nodeNb first = concatStack nb val (concatSE first second:r)+                                    | otherwise = val:first:second:r+concatStack nb val (a:l) = val:a:l +concatStack nb val [] = [val]++toTree :: StackElem a -> Tree a +toTree = valueNb++--0,1,2,3,1,2++mkTree :: [(Int,a)] -> Tree a+mkTree [] = error "Can't make tree from empty list"+mkTree l = toTree $ _mkTree [] l+ where +    node (nb,v) = SE nb (Node v [])+    _mkTree :: [StackElem a] -> [(Int,a)] -> StackElem a+    _mkTree [] (first:r) = _mkTree [node first] r+    _mkTree stack [] = foldl1 concatSE stack+    _mkTree stack@(first:second:stack') (a:b) | fst a == nodeNb first = _mkTree (node a:concatSE first second:stack') b +                                              | fst a > nodeNb first = _mkTree (node a:stack) b +                                              | fst a < nodeNb first = _mkTree (concatStack (fst a) (node a) stack) b+    _mkTree stack@(first:l) (a:b) | fst a == nodeNb first = error "can't add sibling"+                                  | fst a > nodeNb first = _mkTree (node a:stack) b +                                  | fst a < nodeNb first = _mkTree (concatStack (fst a) (node a) stack) b++