gtk-serialized-event-0.11.0: demo/Main.hs

{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
module Main where

import Control.Concurrent
import Control.Monad
import Control.Monad.Trans
import DBus.Bus
import DBus.Client hiding (Signal)
import DBus.MatchRule
import DBus.Message hiding (Signal)
import DBus.Types
import Data.Function
import Data.List (sort)
import Data.Ord
import Data.Text.Lazy hiding (head)
import Data.Word
import Graphics.UI.Gtk hiding (Signal, on)
import Graphics.UI.Gtk.Gdk.DrawWindow
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.UI.Gtk.Gdk.SerializedEvent
import Graphics.UI.Gtk.WebKit.WebView
import System.Directory
import System.Environment
import System.FilePath ((</>))
import System.Process

import qualified Data.Map as Map
import qualified DBus.Message as DM
import qualified Graphics.UI.Gtk as Gtk

main :: IO ()
main = do
  -- Init.
  unsafeInitGUIForThreadedRTS
  
  -- Get program arguments.
  args <- getArgs

  case args of
    -- Entry daemon main.
    [] -> daemonMain
    -- Entry plug main.
    _ -> renderMain

daemonMain :: IO ()
daemonMain = do
  -- Create top-level window.
  window <- windowNew
  windowSetPosition window WinPosCenter
  windowSetDefaultSize window 800 600
  window `onDestroy` mainQuit

  -- Create daemon client.
  client <- mkClient =<< getSessionBus
  requestName client "org.manatee.server" []

  -- Build dbus match rule to listen child process create signal,
  -- then use socketAddId add plug. 
  let matchRule = MatchRule 
                  (Just Signal)
                  Nothing
                  (mkInterfaceName "org.manatee.interface")
                  (mkMemberName "signal1")
                  (mkObjectPath "/server")
                  (mkBusName "org.manatee.server")
                  []
  onSignal client matchRule $ \busName signal -> do
               let plugId = fromVariant $ head $ signalBody signal :: Maybe NativeWindowId
               case plugId of
                 Just pi -> postGUIAsync $ do
                   socket <- socketNew
                   widgetShow socket
                   window `containerAdd` socket
                   socketAddId socket pi
                 Nothing -> return ()

  widgetShowAll window

  -- Send serialized event to child process.
  window `Gtk.on` keyPressEvent $ tryEvent $ do
    sEvent <- serializedEvent
    liftIO $ do
       -- Create signal.
       let signal = DM.Signal 
                     (mkObjectPath_ "/client")
                     (mkMemberName_ "event1")
                     (mkInterfaceName_ "org.manatee.clientinterface")
                     (mkBusName "org.manatee.client")
                     [toVariant sEvent]
       
       -- Send signal.
       emitSignal client signal

  -- Startup child plug process. 
  path <- liftM2 (</>) getCurrentDirectory getProgName -- get program full path
  runCommand $ path ++ " hello"

  mainGUI

renderMain :: IO ()
renderMain = do
  -- Create plug.
  plug <- plugNew Nothing
  plug `onDestroy` mainQuit
  plugId <- plugGetId plug
  
  -- Create browser widget.
  scrolledWindow <- scrolledWindowNew Nothing Nothing
  webView <- webViewNew
  webViewLoadUri webView "http://www.google.com.hk"
  scrolledWindow `containerAdd` webView
  plug `containerAdd` scrolledWindow

  widgetShowAll plug
  
  -- Create render client.
  client <- mkClient =<< getSessionBus
  requestName client "org.manatee.client" []

  -- Build dbus match rule to listen daemon process event.
  let matchRule = MatchRule 
                   (Just Signal)
                   Nothing
                   (mkInterfaceName "org.manatee.clientinterface")
                   (mkMemberName "event1")
                   (mkObjectPath "/client")
                   (mkBusName "org.manatee.client")
                   []
  onSignal client matchRule $ \busName signal -> do
               let sEvent = fromVariant $ head $ signalBody signal :: Maybe SerializedEvent
               case sEvent of
                 Just event -> do
                             putStrLn $ "Receive event from deamon process : " ++ show sEvent
                             drawWindow <- widgetGetDrawWindow webView
                             postGUIAsync $ deserializeEvent event drawWindow (widgetEvent webView) >> return ()
                 Nothing -> return ()
  
  -- Send plug id to deamon process.
  let signal = DM.Signal 
               (mkObjectPath_ "/server")
               (mkMemberName_ "signal1")
               (mkInterfaceName_ "org.manatee.interface")
               (mkBusName "org.manatee.server")
               [toVariant plugId]
  -- Send signal.
  emitSignal client signal
  
  mainGUI

instance Num NativeWindowId where
    (+)         = (+) `on` fromIntegral . fromNativeWindowId
    (*)         = (*) `on` fromIntegral . fromNativeWindowId
    abs         = abs . fromIntegral . fromNativeWindowId
    signum      = signum . fromIntegral . fromNativeWindowId
    fromInteger = toNativeWindowId

instance Ord NativeWindowId where
    compare = comparing (fromIntegral . fromNativeWindowId)

instance Variable NativeWindowId where
  toVariant = toVariant . show . fromNativeWindowId 
  fromVariant x = case fromVariant x of
                    Just v -> Just $ toNativeWindowId $ read v
                    Nothing -> Nothing

instance Variable SerializedEvent where
  toVariant = toVariant . show 
  fromVariant x = case fromVariant x of
                    Just v  -> Just (read v :: SerializedEvent)
                    Nothing -> Nothing