{-# 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