SystrayHelper: initialization

lib/Phi/Bindings/XCB.hsc

@@ -74,7 +74,7 @@ flush (Connection conn) = withForeignPtr conn xcb_flush
 
 type VOID_COOKIE = CUInt
 
-foreign import ccall "xcb/xcb.h xcb_request_check" 
+foreign import ccall unsafe "xcb/xcb.h xcb_request_check" 
   xcb_request_check :: Ptr Connection -> VOID_COOKIE -> IO (Ptr ())
 
 requestCheck :: Ptr Connection -> VOID_COOKIE -> IO ()

lib/Phi/Widgets/X11/Systray.hs

@@ -178,18 +178,6 @@ initSystray disp atoms = do
       return $ Just xembedWin
 
 
-sYSTEM_TRAY_REQUEST_DOCK :: CInt
-sYSTEM_TRAY_REQUEST_DOCK = 0
-
-sYSTEM_TRAY_BEGIN_MESSAGE :: CInt
-sYSTEM_TRAY_BEGIN_MESSAGE = 1
-
-sYSTEM_TRAY_CANCEL_MESSAGE :: CInt
-sYSTEM_TRAY_CANCEL_MESSAGE = 2
-
-xEMBED_EMBEDDED_NOTIFY :: CInt
-xEMBED_EMBEDDED_NOTIFY = 0
-
 handleEvent :: Event -> Phi -> Display -> Window -> Window -> StateT (M.Map Window Window) IO ()
 handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar panelWindow xembedWindow = do
   let atoms = getAtoms dispvar

lib/Phi/X11.hs

@@ -179,7 +179,7 @@ runPhi xconfig config widget = do
     forever $ do
       available <- messageAvailable phi
       repaint <- gets phiRepaint
-      when (not available && repaint) $ liftIO $ threadDelay 30000
+      when (not available && repaint) $ liftIO $ threadDelay 20000
       
       available <- messageAvailable phi
       when (not available && repaint) $ do
@@ -189,6 +189,7 @@ runPhi xconfig config widget = do
       message <- receiveMessage phi
       handleMessage message
       
+      
       case (fromMessage message) of
         Just Shutdown ->
           modify $ \state -> state { phiShutdown = True }

lib/Phi/X11/AtomList.hs

@@ -13,6 +13,7 @@ atoms :: [String]
 atoms = [ "ATOM"
         , "CARDINAL"
         , "STRING"
+        , "VISUALID"
         , "UTF8_STRING"
         , "WM_NAME"
         , "WM_CLASS"

lib/Phi/X11/Util.hs

@@ -6,8 +6,10 @@ module Phi.X11.Util ( getReply'
                     , getProperty16
                     , getProperty32
                     , findVisualtype
+                    , serializeClientMessage
                     ) where
 
+import Control.Exception (assert)
 import Control.Monad
 
 import Data.Int
@@ -15,8 +17,11 @@ import Data.List
 import Data.Maybe
 import Data.Word
 
+import Foreign.C.Types
 import Foreign.Marshal.Array
+import Foreign.Marshal.Utils
 import Foreign.Ptr
+import Foreign.Storable
 
 import Graphics.XHB
 import Graphics.XHB.Gen.Xproto
@@ -50,6 +55,10 @@ castWord8to32 input = unsafePerformIO $
   withArray input $ \ptr ->
     peekArray (length input `div` 4) (castPtr ptr)
 
+castToCChar :: Storable s => s -> [CChar]
+castToCChar input = unsafePerformIO $
+  with input $ \ptr ->
+    peekArray (sizeOf input) (castPtr ptr)
 
 changeProperty8 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO ()
 changeProperty8 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 8 (genericLength propdata) propdata
@@ -86,4 +95,32 @@ getProperty32 conn win prop = getProperty' 32 conn win prop >>= return . fmap ca
 
 
 findVisualtype :: SCREEN -> VISUALID -> Maybe VISUALTYPE
-findVisualtype screen id = listToMaybe . filter ((== id) . visual_id_VISUALTYPE) . join . map visuals_DEPTH . allowed_depths_SCREEN $ screen
+findVisualtype screen id = listToMaybe . filter ((== id) . visual_id_VISUALTYPE) . join . map visuals_DEPTH . allowed_depths_SCREEN $ screen
+
+
+instance Storable ClientMessageData where
+  sizeOf _ = 20
+  alignment _ = 1
+  peek _ = error "ClientMessageData: peek not implemented"
+  poke ptr (ClientData8 d) = assert (length d == 20) $ pokeArray (castPtr ptr) d
+  poke ptr (ClientData16 d) = assert (length d == 10) $ pokeArray (castPtr ptr) d
+  poke ptr (ClientData32 d) = assert (length d == 5) $ pokeArray (castPtr ptr) d
+
+instance Storable ClientMessageEvent where
+  sizeOf _ = 32
+  alignment _ = 1
+  peek _ = error "ClientMessageEvent: peek not implemented"
+  poke ptr ev = do
+    poke' 0 (33 :: Word8) -- ClientMessage == 33                         -- response_type
+    poke' 1 (format_ClientMessageEvent ev)                               -- format
+    poke' 2 (0 :: Word16)                                                -- sequence
+    poke' 4 (fromXid . toXid . window_ClientMessageEvent $ ev :: Word32) -- window
+    poke' 8 (fromXid . toXid . type_ClientMessageEvent $ ev :: Word32)   -- type
+    poke' 12 (data_ClientMessageEvent ev)                                -- data
+    where
+      poke' :: Storable s => Int -> s -> IO ()
+      poke' = poke . plusPtr ptr
+    
+
+serializeClientMessage :: ClientMessageEvent -> [CChar]
+serializeClientMessage = castToCChar

phi.cabal

@@ -10,20 +10,28 @@ author:              Matthias Schiffer
 maintainer:          mschiffer@universe-factory.net
 build-type:          Simple
 
+
 library
   build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb,
                      cairo, pango, unix, data-accessor, arrows, CacheArrow
   exposed-modules:   Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
                      Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.X11.Taskbar
 		     -- , Phi.Widgets.Systray
-  other-modules:     Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB
+  other-modules:     Phi.X11.AtomList, Phi.Bindings.XCB, Phi.X11.Atoms, Phi.X11.Util
   include-dirs:      include
   hs-source-dirs:    lib
-  extra-libraries:   X11
   pkgconfig-depends: xcb, cairo >= 1.2.0, cairo-xcb
   ghc-options:       -fspec-constr-count=16 -threaded
 
+executable PhiSystrayHelper
+  build-depends:     base >= 4, template-haskell, xhb
+  hs-source-dirs:    src, lib
+  main-is:           SystrayHelper.hs
+  other-modules:     Phi.X11.AtomList, Phi.X11.Atoms, Phi.X11.Util
+  ghc-options:       -threaded
+
 executable Phi
   build-depends:     base >= 4, phi
   hs-source-dirs:    src
   main-is:           Phi.hs
+  ghc-options:       -threaded

src/SystrayHelper.hs

@@ -0,0 +1,71 @@
+import Control.Monad
+
+import Data.Maybe
+
+import Graphics.XHB
+import Graphics.XHB.Gen.Xproto
+import qualified Graphics.XHB.Connection.Open as CO
+
+import System.Exit
+
+import Phi.X11.Atoms
+import Phi.X11.Util
+
+
+{-sYSTEM_TRAY_REQUEST_DOCK :: CInt
+sYSTEM_TRAY_REQUEST_DOCK = 0
+
+sYSTEM_TRAY_BEGIN_MESSAGE :: CInt
+sYSTEM_TRAY_BEGIN_MESSAGE = 1
+
+sYSTEM_TRAY_CANCEL_MESSAGE :: CInt
+sYSTEM_TRAY_CANCEL_MESSAGE = 2
+
+xEMBED_EMBEDDED_NOTIFY :: CInt
+xEMBED_EMBEDDED_NOTIFY = 0-}
+
+
+main :: IO ()
+main = do
+  conn <- liftM fromJust connect
+  atoms <- initAtoms conn
+  
+  let dispname = displayInfo conn
+      screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname
+  
+  xembedWindow <- initSystray conn atoms screen
+  
+  return ()
+
+
+initSystray :: Connection -> Atoms -> SCREEN -> IO WINDOW
+initSystray conn atoms screen = do
+  currentSystrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed"
+  when (currentSystrayWin /= fromXid xidNone) $ do
+    putStrLn "PhiSystrayHelper: another systray is running."
+    exitFailure
+  
+  let rootwin = root_SCREEN screen
+      depth = root_depth_SCREEN screen
+      visual = root_visual_SCREEN screen
+  xembedWin <- newResource conn
+  createWindow conn $ MkCreateWindow depth xembedWin rootwin (-1) (-1) 1 1 0 WindowClassInputOutput visual emptyValueParam
+  
+  -- orient horizontally
+  changeProperty32 conn PropModeReplace xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) (atomCARDINAL atoms) [0]
+  
+  -- set visual
+  changeProperty32 conn PropModeReplace xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) (atomVISUALID atoms) [fromIntegral visual]
+  
+  setSelectionOwner conn $ MkSetSelectionOwner xembedWin (atom_NET_SYSTEM_TRAY_SCREEN atoms) 0
+  systrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed"
+  when (systrayWin /= xembedWin) $ do
+    destroyWindow conn xembedWin
+    putStrLn $ "PhiSystrayHelper: can't initialize systray."
+    exitFailure
+  
+  sendEvent conn $ MkSendEvent False rootwin [EventMaskStructureNotify] $
+    serializeClientMessage $ MkClientMessageEvent 32 rootwin (atomMANAGER atoms) $
+    ClientData32 [0, fromXid . toXid $ atom_NET_SYSTEM_TRAY_SCREEN atoms, fromXid . toXid $ xembedWin, 0, 0]
+  
+  return xembedWin