Ticket #3918: Main.hs

File Main.hs, 6.9 KB (added by guest, 5 years ago)

Main.hs

Line 
1module Main where
2
3import DBus.Client hiding (Signal)
4import DBus.Types
5import DBus.MatchRule
6import DBus.Bus
7
8import System.Directory
9import System.FilePath
10import System.Posix.Process
11import System.Environment
12
13import Control.Monad
14import Control.Monad.Trans
15import Control.Arrow (first)
16
17import Data.List
18import Data.Text.Lazy hiding (zip, map, head, concatMap, filter)
19import Data.Map (Map)
20
21import Graphics.UI.Gtk hiding (Frame, frameNew, Signal, MessageType, Variant)
22import Graphics.UI.Gtk.General.Structs
23import Graphics.UI.Gtk.Gdk.EventM
24
25import qualified Data.Map as M
26import qualified DBus.NameReservation as DNR
27import qualified DBus.Client as DC
28import qualified DBus.Message as DM
29
30instance Variable NativeWindowId where
31  toVariant = toVariant . show . fromNativeWindowId
32  fromVariant x = case fromVariant x of
33                    Just v -> Just $ toNativeWindowId $ read v
34                    Nothing -> Nothing
35
36socketBusName :: String
37socketBusName = "org.manatee.socketBus"
38
39socketInterfaceName :: String
40socketInterfaceName = "org.manatee.socketInterface"
41
42socketPathName :: String
43socketPathName = "/socket"
44
45socketMemberNameInfix :: String
46socketMemberNameInfix = "memberName"
47
48main :: IO ()
49main = do
50  pId <- getProcessID
51  putStrLn $ "Entry in new process (id): " ++ show pId
52
53  -- Get program arguments.
54  args <- getArgs
55
56  case args of
57    -- Entry plug main when have two arguments.
58    [id] -> plugMain (toNativeWindowId $ read id :: NativeWindowId) -- get GtkSocket id
59    -- Othersise entry socket main when no arguments.
60    _ -> socketMain
61
62socketMain :: IO ()
63socketMain = do
64  -- Init for gtk2hs threadRTS.
65  unsafeInitGUIForThreadedRTS
66
67  -- Create window and notebook.
68  window <- windowNew
69  windowSetDefaultSize window 600 400
70  windowSetPosition window WinPosCenter
71  windowSetTitle window "Please press key `c` (5 or more times) to recur bug!!!"
72  notebook <- notebookNew
73  window `containerAdd` notebook
74
75  -- Create dbus client.
76  client <- mkClient =<< getSessionBus
77  requestName client (mkBusName_ $ pack socketBusName) []
78
79  -- Handle key event.
80  window `on` keyPressEvent $ tryEvent $ do
81               "c" <- eventKeyName
82               liftIO $ postGUIAsync $ newTab client notebook
83
84  window `onDestroy` mainQuit
85  widgetShowAll window
86
87  mainGUI
88
89plugMain :: NativeWindowId -> IO ()
90plugMain id = do
91  -- Init for gtk2hs threadRTS.
92  unsafeInitGUIForThreadedRTS
93
94  -- Create GtkPlug.
95  putStrLn "Debug-> in plug process (after `forkProcess`)."
96
97  plug <- plugNew Nothing
98  plug `onDestroy` mainQuit
99 
100  textView <- textViewNew
101  plug `containerAdd` textView
102
103  widgetShowAll plug
104
105  -- Request a list of connected clients from the bus
106  let socketId = show $ fromNativeWindowId id
107  plugId <- plugGetId plug
108
109  -- Create dbus client.
110  client <- mkClient =<< getSessionBus
111  putStrLn $ "Connected as: " ++ show (clientName client)
112       
113  -- Create signal.
114  let memberName = socketMemberNameInfix ++ socketId
115      signal = mkMessageSignal socketPathName memberName socketInterfaceName socketBusName [toVariant plugId]
116
117  emitSignal client signal
118 
119  mainGUI
120
121newTab :: Client -> Notebook  -> IO ()
122newTab client notebook = do
123    -- Create socket
124    socket <- socketNew
125    widgetShow socket
126    notebookAppendPage notebook socket "Tab" -- add to GtkSocekt notebook
127    id <- socketGetId socket                  -- get GtkSocket id
128    let socketId = show $ fromNativeWindowId id
129
130    -- Export local object.
131    let memberName = socketMemberNameInfix ++ socketId
132    exportLocalObject client socketPathName [(socketInterfaceName, [(memberName, mkSignalMember "s")])]
133
134    -- Receive signal.
135    let matchRule = mkMatchRule (Just Signal) "" socketInterfaceName memberName socketPathName socketBusName []
136    onSignal client matchRule (\_ signal -> 
137                                   postGUIAsync $ do
138                                     -- Pick up plug id.
139                                     let Just pId = fromVariant $ head $ DM.signalBody signal
140                                     -- Output id info.
141                                     putStrLn "Debug-> socket process receive signal from plug process."
142                                     putStrLn $ "Socekt id: " ++ show id
143                                     putStrLn $ "Plug id: " ++ show pId
144                                     putStrLn "---------------"
145                                     -- Add tab plug.
146                                     socketAddId socket pId)
147
148
149    -- Fork process to add GtkPlug into GtkSocekt.
150    path <- liftM2 (</>) getCurrentDirectory getProgName -- get program full path
151
152    putStrLn "***************"
153    putStrLn "Debug-> in socket process (before `forkProcess`): "
154
155    forkProcess (executeFile path False [socketId] Nothing)
156
157    return ()
158
159---------------------------------- DBus Functions ------------------------------
160type ObjectPathString = String
161type MemberNameString = String
162type InterfaceNameString = String
163type BusNameString = String
164
165-- | Handy function for build DBus message signal.
166mkMessageSignal :: ObjectPathString -> MemberNameString -> InterfaceNameString -> BusNameString -> [Variant] -> DM.Signal
167mkMessageSignal oPath mName iName bName body =
168  DM.Signal objectPath memberName interfaceName destination body
169    where objectPath = mkObjectPath_ $ pack oPath
170          memberName = mkMemberName_ $ pack mName
171          interfaceName = mkInterfaceName_ $ pack iName
172          destination = mkBusName $ pack bName
173
174-- | Build LoaclObject with String information, handy!.
175mkLocalObject :: [(InterfaceNameString, [(MemberNameString, Member)])] -> LocalObject
176mkLocalObject list = LocalObject $ M.fromList $ zip interfaceName interface
177    where interfaceNameList = fst $ unzip list                       -- [InterfaceNameString]
178          interfaceList     = snd $ unzip list                       -- [[(MemberNameString, Member)]]
179          interfaceName     = map (mkInterfaceName_ . pack) interfaceNameList -- [interfaceName]
180          interface         = map (\iList -> Interface $ M.fromList $ map (first (mkMemberName_ . pack)) iList) interfaceList -- [Interface]
181
182-- | Export LocalObject.
183exportLocalObject :: Client -> ObjectPathString -> [(InterfaceNameString, [(MemberNameString, Member)])] -> IO ()
184exportLocalObject client path info = export client (mkObjectPath_ $ pack path) (mkLocalObject info)
185
186-- | Build MatchRule.
187mkMatchRule :: Maybe MessageType -> BusNameString -> InterfaceNameString -> MemberNameString -> ObjectPathString -> BusNameString -> [ParameterValue] -> MatchRule 
188mkMatchRule mType sender interface member path dest parameters =
189  MatchRule mType mSender mInterface mMember mPath mDest parameters
190      where mSender = mkBusName $ pack sender
191            mInterface = mkInterfaceName $ pack interface
192            mMember = mkMemberName $ pack member
193            mPath = mkObjectPath $ pack path
194            mDest = mkBusName $ pack dest
195
196-- | Create Signal Memeber.
197mkSignalMember :: String -> Member           
198mkSignalMember signature = DC.Signal $ mkSignature_ $ pack signature