b4e7bc78f9492005431ab092d5c26a28dce30204
[darcs-mirror-arbtt.git] / src / Capture / X11.hs
1 module Capture.X11 where
2
3 import Data
4 import Graphics.X11
5 import Graphics.X11.Xlib.Extras
6 import Control.Monad
7 import Control.Exception (bracket)
8 import System.IO.Error (catchIOError)
9 import Control.Applicative
10 import Data.Maybe
11 import Data.Time.Clock
12 import System.IO
13 import qualified Data.MyText as T
14
15 import System.Locale.SetLocale
16 import Graphics.X11.XScreenSaver (getXIdleTime, compiledWithXScreenSaver)
17
18 setupCapture :: IO ()
19 setupCapture = do
20         unless compiledWithXScreenSaver $
21                 hPutStrLn stderr "arbtt [Warning]: X11 was compiled without support for XScreenSaver"
22         loc <- supportsLocale
23         unless loc $ hPutStrLn stderr "arbtt [Warning]: locale unsupported"
24         dpy <- openDisplay ""
25         xSetErrorHandler
26         let rwin = defaultRootWindow dpy
27         a <- internAtom dpy "_NET_CLIENT_LIST" False
28         p <- getWindowProperty32 dpy a rwin
29         when (isNothing p) $ do
30                 hPutStrLn stderr "arbtt: ERROR: No _NET_CLIENT_LIST set for the root window"
31         closeDisplay dpy
32
33 captureData :: IO CaptureData
34 captureData = do
35         dpy <- openDisplay ""
36         xSetErrorHandler
37         let rwin = defaultRootWindow dpy
38
39         -- Desktops
40         a <- internAtom dpy "_NET_CURRENT_DESKTOP" False
41         p <- getWindowProperty32 dpy a rwin
42         let desk_index = do {[d] <- p; return (fromIntegral d)}
43
44         a <- internAtom dpy "_NET_DESKTOP_NAMES" False
45         tp <- getTextProperty dpy rwin a
46         names <- wcTextPropertyToTextList dpy tp
47
48         let current_desktop = case desk_index of
49               Nothing -> ""
50               Just n -> if 1 <= n && n <= length names
51                         then names !! (n-1)
52                         else show n
53         -- Windows
54         a <- internAtom dpy "_NET_CLIENT_LIST" False
55         p <- getWindowProperty32 dpy a rwin
56
57         wins <- case p of
58                 Just wins -> filterM (isInteresting dpy) (map fromIntegral wins)
59                 Nothing   -> return []
60
61         (fsubwin,_) <- getInputFocus dpy
62         fwin <- followTreeUntil dpy (`elem` wins) fsubwin
63
64         winData <- forM wins $ \w -> (,,)
65             (w == fwin) <$>
66             (T.pack <$> getWindowTitle dpy w) <*>
67             (T.pack <$> getProgramName dpy w)
68
69         it <- fromIntegral `fmap` getXIdleTime dpy
70
71         closeDisplay dpy
72         return $ CaptureData winData it (T.pack current_desktop)
73
74 getWindowTitle :: Display -> Window -> IO String
75 getWindowTitle dpy =  myFetchName dpy
76
77 getProgramName :: Display -> Window -> IO String
78 getProgramName dpy = fmap resName . getClassHint dpy
79
80 -- | Follows the tree of windows up until the condition is met or the root
81 -- window is reached.
82 followTreeUntil :: Display -> (Window -> Bool) -> Window -> IO Window 
83 followTreeUntil dpy cond = go
84   where go w | cond w    = return w
85              | otherwise = do (r,p,_) <- queryTree dpy w
86                               if p == 0 then return w
87                                         else go p 
88
89 -- | Ignore, for example, Desktop and Docks windows
90 isInteresting :: Display -> Window -> IO Bool
91 isInteresting d w = do
92     a <- internAtom d "_NET_WM_WINDOW_TYPE" False
93     dock <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False
94     desk <- internAtom d "_NET_WM_WINDOW_TYPE_DESKTOP" False
95     mbr <- getWindowProperty32 d a w
96     case mbr of
97         Just [r] -> return $ fromIntegral r `notElem` [dock, desk]
98         _        -> return True
99
100 -- | better than fetchName from X11, as it supports _NET_WM_NAME and unicode
101 --
102 -- Code taken from XMonad.Managehook.title
103 myFetchName :: Display -> Window -> IO String
104 myFetchName d w = do
105         let getProp =
106                 (internAtom d "_NET_WM_NAME" False >>= getTextProperty d w)
107                 `catchIOError`
108                 (\_ -> getTextProperty d w wM_NAME)
109
110             extract prop = do l <- wcTextPropertyToTextList d prop
111                               return $ if null l then "" else head l
112
113         bracket getProp (xFree . tp_value) extract
114             `catchIOError` \_ -> return ""
115