diff --git a/Adb.hs b/Adb.hs new file mode 100644 --- /dev/null +++ b/Adb.hs @@ -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; + + + + + + diff --git a/AndroidViewHierarchyImporter.cabal b/AndroidViewHierarchyImporter.cabal new file mode 100644 --- /dev/null +++ b/AndroidViewHierarchyImporter.cabal @@ -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.* diff --git a/Graphviz.hs b/Graphviz.hs new file mode 100644 --- /dev/null +++ b/Graphviz.hs @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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. + +-} diff --git a/OPML.hs b/OPML.hs new file mode 100644 --- /dev/null +++ b/OPML.hs @@ -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} + diff --git a/Output.hs b/Output.hs new file mode 100644 --- /dev/null +++ b/Output.hs @@ -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) + 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/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -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 + + diff --git a/ViewServer.hs b/ViewServer.hs new file mode 100644 --- /dev/null +++ b/ViewServer.hs @@ -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 + +