├── Setup.hs ├── stack.yaml ├── LICENSE ├── wayland-tracker.cabal ├── cbits ├── wayland-msg-handling.h ├── Wayland.hs └── wayland-msg-handling.c ├── src ├── Types.hs ├── Main.hs ├── ParseWaylandXML.hs ├── Log.hs └── Tracker.hs └── README.md /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | resolver: lts-7.0 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2008 Kristian Høgsberg 2 | Copyright © 2013 Jason Ekstrand 3 | Copyright © 2014 Intel Corporation 4 | 5 | Permission to use, copy, modify, distribute, and sell this software and its 6 | documentation for any purpose is hereby granted without fee, provided that 7 | the above copyright notice appear in all copies and that both that copyright 8 | notice and this permission notice appear in supporting documentation, and 9 | that the name of the copyright holders not be used in advertising or 10 | publicity pertaining to distribution of the software without specific, 11 | written prior permission. The copyright holders make no representations 12 | about the suitability of this software for any purpose. It is provided "as 13 | is" without express or implied warranty. 14 | 15 | THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 16 | INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO 17 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR 18 | CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 19 | DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 20 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 21 | OF THIS SOFTWARE. 22 | -------------------------------------------------------------------------------- /wayland-tracker.cabal: -------------------------------------------------------------------------------- 1 | -- Initial wayland-tracker.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: wayland-tracker 5 | version: 0.4.0.0 6 | synopsis: Message dumper for Wayland protocol. 7 | description: Message dumper for Wayland protocol. 8 | license: MIT 9 | license-file: LICENSE 10 | author: Ismo Puustinen 11 | maintainer: ismo.puustinen@intel.com 12 | -- copyright: 13 | category: Graphics 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable wayland-tracker 19 | main-is: Main.hs 20 | other-modules: Types, ParseWaylandXML, Tracker, Log, Wayland 21 | C-sources: cbits/wayland-msg-handling.c 22 | include-dirs: cbits 23 | -- other-extensions: 24 | build-depends: base, mtl, stm, network, unix, bytestring, xml, 25 | containers, binary-bits >= 0.3, cmdargs, utf8-string, 26 | attoparsec, attoparsec-binary, time, aeson, 27 | base16-bytestring, cpu, binary, aeson-pretty >= 0.8.1 28 | hs-source-dirs: ., cbits, src 29 | default-language: Haskell2010 30 | -------------------------------------------------------------------------------- /cbits/wayland-msg-handling.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright © 2014 Intel Corporation 3 | * 4 | * Permission to use, copy, modify, distribute, and sell this software and its 5 | * documentation for any purpose is hereby granted without fee, provided that 6 | * the above copyright notice appear in all copies and that both that copyright 7 | * notice and this permission notice appear in supporting documentation, and 8 | * that the name of the copyright holders not be used in advertising or 9 | * publicity pertaining to distribution of the software without specific, 10 | * written prior permission. The copyright holders make no representations 11 | * about the suitability of this software for any purpose. It is provided "as 12 | * is" without express or implied warranty. 13 | * 14 | * THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 15 | * INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO 16 | * EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR 17 | * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 18 | * DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 19 | * TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 20 | * OF THIS SOFTWARE. 21 | */ 22 | 23 | #include 24 | #include 25 | #include 26 | #include 27 | #include 28 | 29 | int recvmsg_wayland(int fd, const char *buf, int bufsize, int *fds, 30 | int fdbufsize, int *n_fds); 31 | 32 | int sendmsg_wayland(int fd, const char *buf, int bufsize, int *fds, int n_fds); 33 | -------------------------------------------------------------------------------- /cbits/Wayland.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright © 2014 Intel Corporation 3 | 4 | Permission to use, copy, modify, distribute, and sell this software and its 5 | documentation for any purpose is hereby granted without fee, provided that 6 | the above copyright notice appear in all copies and that both that copyright 7 | notice and this permission notice appear in supporting documentation, and 8 | that the name of the copyright holders not be used in advertising or 9 | publicity pertaining to distribution of the software without specific, 10 | written prior permission. The copyright holders make no representations 11 | about the suitability of this software for any purpose. It is provided "as 12 | is" without express or implied warranty. 13 | 14 | THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 15 | INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO 16 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR 17 | CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 18 | DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 19 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 20 | OF THIS SOFTWARE. 21 | -} 22 | 23 | {-# LANGUAGE CPP #-} 24 | {-# LANGUAGE ForeignFunctionInterface #-} 25 | 26 | module Wayland (sendToWayland, recvFromWayland) 27 | 28 | where 29 | 30 | import qualified Control.Concurrent as CC 31 | import qualified Data.ByteString as BS 32 | import Foreign 33 | import Foreign.C.Types 34 | import qualified Network.Socket as Socket 35 | 36 | foreign import ccall unsafe "wayland-msg-handling.h sendmsg_wayland" 37 | c_sendmsg_wayland :: CInt -- fd 38 | -> Ptr CChar -- buf 39 | -> CInt -- bufsize 40 | -> Ptr CInt -- fds 41 | -> CInt -- n_fds 42 | -> IO CInt -- bytes sent 43 | 44 | foreign import ccall unsafe "wayland-msg-handling.h recvmsg_wayland" 45 | c_recvmsg_wayland :: CInt -- fd 46 | -> Ptr CChar -- buf 47 | -> CInt -- bufsize 48 | -> Ptr CInt -- fds 49 | -> CInt -- fdbufsize 50 | -> Ptr CInt -- n_fds 51 | -> IO CInt -- bytes received 52 | 53 | 54 | sendToWayland :: Socket.Socket -> BS.ByteString -> [Int] -> IO Int 55 | sendToWayland s bs fds = do 56 | CC.threadWaitWrite $ fromIntegral socket 57 | BS.useAsCStringLen bs sendData 58 | where 59 | socket = Socket.fdSocket s 60 | c_fds = map fromIntegral fds 61 | sendData (bytePtr, byteLen) = withArrayLen c_fds $ \fdLen fdArray -> do 62 | let c_byteLen = fromIntegral byteLen 63 | let c_fdLen = fromIntegral fdLen 64 | len <- c_sendmsg_wayland socket bytePtr c_byteLen fdArray c_fdLen 65 | if len < 0 66 | then ioError $ userError "sendmsg failed" 67 | else return $ fromIntegral len 68 | 69 | 70 | recvFromWayland :: Socket.Socket -> IO (BS.ByteString, [Int]) 71 | recvFromWayland s = allocaArray 4096 $ \cbuf -> do 72 | CC.threadWaitRead $ fromIntegral socket 73 | alloca $ \nFds_ptr -> 74 | allocaArray (4*28) $ \fdArray -> do 75 | len <- c_recvmsg_wayland socket cbuf 4096 fdArray (4*28) nFds_ptr 76 | if len < 0 77 | then ioError $ userError "recvmsg failed" 78 | else do 79 | bs <- BS.packCStringLen (cbuf, fromIntegral len) 80 | nFds <- peek nFds_ptr 81 | fds <- peekArray (fromIntegral nFds) fdArray 82 | return (bs, map fromIntegral fds) 83 | where 84 | socket = Socket.fdSocket s 85 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright © 2014 Intel Corporation 3 | 4 | Permission to use, copy, modify, distribute, and sell this software and its 5 | documentation for any purpose is hereby granted without fee, provided that 6 | the above copyright notice appear in all copies and that both that copyright 7 | notice and this permission notice appear in supporting documentation, and 8 | that the name of the copyright holders not be used in advertising or 9 | publicity pertaining to distribution of the software without specific, 10 | written prior permission. The copyright holders make no representations 11 | about the suitability of this software for any purpose. It is provided "as 12 | is" without express or implied warranty. 13 | 14 | THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 15 | INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO 16 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR 17 | CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 18 | DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 19 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 20 | OF THIS SOFTWARE. 21 | -} 22 | 23 | {-# LANGUAGE OverloadedStrings #-} 24 | 25 | module Types ( 26 | MessageType(..), 27 | MArgumentValue(..), 28 | MArgument(..), 29 | ParsedMessage(..), 30 | ParsedBinaryMessage(..), 31 | LogType(..), 32 | Logger(..)) 33 | 34 | where 35 | 36 | import qualified Data.Aeson as A 37 | import qualified Data.ByteString as BS 38 | import qualified Data.ByteString.Base16 as B16 39 | import qualified Data.ByteString.Char8 as C8 40 | import qualified Numeric as N 41 | import qualified System.IO as IO 42 | 43 | data MessageType = Request | Event deriving (Eq, Show) 44 | 45 | data MArgumentValue = MInt Int 46 | | MUInt Int 47 | | MString String 48 | | MFixed Bool Int Int 49 | | MArray BS.ByteString 50 | | MFd 51 | | MNewId Int String 52 | | MObject Int 53 | deriving (Eq, Show) 54 | 55 | data MArgument = MArgument 56 | { argName :: String, 57 | argValue :: MArgumentValue 58 | } deriving (Eq, Show) 59 | 60 | data ParsedMessage = UnknownMessage MessageType 61 | | Message 62 | { msgType :: MessageType, 63 | msgName :: String, 64 | msgInterface :: String, 65 | msgObject :: Int, 66 | msgArguments :: [MArgument] 67 | } deriving (Eq, Show) 68 | 69 | data ParsedBinaryMessage = ParsedBinaryMessage 70 | { binaryMsgType :: MessageType, 71 | senderId :: Int, 72 | opCode :: Int, 73 | msgSize :: Int, 74 | msgData :: BS.ByteString 75 | } deriving (Eq, Show) 76 | 77 | data LogType = Binary | Json | JsonPretty | Simple 78 | 79 | data Logger = Logger IO.Handle LogType 80 | 81 | -- Helper to convert a Wayland Fixed number to Double 82 | fixedToFloat :: MArgumentValue -> Double 83 | fixedToFloat (MFixed sign fp sp) = signed sign (head values) 84 | where 85 | values = N.readFloat $ show fp ++ "." ++ show sp 86 | signed s (float, _) = if s 87 | then -1.0 * float 88 | else float 89 | 90 | 91 | instance A.ToJSON MArgumentValue where 92 | toJSON value = case value of 93 | MInt v -> A.object [ "type" A..= A.String "Int", "value" A..= v ] 94 | MUInt v -> A.object [ "type" A..= A.String "UInt", "value" A..= v ] 95 | MString v -> A.object [ "type" A..= A.String "String", "value" A..= v ] 96 | MFixed _ _ _ -> A.object [ "type" A..= A.String "Fixed", 97 | "value" A..= fixedToFloat value ] 98 | MArray bs -> A.object [ "type" A..= A.String "Array", 99 | "value" A..= C8.unpack (B16.encode bs) ] 100 | MFd -> A.object [ "type" A..= A.String "Fd" ] 101 | MNewId v _ -> A.object [ "type" A..= A.String "NewId", "value" A..= v ] 102 | MObject v -> A.object [ "type" A..= A.String "Object", "value" A..= v ] 103 | 104 | instance A.ToJSON MArgument where 105 | toJSON (MArgument name value) = A.object [ "name" A..= name, "value" A..= value ] 106 | 107 | instance A.ToJSON MessageType where 108 | toJSON Request = A.String "Request" 109 | toJSON Event = A.String "Event" 110 | 111 | instance A.ToJSON ParsedMessage where 112 | toJSON (UnknownMessage _) = A.String "Unknown message" 113 | toJSON (Message t n i o as) = A.object 114 | [ "type" A..= t, 115 | "name" A..= n, 116 | "object" A..= o, 117 | "interface" A..= i, 118 | "arguments" A..= as ] 119 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright © 2014 Intel Corporation 3 | 4 | Permission to use, copy, modify, distribute, and sell this software and its 5 | documentation for any purpose is hereby granted without fee, provided that 6 | the above copyright notice appear in all copies and that both that copyright 7 | notice and this permission notice appear in supporting documentation, and 8 | that the name of the copyright holders not be used in advertising or 9 | publicity pertaining to distribution of the software without specific, 10 | written prior permission. The copyright holders make no representations 11 | about the suitability of this software for any purpose. It is provided "as 12 | is" without express or implied warranty. 13 | 14 | THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 15 | INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO 16 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR 17 | CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 18 | DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 19 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 20 | OF THIS SOFTWARE. 21 | -} 22 | 23 | {-# LANGUAGE DeriveDataTypeable #-} 24 | 25 | module Main 26 | 27 | where 28 | 29 | import System.Console.CmdArgs 30 | import System.Environment 31 | 32 | import Tracker 33 | import Types 34 | 35 | data OutputMode = BinaryMode 36 | { output :: Maybe String, 37 | command :: String, 38 | commandArgs :: [String] 39 | } 40 | | SimpleMode 41 | { xmlFile :: [String], 42 | output :: Maybe String, 43 | command :: String, 44 | commandArgs :: [String] 45 | } 46 | | JsonMode 47 | { xmlFile :: [String], 48 | output :: Maybe String, 49 | command :: String, 50 | commandArgs :: [String] 51 | } 52 | | JsonPrettyMode 53 | { xmlFile :: [String], 54 | output :: Maybe String, 55 | command :: String, 56 | commandArgs :: [String] 57 | } deriving (Show, Data, Typeable) 58 | 59 | 60 | binaryMode :: Annotate Ann 61 | binaryMode = record BinaryMode { output = Nothing, command = "", commandArgs = [] } 62 | [ 63 | output := def += typFile += help "Output file", 64 | command := def += argPos 0 += typ "PROGRAM", 65 | commandArgs := def += args += typ "PROGRAM OPTIONS" 66 | ] += name "binary" 67 | 68 | 69 | simpleMode :: Annotate Ann 70 | simpleMode = record SimpleMode { xmlFile = [], output = Nothing, command = "", commandArgs = [] } 71 | [ 72 | xmlFile := def += typFile += help "Protocol description XML file", 73 | output := def += typFile += help "Output file", 74 | command := def += argPos 0 += typ "PROGRAM", 75 | commandArgs := def += args += typ "PROGRAM OPTIONS" 76 | ] += name "simple" 77 | 78 | 79 | jsonMode :: Annotate Ann 80 | jsonMode = record JsonMode { xmlFile = [], output = Nothing, command = "", commandArgs = [] } 81 | [ 82 | xmlFile := def += typFile += help "Protocol description XML file", 83 | output := def += typFile += help "Output file", 84 | command := def += argPos 0 += typ "PROGRAM", 85 | commandArgs := def += args += typ "PROGRAM OPTIONS" 86 | ] += name "json" 87 | 88 | 89 | jsonPrettyMode :: Annotate Ann 90 | jsonPrettyMode = record JsonPrettyMode { xmlFile = [], output = Nothing, command = "", commandArgs = [] } 91 | [ 92 | xmlFile := def += typFile += help "Protocol description XML file", 93 | output := def += typFile += help "Output file", 94 | command := def += argPos 0 += typ "PROGRAM", 95 | commandArgs := def += args += typ "PROGRAM OPTIONS" 96 | ] += name "json_pretty" 97 | 98 | 99 | main :: IO () 100 | main = do 101 | let m = modes_ [binaryMode += auto, simpleMode, jsonMode, jsonPrettyMode] 102 | += program "wayland-tracker" 103 | += summary "Wayland protocol message dumper, version 0.4" 104 | += helpArg [name "h"] 105 | -- add '--help' to the command line in case the command line was empty 106 | originalArgs <- getArgs 107 | 108 | let args = if null originalArgs 109 | then ["--help"] 110 | else originalArgs 111 | 112 | parsedArgs <- withArgs args $ cmdArgs_ m 113 | 114 | case parsedArgs of 115 | BinaryMode o c cargs -> runApplication [] Binary o c cargs 116 | SimpleMode xs o c cargs -> runApplication xs Simple o c cargs 117 | JsonMode xs o c cargs -> runApplication xs Json o c cargs 118 | JsonPrettyMode xs o c cargs -> runApplication xs JsonPretty o c cargs 119 | -------------------------------------------------------------------------------- /cbits/wayland-msg-handling.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright © 2008 Kristian Høgsberg 3 | * Copyright © 2013 Jason Ekstrand 4 | * Copyright © 2014 Intel Corporation 5 | * 6 | * Permission to use, copy, modify, distribute, and sell this software and its 7 | * documentation for any purpose is hereby granted without fee, provided that 8 | * the above copyright notice appear in all copies and that both that copyright 9 | * notice and this permission notice appear in supporting documentation, and 10 | * that the name of the copyright holders not be used in advertising or 11 | * publicity pertaining to distribution of the software without specific, 12 | * written prior permission. The copyright holders make no representations 13 | * about the suitability of this software for any purpose. It is provided "as 14 | * is" without express or implied warranty. 15 | * 16 | * THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 17 | * INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO 18 | * EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR 19 | * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 20 | * DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 21 | * TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 22 | * OF THIS SOFTWARE. 23 | */ 24 | 25 | #include 26 | 27 | #include "wayland-msg-handling.h" 28 | 29 | #define MAX_FDS 28 /* this constant is from Wayland library */ 30 | 31 | static void build_cmsg(int *fds, int n_fds, char *data, int *clen) 32 | { 33 | struct cmsghdr *cmsg; 34 | size_t size; 35 | 36 | if (n_fds > MAX_FDS) 37 | n_fds = MAX_FDS; 38 | 39 | size = n_fds * 4; 40 | 41 | if (size > 0) { 42 | cmsg = (struct cmsghdr *) data; 43 | cmsg->cmsg_level = SOL_SOCKET; 44 | cmsg->cmsg_type = SCM_RIGHTS; 45 | cmsg->cmsg_len = CMSG_LEN(size); 46 | memcpy(CMSG_DATA(cmsg), fds, size); 47 | *clen = cmsg->cmsg_len; 48 | } else { 49 | *clen = 0; 50 | } 51 | } 52 | 53 | static int decode_cmsg(int *fds, int bufsize, struct msghdr *msg) 54 | { 55 | struct cmsghdr *cmsg; 56 | size_t size; 57 | int n = 0; 58 | int *fdp = fds; 59 | 60 | cmsg = CMSG_FIRSTHDR(msg); 61 | 62 | while (cmsg) { 63 | int n_fds_in_cmsg = 0; 64 | 65 | if (cmsg->cmsg_level != SOL_SOCKET || cmsg->cmsg_type != SCM_RIGHTS) { 66 | cmsg = CMSG_NXTHDR(msg, cmsg); 67 | continue; 68 | } 69 | 70 | size = cmsg->cmsg_len - CMSG_LEN(0); 71 | 72 | n_fds_in_cmsg = size / sizeof(int32_t); 73 | 74 | if (bufsize < size) { 75 | /* TODO: close the fds */ 76 | return -1; 77 | } 78 | 79 | memcpy(fdp, CMSG_DATA(cmsg), size); 80 | fdp += n_fds_in_cmsg; 81 | n += n_fds_in_cmsg; 82 | bufsize -= size; 83 | 84 | cmsg = CMSG_NXTHDR(msg, cmsg); 85 | } 86 | 87 | return n; 88 | } 89 | 90 | int recvmsg_wayland(int fd, const char *buf, int bufsize, int *fds, 91 | int fdbufsize, int *n_fds) 92 | { 93 | char cmsg_buf[CMSG_LEN(MAX_FDS*4)]; 94 | struct iovec iov[1]; 95 | struct msghdr msg; 96 | int len; 97 | 98 | iov[0].iov_base = (void *) buf; 99 | iov[0].iov_len = bufsize; 100 | 101 | msg.msg_name = NULL; 102 | msg.msg_namelen = 0; 103 | msg.msg_iov = iov; 104 | msg.msg_iovlen = 1; 105 | msg.msg_control = cmsg_buf; 106 | msg.msg_controllen = sizeof(cmsg_buf); 107 | msg.msg_flags = 0; 108 | 109 | do { 110 | len = recvmsg(fd, &msg, MSG_CMSG_CLOEXEC); 111 | } while (len == -1 && errno == EINTR); 112 | 113 | if (len >= 0) 114 | *n_fds = decode_cmsg(fds, fdbufsize, &msg); 115 | else { 116 | /* printf("recvmsg error: %m!\n"); */ 117 | *n_fds = 0; 118 | } 119 | 120 | return len; 121 | } 122 | 123 | int sendmsg_wayland(int fd, const char *buf, int bufsize, int *fds, int n_fds) 124 | { 125 | char cmsg_buf[CMSG_LEN(MAX_FDS*4)]; 126 | struct iovec iov[1]; 127 | struct msghdr msg; 128 | int clen, len, i; 129 | 130 | iov[0].iov_base = (void *) buf; 131 | iov[0].iov_len = bufsize; 132 | 133 | build_cmsg(fds, n_fds, cmsg_buf, &clen); 134 | 135 | msg.msg_name = NULL; 136 | msg.msg_namelen = 0; 137 | msg.msg_iov = iov; 138 | msg.msg_iovlen = 1; 139 | msg.msg_control = cmsg_buf; 140 | msg.msg_controllen = clen; 141 | msg.msg_flags = 0; 142 | 143 | do { 144 | len = sendmsg(fd, &msg, MSG_NOSIGNAL | MSG_DONTWAIT); 145 | } while (len == -1 && errno == EINTR); 146 | 147 | if (len == -1) { 148 | /* printf("sendmsg error: %m!\n"); */ 149 | return -1; 150 | } 151 | 152 | /* close the fds now */ 153 | 154 | for (i = 0; i < n_fds; i++) { 155 | close(fds[i]); 156 | } 157 | 158 | return len; 159 | } -------------------------------------------------------------------------------- /src/ParseWaylandXML.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright © 2014 Intel Corporation 3 | 4 | Permission to use, copy, modify, distribute, and sell this software and its 5 | documentation for any purpose is hereby granted without fee, provided that 6 | the above copyright notice appear in all copies and that both that copyright 7 | notice and this permission notice appear in supporting documentation, and 8 | that the name of the copyright holders not be used in advertising or 9 | publicity pertaining to distribution of the software without specific, 10 | written prior permission. The copyright holders make no representations 11 | about the suitability of this software for any purpose. It is provided "as 12 | is" without express or implied warranty. 13 | 14 | THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 15 | INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO 16 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR 17 | CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 18 | DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 19 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 20 | OF THIS SOFTWARE. 21 | -} 22 | 23 | module ParseWaylandXML ( 24 | parseWaylandXML, 25 | WArgumentType(..), 26 | WArgumentDescription(..), 27 | WMessageDescription(..), 28 | WInterfaceDescription(..), 29 | WMessageMap) 30 | 31 | where 32 | 33 | import qualified Data.IntMap as IM 34 | import qualified Data.List as L 35 | import qualified Data.Map.Strict as DM 36 | import qualified Data.Maybe as Maybe 37 | import qualified Text.XML.Light as XML 38 | 39 | data WArgumentType = WInt 40 | | WUInt 41 | | WFixed 42 | | WString 43 | | WObject 44 | | WNewId 45 | | WArray 46 | | WFd deriving (Eq, Show) 47 | 48 | data WArgumentDescription = WArgumentDescription 49 | { argDescrName :: String, 50 | argDescrType :: WArgumentType, 51 | argDescrInterface :: String 52 | } deriving (Eq, Show) 53 | 54 | data WMessageDescription = WMessageDescription 55 | { msgDescrName :: String, 56 | msgDescrArgs :: [WArgumentDescription] 57 | } deriving (Eq, Show) 58 | 59 | data WInterfaceDescription = WInterfaceDescription 60 | { interfaceDescrName :: String, 61 | interfaceRequests :: WMessageMap, 62 | interfaceEvents :: WMessageMap 63 | } deriving (Eq, Show) 64 | 65 | type WMessageMap = IM.IntMap WMessageDescription 66 | 67 | argumentMap :: DM.Map String WArgumentType 68 | argumentMap = DM.fromList [ ("int", WInt), ("uint", WUInt), 69 | ("fixed", WFixed), ("string", WString), 70 | ("object", WObject), ("new_id", WNewId), 71 | ("array", WArray), ("fd", WFd) ] 72 | 73 | 74 | parseArgument :: XML.Element -> Maybe WArgumentDescription 75 | parseArgument e = do 76 | argName <- XML.findAttr (XML.QName "name" Nothing Nothing) e 77 | argTypeString <- XML.findAttr (XML.QName "type" Nothing Nothing) e 78 | argType <- DM.lookup argTypeString argumentMap 79 | let argInterface = Maybe.fromMaybe "" (XML.findAttr (XML.QName "interface" Nothing Nothing) e) 80 | return $ WArgumentDescription argName argType argInterface 81 | 82 | 83 | parseMessage :: XML.Element -> Maybe WMessageDescription 84 | parseMessage e = do 85 | messageName <- XML.findAttr (XML.QName "name" Nothing Nothing) e 86 | arguments <- mapM parseArgument $ xmlArguments e 87 | return $ WMessageDescription messageName arguments 88 | 89 | where 90 | xmlArguments :: XML.Element -> [XML.Element] 91 | xmlArguments = XML.findElements (XML.QName "arg" Nothing Nothing) 92 | 93 | 94 | parseInterface :: XML.Element -> Maybe WInterfaceDescription 95 | parseInterface e = do 96 | interfaceName <- XML.findAttr (XML.QName "name" Nothing Nothing) e 97 | requests <- mapM parseMessage $ xmlRequests e 98 | events <- mapM parseMessage $ xmlEvents e 99 | return $ WInterfaceDescription interfaceName (messageMap requests) (messageMap events) 100 | 101 | where 102 | xmlRequests :: XML.Element -> [XML.Element] 103 | xmlRequests = XML.findElements (XML.QName "request" Nothing Nothing) 104 | 105 | xmlEvents :: XML.Element -> [XML.Element] 106 | xmlEvents = XML.findElements (XML.QName "event" Nothing Nothing) 107 | 108 | messageMap :: [WMessageDescription] -> WMessageMap 109 | messageMap = IM.fromList . L.zip [0..] -- opcodes start from 0 110 | 111 | 112 | parseWaylandXML :: String -> Maybe [WInterfaceDescription] 113 | parseWaylandXML fileData = do 114 | xmlDoc <- XML.parseXMLDoc fileData 115 | mapM parseInterface $ xmlInterfaces xmlDoc 116 | 117 | where 118 | xmlInterfaces :: XML.Element -> [XML.Element] 119 | xmlInterfaces = XML.findElements (XML.QName "interface" Nothing Nothing) 120 | -------------------------------------------------------------------------------- /src/Log.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright © 2014 Intel Corporation 3 | 4 | Permission to use, copy, modify, distribute, and sell this software and its 5 | documentation for any purpose is hereby granted without fee, provided that 6 | the above copyright notice appear in all copies and that both that copyright 7 | notice and this permission notice appear in supporting documentation, and 8 | that the name of the copyright holders not be used in advertising or 9 | publicity pertaining to distribution of the software without specific, 10 | written prior permission. The copyright holders make no representations 11 | about the suitability of this software for any purpose. It is provided "as 12 | is" without express or implied warranty. 13 | 14 | THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 15 | INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO 16 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR 17 | CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 18 | DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 19 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 20 | OF THIS SOFTWARE. 21 | -} 22 | 23 | {-# LANGUAGE OverloadedStrings #-} 24 | 25 | module Log ( 26 | writeLog, 27 | writeBinaryLog) 28 | 29 | where 30 | 31 | import qualified Data.Aeson as A 32 | import qualified Data.Aeson.Encode.Pretty as AP 33 | import qualified Data.ByteString as BS 34 | import qualified Data.ByteString.Base16 as B16 35 | import qualified Data.ByteString.Char8 as C8 36 | import qualified Data.ByteString.Lazy as BSL 37 | import qualified Data.Time.Clock as Clock 38 | import qualified System.IO as IO 39 | import Data.Monoid 40 | 41 | import Types 42 | 43 | data StampedMessage = StampedMessage String ParsedMessage deriving (Eq, Show) 44 | 45 | instance A.ToJSON StampedMessage where 46 | toJSON (StampedMessage time msg) = A.object 47 | [ "timestamp" A..= time, "message" A..= msg ] 48 | 49 | 50 | -- make bytestring length at least specified 51 | padBs :: Int -> BS.ByteString -> BS.ByteString 52 | padBs neededSize bs = 53 | let 54 | extra = neededSize - BS.length bs 55 | padding n = C8.replicate n ' ' 56 | in 57 | if extra > 0 58 | then bs <> padding extra 59 | else bs 60 | 61 | 62 | -- split bytestring at chunkSize with another bytestring in between 63 | -- example: 123456789 becomes 12 34 56 78 9 if padding is two 64 | splitBs :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString 65 | splitBs chunkSize between bstr = BS.intercalate between $ split bstr [] 66 | where 67 | split bs acc = 68 | if BS.null bs 69 | then reverse acc 70 | else let 71 | chunk = BS.take chunkSize bs 72 | in 73 | split (BS.drop chunkSize bs) (chunk:acc) 74 | 75 | 76 | generateTS :: Clock.NominalDiffTime -> BS.ByteString 77 | generateTS time = C8.singleton '[' <> padBs 12 (C8.pack (show time)) <> C8.singleton ']' 78 | 79 | 80 | bSpace :: C8.ByteString 81 | bSpace = C8.singleton ' ' 82 | 83 | 84 | bNewLine :: C8.ByteString 85 | bNewLine = C8.singleton '\n' 86 | 87 | 88 | toStringBinary :: BS.ByteString -> ParsedBinaryMessage -> BS.ByteString 89 | toStringBinary ts (ParsedBinaryMessage t sender opcode size d) = 90 | let typeS = padBs 7 $ getMessageTypeString t 91 | senderS = C8.pack "sender=" <> padBs 2 (C8.pack (show sender)) 92 | opcodeS = C8.pack "op=" <> padBs 2 (C8.pack (show opcode)) 93 | sizeS = C8.pack "size=" <> padBs 2 (C8.pack (show size)) 94 | dataS = splitBs 8 bSpace $ B16.encode d -- split between 8 hex chars 95 | in 96 | ts <> bSpace <> typeS <> bSpace <> senderS <> bSpace <> opcodeS <> bSpace <> 97 | sizeS <> bSpace <> bSpace <> dataS <> bNewLine 98 | 99 | 100 | getMessageTypeString :: MessageType -> BS.ByteString 101 | getMessageTypeString Event = C8.pack "Event" 102 | getMessageTypeString Request = C8.pack "Request" 103 | 104 | 105 | getMessageTypeArrow :: MessageType -> BS.ByteString 106 | getMessageTypeArrow Event = C8.pack "<- " 107 | getMessageTypeArrow Request = C8.pack " ->" 108 | 109 | 110 | writeBinaryLog :: Logger -> Clock.NominalDiffTime -> ParsedBinaryMessage -> IO () 111 | writeBinaryLog (Logger lh _) ts msg = do 112 | let stamp = generateTS ts 113 | BS.hPut lh $ toStringBinary stamp msg 114 | IO.hFlush lh 115 | 116 | 117 | toSimple :: Clock.NominalDiffTime -> ParsedMessage -> BS.ByteString 118 | toSimple ts (UnknownMessage t) = let 119 | stamp = generateTS ts 120 | arrow = getMessageTypeArrow t 121 | in 122 | stamp <> bSpace <> arrow <> bSpace <> C8.pack "Unknown message" 123 | 124 | toSimple ts (Message t n i o args) = let 125 | stamp = generateTS ts 126 | arrow = getMessageTypeArrow t 127 | simpleArgs as = BS.intercalate (C8.pack ", ") (map argToString as) 128 | argToString (MArgument _ a) = case a of 129 | MInt v -> C8.pack $ show v 130 | MUInt v -> C8.pack $ show v 131 | MString v -> C8.singleton '"' <> C8.pack v <> C8.singleton '"' 132 | MFixed s fp sp -> BS.concat $ [C8.singleton '-' | s] ++ 133 | [C8.pack $ show fp, C8.singleton '.', C8.pack $ show sp] 134 | MArray bs -> C8.singleton '[' <> B16.encode bs <> C8.singleton ']' 135 | MFd -> C8.pack "fd" 136 | MNewId object interface -> let 137 | realInterface = C8.pack $ if null interface then "[unknown]" else interface 138 | in 139 | C8.pack "new id " <> realInterface <> C8.singleton '@' <> C8.pack (show object) 140 | MObject v -> C8.pack "object " <> C8.pack (show v) 141 | 142 | in 143 | stamp <> bSpace <> arrow <> bSpace <> C8.pack i <> C8.singleton '@' <> 144 | C8.pack (show o) <> C8.singleton '.' <> C8.pack n <> C8.singleton '(' <> 145 | simpleArgs args <> C8.singleton ')' 146 | 147 | 148 | writeLog :: Logger -> Clock.NominalDiffTime -> ParsedMessage -> IO () 149 | writeLog (Logger lh lt) ts msg = do 150 | -- let stamp = generateTS ts 151 | let smsg = StampedMessage (show ts) msg 152 | case lt of 153 | Json -> do 154 | BSL.hPut lh $ A.encode smsg 155 | BS.hPut lh bNewLine 156 | IO.hFlush lh 157 | JsonPretty -> do 158 | BSL.hPut lh $ AP.encodePretty' conf smsg 159 | BS.hPut lh bNewLine 160 | IO.hFlush lh 161 | Simple -> do 162 | BS.hPut lh $ toSimple ts msg 163 | BS.hPut lh bNewLine 164 | IO.hFlush lh 165 | where 166 | conf = AP.Config (AP.Spaces 4) ordering AP.Generic 167 | ordering = AP.keyOrder ["type", "name", "object", "interface", "arguments", "value", "message", "timestamp"] 168 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | DISCONTINUATION OF PROJECT. 2 | 3 | This project will no longer be maintained by Intel. 4 | 5 | Intel has ceased development and contributions including, but not limited to, maintenance, bug fixes, new releases, or updates, to this project. 6 | 7 | Intel no longer accepts patches to this project. 8 | 9 | If you have an ongoing need to use this project, are interested in independently developing it, or would like to maintain patches for the open source software community, please create your own fork of this project. 10 | WAYLAND-TRACKER 11 | =============== 12 | 13 | Wayland-tracker is a Wayland message protocol dumper, licensed with the Wayland 14 | MIT license. 15 | 16 | *Question:* Why use this instead of just setting WAYLAND_DEBUG environment 17 | variable for the application? 18 | 19 | *Answer:* Having message tracking outside Wayland library helps debug 20 | difficult-to-catch problems. The wayland-tracker tool does not depend on 21 | application implementation or Wayland library, and it potentially gives more 22 | information about the messages such as the names of the message arguments. Also, 23 | being able to output the messages in JSON format means that you can feed the 24 | results to an external tool that, for instance, counts how many messages needed 25 | to be sent for some application use case or finds warning messages. 26 | 27 | Using wayland-tracker 28 | --------------------- 29 | 30 | Wayland-tracker sits between Wayland server (such as Weston) and a Wayland 31 | client, dumping all message traffic to both directions. 32 | 33 | Wayland-tracker has four output modes: `binary`, `simple`, `json` and 34 | `json_pretty`. The simple mode outputs the messages in a format that is very 35 | close to WAYLAND_DEBUG style logging. The JSON modes output the messages in 36 | JSON format and binary mode outputs the messages in binary format. To use JSON 37 | or simple format, you need to have the protocol description XML files that are 38 | being used by the application and server you are running. The XML protocol files 39 | are provided using `-x` command line option. 40 | 41 | For example, command 42 | 43 | wayland-tracker json -x wayland.xml -x xdg-shell.xml -x workspaces.xml -- weston-terminal 44 | 45 | might print messages such as these (and much more): 46 | 47 | {"message":{"arguments":[{"value":{"value":3,"type":"NewId"},"name":"callback"}],"name":"sync","interface":"wl_display","object":1,"type":"Request"},"timestamp":"0.158632s"} 48 | {"message":{"arguments":[{"value":{"value":2,"type":"NewId"},"name":"registry"}],"name":"get_registry","interface":"wl_display","object":1,"type":"Request"},"timestamp":"0.158632s"} 49 | {"message":{"arguments":[{"value":{"value":3,"type":"UInt"},"name":"id"}],"name":"delete_id","interface":"wl_display","object":1,"type":"Event"},"timestamp":"0.158947s"} 50 | {"message":{"arguments":[{"value":{"value":5244,"type":"UInt"},"name":"callback_data"}],"name":"done","interface":"wl_callback","object":3,"type":"Event"},"timestamp":"0.158947s"} 51 | 52 | Output mode `json_pretty` uses a JSON pretty-printer to make JSON messages more 53 | human-readable while using exactly the same options as `json`: 54 | 55 | { 56 | "message": { 57 | "type": "Request", 58 | "name": "set_window_geometry", 59 | "object": 15, 60 | "interface": "xdg_surface", 61 | "arguments": [ 62 | { 63 | "name": "x", 64 | "value": { 65 | "type": "Int", 66 | "value": 32 67 | } 68 | }, 69 | { 70 | "name": "y", 71 | "value": { 72 | "type": "Int", 73 | "value": 32 74 | } 75 | }, 76 | { 77 | "name": "width", 78 | "value": { 79 | "type": "Int", 80 | "value": 742 81 | } 82 | }, 83 | { 84 | "name": "height", 85 | "value": { 86 | "type": "Int", 87 | "value": 427 88 | } 89 | } 90 | ] 91 | }, 92 | "timestamp": "0.157951s" 93 | } 94 | 95 | Output mode `simple` is used with the following: 96 | 97 | wayland-tracker simple -x wayland.xml -x xdg-shell.xml -x workspaces.xml -- weston-terminal 98 | 99 | The simple output looks like this: 100 | 101 | [0.100927s ] -> wl_registry@2.bind(3, "wl_subcompositor", 1, new id [unknown]@5) 102 | [0.100927s ] -> wl_registry@2.bind(2, "wl_compositor", 3, new id [unknown]@4) 103 | [0.102968s ] <- xdg_surface@15.configure(0, 0, [04000000], 9969) 104 | [0.102968s ] <- wl_surface@14.enter(object 11) 105 | [0.102968s ] <- wl_display@1.delete_id(17) 106 | [0.102968s ] <- wl_display@1.delete_id(16) 107 | [0.102968s ] <- workspace_manager@13.state(0, 1) 108 | [0.102968s ] <- wl_output@11.done() 109 | [0.102968s ] <- wl_output@11.mode(3, 1024, 640, 60000) 110 | 111 | The arrows indicate the message direction (`->` for requests, `<-` for events). 112 | A good place to find the protocol XML files are the Wayland and Weston git 113 | repositiories. 114 | 115 | Binary mode doesn't require XML files, since the protocol state is not 116 | tracked. For instance, command 117 | 118 | wayland-tracker binary -- weston-terminal 119 | 120 | might print out this data (and more): 121 | 122 | [0.012587s ] Request sender=1 op=0 size=12 03000000 123 | [0.012587s ] Request sender=1 op=1 size=12 02000000 124 | [0.012968s ] Event sender=1 op=1 size=12 03000000 125 | [0.012968s ] Event sender=3 op=0 size=12 34090000 126 | [0.012968s ] Event sender=2 op=0 size=36 12000000 0e000000 73637265 656e7368 6f6f7465 72006765 01000000 127 | [0.012968s ] Event sender=2 op=0 size=40 11000000 12000000 776f726b 73706163 655f6d61 6e616765 72000000 01000000 128 | [0.012968s ] Event sender=2 op=0 size=32 10000000 0c000000 73637265 656e7361 76657200 01000000 129 | [0.012968s ] Event sender=2 op=0 size=36 0f000000 0e000000 6465736b 746f705f 7368656c 6c000000 02000000 130 | [0.012968s ] Event sender=2 op=0 size=32 0e000000 0a000000 7864675f 7368656c 6c00616e 01000000 131 | [0.012968s ] Event sender=2 op=0 size=32 0d000000 09000000 776c5f73 68656c6c 0070616e 01000000 132 | [0.012968s ] Event sender=2 op=0 size=36 0c000000 0f000000 776c5f69 6e707574 5f70616e 656c0000 01000000 133 | [0.012968s ] Event sender=2 op=0 size=32 0b000000 0a000000 776c5f6f 75747075 74006574 02000000 134 | [0.012968s ] Event sender=2 op=0 size=36 0a000000 10000000 776c5f69 6e707574 5f6d6574 686f6400 01000000 135 | 136 | The binary format log contains first the time stamp since program launch, then 137 | parsed Wayland message heades (sender, opcode, and message size). The message 138 | data is then printed out in hexadecimal format split into 32-bit words. 139 | 140 | More output modes are expected in the future. 141 | 142 | The diagnostic output from wayland-tracker and all of the application output are 143 | redirected to stderr, while the message dump is provided to stdout. This means 144 | that you can redirect the application output elsewhere using the normal command 145 | line semantics: 146 | 147 | wayland-tracker binary -- weston-terminal 2> /dev/null 148 | 149 | You can also use command line option `-o` to direct the message dump to a file. 150 | 151 | The application and its command line parameters are provided after `--` in the 152 | command line: 153 | 154 | wayland-tracker binary -- weston-terminal --help 155 | 156 | Building wayland-tracker using stack 157 | ------------------------------------ 158 | 159 | [First install and set up stack](http://docs.haskellstack.org/) for your 160 | (Linux) platform. After that you can build the software in the source 161 | directory with `stack build` and install it to stack binary installation 162 | directory with `stack install`. 163 | 164 | Building wayland-tracker using cabal 165 | ------------------------------------ 166 | 167 | Wayland-tracker is written (mostly) in Haskell. To build the software, you need 168 | to first install ghc, gcc and cabal using your package manager. For instance, in 169 | Fedora 20, you would say: 170 | 171 | sudo yum install cabal-install ghc gcc 172 | 173 | In Ubuntu 14.04 a similar command would be: 174 | 175 | sudo apt-get install cabal-install ghc build-essentials 176 | 177 | Then, in the source directory update the cabal package database: 178 | 179 | cabal update 180 | 181 | Install all dependencies of wayland-tracker: 182 | 183 | cabal install --only-dependencies 184 | 185 | And finally configure and build: 186 | 187 | cabal configure 188 | cabal build 189 | 190 | The binary will be created to `dist/build/wayland-tracker/wayland-tracker`. To 191 | install it in `$HOME/.cabal/bin/wayland-tracker`, use: 192 | 193 | cabal install 194 | 195 | Technical information 196 | --------------------- 197 | 198 | The low-level Wayland message sending/receiving is using C code that is directly 199 | based on Wayland library code for maximum compatibility. There is no direct 200 | Wayland dependency, however. 201 | 202 | Message parsing is done using [Attoparsec](https://github.com/bos/attoparsec). 203 | JSON generation uses [Aeson](https://github.com/bos/aeson). 204 | 205 | Future work and improvement ideas 206 | --------------------------------- 207 | 208 | * "pcap" output mode (maybe using text2pcap tool?) 209 | * use quickcheck for testing parsing and log formats 210 | 211 | -------------------------------------------------------------------------------- /src/Tracker.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright © 2014 Intel Corporation 3 | 4 | Permission to use, copy, modify, distribute, and sell this software and its 5 | documentation for any purpose is hereby granted without fee, provided that 6 | the above copyright notice appear in all copies and that both that copyright 7 | notice and this permission notice appear in supporting documentation, and 8 | that the name of the copyright holders not be used in advertising or 9 | publicity pertaining to distribution of the software without specific, 10 | written prior permission. The copyright holders make no representations 11 | about the suitability of this software for any purpose. It is provided "as 12 | is" without express or implied warranty. 13 | 14 | THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 15 | INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO 16 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY SPECIAL, INDIRECT OR 17 | CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 18 | DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 19 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 20 | OF THIS SOFTWARE. 21 | -} 22 | 23 | module Tracker where 24 | 25 | import qualified Control.Concurrent as CC 26 | import qualified Control.Concurrent.STM as STM 27 | import qualified Control.Exception as Exception 28 | import qualified Control.Monad as M 29 | import qualified Data.Attoparsec.Binary as AB 30 | import qualified Data.Attoparsec.ByteString as A 31 | import qualified Data.Binary as B 32 | import qualified Data.Binary.Bits.Get as BBG 33 | import qualified Data.Binary.Get as BG 34 | import qualified Data.ByteString as BS 35 | import qualified Data.ByteString.Lazy as BSL 36 | import qualified Data.ByteString.UTF8 as U 37 | import qualified Data.IntMap as IM 38 | import qualified Data.List as List 39 | import qualified Data.Map.Strict as DM 40 | import qualified Data.Maybe as Maybe 41 | import qualified Data.Time.Clock as Clock 42 | import qualified Data.Word as W 43 | import qualified Network.Socket as Socket 44 | import qualified System.Endian as Endian 45 | import qualified System.Environment as E 46 | import qualified System.Exit as Exit 47 | import qualified System.IO as IO 48 | import qualified System.IO.Error as Err 49 | import qualified System.Posix.IO as PI 50 | import qualified System.Posix.Process as Process 51 | import qualified System.Posix.Signals as Signals 52 | import qualified System.Posix.Types as PT 53 | import qualified System.Posix.User as PU 54 | 55 | import Log 56 | import ParseWaylandXML 57 | import Types 58 | import Wayland 59 | 60 | data Event = ServerClosedSocket 61 | | ClientClosedSocket 62 | | ProcessingEnded 63 | | SigChld 64 | | SigInt 65 | deriving (Show, Eq) 66 | 67 | -- mapping of interface names to interfaces 68 | type InterfaceMap = DM.Map String WInterfaceDescription 69 | 70 | -- mapping of bound object ids to interfaces 71 | type ObjectMap = IM.IntMap WInterfaceDescription 72 | 73 | 74 | -- read values in correct endianness 75 | 76 | anyWord32he :: A.Parser W.Word32 77 | anyWord32he = 78 | case Endian.getSystemEndianness of 79 | Endian.LittleEndian -> AB.anyWord32le 80 | Endian.BigEndian -> AB.anyWord32be 81 | 82 | 83 | anyWord16he :: A.Parser W.Word16 84 | anyWord16he = 85 | case Endian.getSystemEndianness of 86 | Endian.LittleEndian -> AB.anyWord16le 87 | Endian.BigEndian -> AB.anyWord16be 88 | 89 | 90 | putStrLnErr :: String -> IO () 91 | putStrLnErr s = do 92 | IO.hPutStr IO.stderr ("wayland-tracker: " ++ s) 93 | IO.hPutStr IO.stderr "\n" 94 | 95 | 96 | {- 97 | -- debug: dump a bytestring in hex format to stdout 98 | dumpByteString :: BS.ByteString -> IO () 99 | dumpByteString bs = do 100 | M.mapM_ (\n -> putStr $ N.showHex n " ") bytes 101 | putStrLn "" 102 | where 103 | bytes = BS.unpack bs 104 | -} 105 | 106 | 107 | intParser :: A.Parser MArgumentValue 108 | intParser = do 109 | v <- anyWord32he 110 | return $ MInt $ fromIntegral v 111 | 112 | 113 | uintParser :: A.Parser MArgumentValue 114 | uintParser = do 115 | v <- anyWord32he 116 | return $ MUInt $ fromIntegral v 117 | 118 | 119 | objectParser :: A.Parser MArgumentValue 120 | objectParser = do 121 | v <- anyWord32he 122 | return $ MObject $ fromIntegral v 123 | 124 | 125 | newIdParser :: String -> A.Parser MArgumentValue 126 | newIdParser interface = do 127 | v <- anyWord32he 128 | return $ MNewId (fromIntegral v) interface 129 | 130 | 131 | fixedParser :: A.Parser MArgumentValue 132 | fixedParser = do 133 | v <- anyWord32he 134 | let bs = B.encode v 135 | let (sign, f, s) = getFixedValues bs 136 | return $ MFixed sign f s 137 | where 138 | getFixedValues :: BSL.ByteString -> (Bool, Int, Int) 139 | getFixedValues = BG.runGet $ do 140 | (a, b, c) <- BBG.runBitGet parseFixed 141 | return (a,b,c) 142 | 143 | parseFixed :: BBG.BitGet (Bool, Int, Int) 144 | parseFixed = do 145 | sign <- BBG.getBool 146 | f <- BBG.getWord32be 23 147 | s <- BBG.getWord8 8 148 | return (sign, fromIntegral f, fromIntegral s) 149 | 150 | 151 | paddedLength :: Int -> Int 152 | paddedLength len = if rem len 4 == 0 153 | then len 154 | else len + 4 - rem len 4 155 | 156 | 157 | stringParser :: A.Parser MArgumentValue 158 | stringParser = do 159 | lenW <- anyWord32he 160 | let dataLen = fromIntegral lenW 161 | if dataLen == 0 -- this is a null string, it's not even an empty string 162 | then return $ MString "(null)" -- TODO: better representation? 163 | else do 164 | str <- A.take (dataLen - 1) 165 | A.take 1 -- the terminating NUL byte 166 | A.take $ (paddedLength dataLen) - dataLen -- read padded bytes 167 | return $ MString $ U.toString str 168 | 169 | 170 | arrayParser :: A.Parser MArgumentValue 171 | arrayParser = do 172 | lenW <- anyWord32he 173 | let dataLen = fromIntegral lenW 174 | arr <- A.take dataLen 175 | A.take $ (paddedLength dataLen) - dataLen 176 | return $ MArray arr 177 | 178 | 179 | fdParser :: A.Parser MArgumentValue 180 | fdParser = return MFd 181 | 182 | 183 | messageDataParser :: WMessageDescription -> A.Parser [MArgument] 184 | messageDataParser (WMessageDescription _ msgArgs) = do 185 | let ps = reverse $ messageBlockParser msgArgs [] 186 | values <- M.sequence ps 187 | let combined = zipWith (\a v -> MArgument (argDescrName a) v) msgArgs values 188 | return combined 189 | where 190 | messageBlockParser :: [WArgumentDescription] -> [A.Parser MArgumentValue] -> [A.Parser MArgumentValue] 191 | messageBlockParser [] parsers = parsers 192 | messageBlockParser (arg:args) parsers = messageBlockParser args (selectParser arg:parsers) 193 | where 194 | selectParser :: WArgumentDescription -> A.Parser MArgumentValue 195 | selectParser a = case argDescrType a of 196 | WInt -> intParser 197 | WUInt -> uintParser 198 | WFd -> fdParser 199 | WObject -> objectParser 200 | WNewId -> newIdParser $ argDescrInterface a 201 | WString -> stringParser 202 | WArray -> arrayParser 203 | WFixed -> fixedParser 204 | 205 | 206 | messageParser :: ObjectMap -> InterfaceMap -> MessageType -> A.Parser ParsedMessage 207 | messageParser om _ t = do 208 | senderIdW <- anyWord32he 209 | opCodeW <- anyWord16he 210 | msgSizeW <- anyWord16he 211 | 212 | let sId = fromIntegral senderIdW 213 | let size = fromIntegral msgSizeW 214 | let op = fromIntegral opCodeW 215 | 216 | case IM.lookup sId om of 217 | Just interfaceDescription -> case IM.lookup op (getMap t interfaceDescription) of 218 | Just messageDescription -> do 219 | let messageName = msgDescrName messageDescription 220 | let interfaceName = interfaceDescrName interfaceDescription 221 | args <- messageDataParser messageDescription 222 | return $ Message t messageName interfaceName sId args 223 | Nothing -> do 224 | A.take (size - 8) 225 | return $ UnknownMessage t 226 | Nothing -> do 227 | A.take (size - 8) 228 | return $ UnknownMessage t 229 | 230 | where 231 | getMap :: MessageType -> WInterfaceDescription -> WMessageMap 232 | getMap messageType interface = case messageType of 233 | Request -> interfaceRequests interface 234 | Event -> interfaceEvents interface 235 | 236 | 237 | binaryMessageParser:: MessageType -> A.Parser ParsedBinaryMessage 238 | binaryMessageParser t = do 239 | senderIdW <- anyWord32he 240 | opCodeW <- anyWord16he 241 | msgSizeW <- anyWord16he 242 | 243 | let sId = fromIntegral senderIdW 244 | let size = fromIntegral msgSizeW 245 | let op = fromIntegral opCodeW 246 | 247 | msgBs <- A.take (size - 8) 248 | 249 | return $ ParsedBinaryMessage t sId op size msgBs 250 | 251 | 252 | isNewId :: MArgument -> Bool 253 | isNewId (MArgument _ (MNewId _ _)) = True 254 | isNewId _ = False 255 | 256 | 257 | updateMap :: InterfaceMap -> ParsedMessage -> ObjectMap -> ObjectMap 258 | updateMap im msg om = 259 | case msg of 260 | Message _ name _ _ _ -> 261 | case name of 262 | "bind" -> Maybe.fromMaybe om (processBind om msg) 263 | "delete_id" -> Maybe.fromMaybe om (processDeleteId om msg) 264 | _ -> Maybe.fromMaybe om (processCreateObject om msg) 265 | UnknownMessage _ -> om 266 | where 267 | processBind oldOm (Message _ _ _ _ args) = do 268 | iface <- List.find (\a -> argName a == "interface") args 269 | newId <- List.find (\a -> argName a == "id") args 270 | case argValue iface of 271 | MString sv -> do 272 | interfaceDescr <- DM.lookup sv im 273 | case argValue newId of 274 | MNewId niv _ -> Just $ IM.insert niv interfaceDescr oldOm 275 | _ -> Nothing 276 | _ -> Nothing 277 | 278 | processCreateObject oldOm (Message _ _ _ _ args) = do 279 | newId <- List.find isNewId args 280 | case argValue newId of 281 | MNewId niv interface -> do 282 | interfaceDescr <- DM.lookup interface im 283 | Just $ IM.insert niv interfaceDescr oldOm 284 | _ -> Nothing 285 | 286 | processDeleteId oldOm (Message _ _ _ _ args) = do 287 | deletedId <- List.find (\a -> argName a == "id") args 288 | case argValue deletedId of 289 | MUInt v -> Just $ IM.delete v oldOm 290 | _ -> Nothing 291 | 292 | 293 | parseBinaryData :: MessageType -> BS.ByteString -> [ParsedBinaryMessage] -> 294 | Either String [ParsedBinaryMessage] 295 | parseBinaryData t bs msgs = 296 | case A.parse (binaryMessageParser t) bs of 297 | A.Fail _ _ err -> Left ("Parsing failure: " ++ err) 298 | A.Partial _ -> Left "Confused with protocol files and actual data" 299 | A.Done i msg -> 300 | if BS.null i 301 | then Right (msg:msgs) 302 | else parseBinaryData t i (msg:msgs) 303 | 304 | 305 | parseData :: MessageType -> ObjectMap -> InterfaceMap -> BS.ByteString -> 306 | [ParsedMessage] -> Either String ([ParsedMessage], ObjectMap) 307 | parseData t om im bs msgs = 308 | case A.parse (messageParser om im t) bs of 309 | A.Fail _ _ err -> Left ("Parsing failure: " ++ err) 310 | A.Partial _ -> Left "Confused with protocol files and actual data" 311 | A.Done i msg -> 312 | -- update object map 313 | let newOm = updateMap im msg om 314 | in 315 | if BS.null i 316 | then Right (msg:msgs, newOm) 317 | else parseData t newOm im i (msg:msgs) 318 | 319 | 320 | processingThread :: STM.TMVar Event -> 321 | (Clock.UTCTime -> Clock.NominalDiffTime) -> [String] -> 322 | STM.TChan (Maybe (MessageType, BS.ByteString, [Int])) -> 323 | IO.Handle -> LogType -> IO () 324 | processingThread eventV ts xfs chan lh lt = do 325 | 326 | -- read the protocol file(s) 327 | 328 | case lt of 329 | Binary -> processBinaryData chan 330 | _ -> do 331 | res <- Exception.try $ readXmlData xfs DM.empty :: IO (Either Exception.IOException (Maybe InterfaceMap)) 332 | case res of 333 | Left _ -> putStrLnErr "Error reading XML files" 334 | Right xmlData -> case getXmlData xmlData of 335 | Nothing -> putStrLnErr "Error parsing of XML files" 336 | Just (im, displayDescr) -> do 337 | -- initialize object map with known global mapping: 338 | -- 1 -> "wl_display" 339 | let objectMap = IM.insert 1 displayDescr IM.empty 340 | processData chan objectMap im 341 | 342 | -- send an error message to the channel if we end here: it means 343 | -- that something has gone wrong with the XML files or that the main 344 | -- program has asked us to quit. 345 | 346 | STM.atomically $ STM.putTMVar eventV ProcessingEnded 347 | 348 | where 349 | getXmlData xmlData = do 350 | interfaceMap <- xmlData 351 | displayDescr <- DM.lookup "wl_display" interfaceMap 352 | return (interfaceMap, displayDescr) 353 | 354 | logger = Logger lh lt 355 | 356 | processBinaryData input = do 357 | v <- STM.atomically $ STM.readTChan input 358 | 359 | case v of 360 | Nothing -> return () -- time to end this thread 361 | Just (t, bs, _) -> do 362 | 363 | -- Everything read in one go will have the same timestamp 364 | currentTime <- Clock.getCurrentTime 365 | let timeStamp = ts currentTime 366 | 367 | let r = parseBinaryData t bs [] 368 | case r of 369 | Right msgs -> do 370 | mapM_ (writeBinaryLog logger timeStamp) msgs 371 | processBinaryData chan 372 | Left str -> do 373 | putStrLnErr str 374 | processBinaryData chan 375 | 376 | processData input objectMap im = do 377 | v <- STM.atomically $ STM.readTChan input 378 | 379 | case v of 380 | Nothing -> return () -- time to end this thread 381 | Just (t, bs, _) -> do 382 | 383 | currentTime <- Clock.getCurrentTime 384 | let timeStamp = ts currentTime 385 | 386 | -- Logging file descriptors doesn't make much sense, because 387 | -- the fd numbers will anyway change when they are passed 388 | -- over the socket. 389 | 390 | let r = parseData t objectMap im bs [] 391 | case r of 392 | Right (msgs, newObjectMap) -> do 393 | mapM_ (writeLog logger timeStamp) msgs 394 | processData chan newObjectMap im 395 | Left str -> do 396 | putStrLnErr str 397 | processData chan objectMap im 398 | 399 | 400 | rwloop :: MessageType -> Socket.Socket -> Socket.Socket -> 401 | STM.TChan (Maybe (MessageType, BS.ByteString, [Int])) -> IO Event 402 | rwloop t inputSock outputSock logger = do 403 | 404 | (bs, fds) <- Err.catchIOError (recvFromWayland inputSock) (\_ -> return (BS.empty, [])) 405 | 406 | if BS.null bs 407 | then if t == Request then return ClientClosedSocket else return ServerClosedSocket 408 | else do 409 | sent <- Err.catchIOError (sendToWayland outputSock bs fds) (\_ -> return 0) 410 | if sent == 0 411 | then if t == Event then return ClientClosedSocket else return ServerClosedSocket 412 | else do 413 | STM.atomically $ STM.writeTChan logger $ Just (t, bs, fds) 414 | rwloop t inputSock outputSock logger 415 | 416 | 417 | {- 418 | Some objects are so called "typeless objects". The scanner generates extra code 419 | for them, meaning that the message description in the xml protocol files is not 420 | an accurate description of the message content on the wire. 421 | -} 422 | 423 | isTypelessObject :: WMessageDescription -> Bool 424 | isTypelessObject (WMessageDescription _ args) = any typeless args 425 | where typeless (WArgumentDescription _ t i) = t == WNewId && i == "" 426 | 427 | 428 | fixMessage :: WMessageDescription -> WMessageDescription 429 | fixMessage msg@(WMessageDescription n args) = 430 | if isTypelessObject msg 431 | then 432 | -- insert new fields before the new_id parameter 433 | let beginning = takeWhile (\a -> argDescrType a /= WNewId) args 434 | end = dropWhile (\a -> argDescrType a /= WNewId) args 435 | newArgs = [ WArgumentDescription "interface" WString "", 436 | WArgumentDescription "version" WUInt "" ] 437 | in 438 | WMessageDescription n (beginning ++ newArgs ++ end) 439 | else 440 | msg 441 | 442 | 443 | fixInterface :: WInterfaceDescription -> WInterfaceDescription 444 | fixInterface (WInterfaceDescription n rs es) = 445 | WInterfaceDescription n (IM.map fixMessage rs) (IM.map fixMessage es) 446 | 447 | 448 | clientThread :: STM.TMVar Event -> Socket.Socket -> Socket.Socket -> 449 | STM.TChan (Maybe (MessageType, BS.ByteString, [Int])) -> IO () 450 | clientThread eventV clientSock serverSock loggerChan = do 451 | event <- rwloop Request clientSock serverSock loggerChan 452 | STM.atomically $ STM.putTMVar eventV event 453 | 454 | 455 | serverThread :: STM.TMVar Event -> Socket.Socket -> Socket.Socket -> 456 | STM.TChan (Maybe (MessageType, BS.ByteString, [Int])) -> IO () 457 | serverThread eventV serverSock clientSock loggerChan = do 458 | event <- rwloop Event serverSock clientSock loggerChan 459 | STM.atomically $ STM.putTMVar eventV event 460 | 461 | 462 | passThread :: PT.Fd -> PT.Fd -> IO () 463 | passThread input output = do 464 | hInput <- PI.fdToHandle input 465 | hOutput <- PI.fdToHandle output 466 | IO.hSetBuffering hInput IO.NoBuffering 467 | IO.hSetBuffering hOutput IO.NoBuffering 468 | IO.hSetBinaryMode hInput True 469 | IO.hSetBinaryMode hOutput True 470 | loop hInput hOutput 471 | where 472 | loop i o = do 473 | closed <- IO.hIsClosed i 474 | if closed 475 | then IO.hClose o -- close also the output fd 476 | else do 477 | str <- IO.hGetContents i 478 | IO.hPutStr o str 479 | IO.hFlush o 480 | loop i o 481 | 482 | 483 | execProcess :: FilePath -> [String] -> Socket.Socket -> PT.Fd -> PT.Fd -> IO a 484 | execProcess path args sock writeFd readFd = do 485 | let wFd = show $ Socket.fdSocket sock 486 | 487 | env <- E.getEnvironment 488 | let filteredEnv = filter (\x -> fst x /= "WAYLAND_SOCKET") env 489 | 490 | -- channel child's stdout, stderr to local stderr and local stdin to 491 | -- child's stdin 492 | 493 | IO.hClose IO.stdin 494 | IO.hClose IO.stdout 495 | IO.hClose IO.stderr 496 | 497 | PI.dupTo readFd PI.stdInput 498 | PI.dupTo writeFd PI.stdOutput 499 | PI.dupTo writeFd PI.stdError 500 | 501 | PI.closeFd writeFd 502 | PI.closeFd readFd 503 | 504 | -- putStrLnErr $ "Exec " ++ path ++ " with WAYLAND_SOCKET=" ++ fd 505 | Process.executeFile path True args (Just $ ("WAYLAND_SOCKET", wFd):filteredEnv) 506 | 507 | 508 | createXdgPath :: a -> IO String 509 | createXdgPath _ = do 510 | userid <- PU.getRealUserID 511 | return $ "/var/run/" ++ show userid 512 | 513 | 514 | sigHandler :: Signals.Signal -> STM.TMVar Event -> IO () 515 | sigHandler sig var = do 516 | let e = if sig == Signals.sigINT 517 | then SigInt 518 | else SigChld 519 | STM.atomically $ STM.putTMVar var e 520 | 521 | 522 | readXmlData :: [FilePath] -> InterfaceMap -> IO (Maybe InterfaceMap) 523 | readXmlData [] mapping = return $ Just mapping 524 | readXmlData (xf:xfs) mapping = do 525 | h <- IO.openFile xf IO.ReadMode 526 | -- set encoding, because Wayland XML files are UTF8 527 | IO.hSetEncoding h IO.utf8 528 | d <- IO.hGetContents h 529 | case addMapping d mapping of 530 | Nothing -> do 531 | IO.hClose h 532 | return Nothing 533 | Just m -> do 534 | IO.hClose h 535 | readXmlData xfs m 536 | 537 | where 538 | addMapping :: String -> InterfaceMap -> Maybe InterfaceMap 539 | addMapping d imap = do 540 | is <- parseWaylandXML d 541 | let fixedIs = map fixInterface is 542 | let m = foldr (\i -> DM.insert (interfaceDescrName i) i) DM.empty fixedIs 543 | let exists = not $ DM.null $ DM.intersection m imap 544 | if exists 545 | then Nothing 546 | else Just $ DM.union imap m 547 | 548 | 549 | timeSinceStart :: Clock.UTCTime -> Clock.UTCTime -> Clock.NominalDiffTime 550 | timeSinceStart beginning current = Clock.diffUTCTime current beginning 551 | 552 | 553 | runApplication :: [String] -> LogType -> Maybe String -> String -> [String] -> IO () 554 | runApplication xfs lt lf cmd cmdargs = do 555 | 556 | logHandle <- if Maybe.isNothing lf 557 | then return IO.stdout 558 | else IO.openFile (Maybe.fromJust lf) IO.WriteMode 559 | 560 | beginning <- Clock.getCurrentTime 561 | let ts = timeSinceStart beginning 562 | 563 | -- read the WAYLAND_DISPLAY environment variable 564 | 565 | loggerChan <- STM.newTChanIO 566 | eventV <- STM.newEmptyTMVarIO 567 | 568 | _ <- Signals.installHandler Signals.sigINT (Signals.Catch $ sigHandler Signals.sigINT eventV) Nothing 569 | _ <- Signals.installHandler Signals.sigCHLD (Signals.Catch $ sigHandler Signals.sigCHLD eventV) Nothing 570 | 571 | xdgDir <- Err.catchIOError (E.getEnv "XDG_RUNTIME_DIR") createXdgPath 572 | serverName <- Err.catchIOError (E.getEnv "WAYLAND_DISPLAY") (\_ -> return "wayland-0") 573 | 574 | -- open the connection to the server 575 | 576 | serverSock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol 577 | 578 | PI.setFdOption (PT.Fd $ Socket.fdSocket serverSock) PI.CloseOnExec True 579 | 580 | let serverPath = xdgDir ++ "/" ++ serverName 581 | 582 | putStrLnErr $ "connecting to " ++ serverPath 583 | 584 | Socket.connect serverSock (Socket.SockAddrUnix serverPath) 585 | 586 | -- create stdout/stderr pipe for the child 587 | (ourReadFd, childWriteFd) <- PI.createPipe 588 | PI.setFdOption ourReadFd PI.CloseOnExec True 589 | 590 | -- stdin pipe 591 | (childReadFd, ourWriteFd) <- PI.createPipe 592 | PI.setFdOption ourWriteFd PI.CloseOnExec True 593 | 594 | -- create wayland socket for the child and start a thread for it 595 | 596 | (clientSock, trackerSock) <- Socket.socketPair Socket.AF_UNIX Socket.Stream Socket.defaultProtocol 597 | 598 | PI.setFdOption (PT.Fd $ Socket.fdSocket clientSock) PI.CloseOnExec True 599 | 600 | -- start threads for communication and processing 601 | 602 | pt <- CC.forkIO $ processingThread eventV ts xfs loggerChan logHandle lt 603 | st <- CC.forkIO $ serverThread eventV serverSock clientSock loggerChan 604 | ct <- CC.forkIO $ clientThread eventV clientSock serverSock loggerChan 605 | rt <- CC.forkIO $ passThread ourReadFd PI.stdError 606 | wt <- CC.forkIO $ passThread PI.stdInput ourWriteFd 607 | 608 | -- fork the child 609 | 610 | pid <- Process.forkProcess $ execProcess cmd cmdargs trackerSock childWriteFd childReadFd 611 | 612 | Socket.close trackerSock 613 | 614 | -- process messages until the child dies (closes the socket), server dies or 615 | -- there is a SIGINT 616 | 617 | M.forever $ do 618 | e <- STM.atomically $ STM.takeTMVar eventV 619 | 620 | case e of 621 | SigInt -> do 622 | putStrLnErr "sigINT received" 623 | -- wait until the logger thread finishes 624 | STM.atomically $ STM.writeTChan loggerChan Nothing 625 | SigChld -> do 626 | putStrLnErr "sigCHLD received" 627 | STM.atomically $ STM.writeTChan loggerChan Nothing 628 | ServerClosedSocket -> do 629 | putStrLnErr "server closed socket" 630 | Signals.signalProcess Signals.sigINT pid 631 | STM.atomically $ STM.writeTChan loggerChan Nothing 632 | ClientClosedSocket -> do 633 | putStrLnErr "client closed socket" 634 | STM.atomically $ STM.writeTChan loggerChan Nothing 635 | ProcessingEnded -> do 636 | putStrLnErr "exiting" 637 | 638 | IO.hClose logHandle 639 | CC.killThread pt 640 | CC.killThread st 641 | CC.killThread ct 642 | CC.killThread rt 643 | CC.killThread wt 644 | 645 | Socket.close clientSock 646 | Socket.close serverSock 647 | 648 | -- finally exit when the logger thread is done 649 | Exit.exitSuccess 650 | --------------------------------------------------------------------------------