taffybar 2.1.1 → 2.1.2
raw patch · 9 files changed
+268/−247 lines, 9 files
Files
- src/System/Taffybar/Information/SafeX11.hs +218/−0
- src/System/Taffybar/Information/SafeX11.hsc +0/−218
- src/System/Taffybar/Information/XDG/DesktopEntry.hs +10/−2
- src/System/Taffybar/Information/XDG/Protocol.hs +14/−10
- src/System/Taffybar/Widget.hs +1/−1
- src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs +10/−6
- src/System/Taffybar/WindowIcon.hs +10/−6
- taffybar.cabal +1/−1
- taffybar.hs.example +4/−3
+ src/System/Taffybar/Information/SafeX11.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances,+ InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.SafeX11+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+-----------------------------------------------------------------------------+module System.Taffybar.Information.SafeX11+ ( module Graphics.X11.Xlib+ , module Graphics.X11.Xlib.Extras+ , module System.Taffybar.Information.SafeX11+ )+ where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Either.Combinators+import Data.Typeable+import Foreign hiding (void)+import Foreign.C.Types+import GHC.ForeignPtr+import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras+ hiding (rawGetWindowProperty, getWindowProperty8,+ getWindowProperty16, getWindowProperty32,+ xGetWMHints, getWMHints, refreshKeyboardMapping)+import Prelude+import System.IO+import System.IO.Unsafe+import System.Timeout++foreign import ccall safe "XlibExtras.h XGetWMHints"+ safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)++foreign import ccall interruptible "XlibExtras.h XGetWindowProperty"+ safeXGetWindowProperty ::+ Display ->+ Window ->+ Atom ->+ CLong ->+ CLong ->+ Bool ->+ Atom ->+ Ptr Atom ->+ Ptr CInt ->+ Ptr CULong ->+ Ptr CULong ->+ Ptr (Ptr CUChar) -> IO Status++rawGetWindowPropertyBytes+ :: Storable a+ => Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int))+rawGetWindowPropertyBytes bits d atom w =+ alloca $ \actual_type_return ->+ alloca $ \actual_format_return ->+ alloca $ \nitems_return ->+ alloca $ \bytes_after_return ->+ alloca $ \prop_return -> do+ ret <- postX11RequestSync $+ safeXGetWindowProperty+ d+ w+ atom+ 0+ 0xFFFFFFFF+ False+ anyPropertyType+ actual_type_return+ actual_format_return+ nitems_return+ bytes_after_return+ prop_return+ if fromRight (-1) ret /= 0+ then return Nothing+ else do+ prop_ptr <- peek prop_return+ actual_format <- fromIntegral `fmap` peek actual_format_return+ nitems <- fromIntegral `fmap` peek nitems_return+ getprop prop_ptr nitems actual_format+ where+ getprop prop_ptr nitems actual_format+ | actual_format == 0 = return Nothing -- Property not found+ | actual_format /= bits = xFree prop_ptr >> return Nothing+ | otherwise = do+ ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr)+ return $ Just (ptr, nitems)++data SafeX11Exception = SafeX11Exception deriving (Show, Eq, Typeable)++instance Exception SafeX11Exception++data IORequest = forall a. IORequest+ { ioAction :: IO a+ , ioResponse :: Chan (Either SafeX11Exception a)+ }++{-# NOINLINE requestQueue #-}+requestQueue :: Chan IORequest+requestQueue = unsafePerformIO newChan++{-# NOINLINE x11Thread #-}+x11Thread :: ThreadId+x11Thread = unsafePerformIO $ forkIO startHandlingX11Requests++withErrorHandler :: XErrorHandler -> IO a -> IO a+withErrorHandler new_handler action = do+ handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)+ original <- _xSetErrorHandler handler+ res <- action+ _ <- _xSetErrorHandler original+ return res++deriving instance Show ErrorEvent++startHandlingX11Requests :: IO ()+startHandlingX11Requests =+ withErrorHandler handleError handleX11Requests+ where handleError _ xerrptr = do+ putStrLn "Got error"+ ee <- getErrorEvent xerrptr+ print ee++handleX11Requests :: IO ()+handleX11Requests = do+ IORequest {ioAction = action, ioResponse = responseChannel} <-+ readChan requestQueue+ res <-+ catch+ (maybe (Left SafeX11Exception) Right <$> timeout 500000 action)+ (\e -> do+ putStrLn "Got error on X11 thread"+ hFlush stdout+ print (e :: IOException)+ return $ Left SafeX11Exception)+ writeChan responseChannel res+ handleX11Requests+ return ()++postX11RequestSync :: IO a -> IO (Either SafeX11Exception a)+postX11RequestSync action = do+ let postAndWait = do+ responseChannel <- newChan :: IO (Chan (Either SafeX11Exception a))+ writeChan+ requestQueue+ IORequest {ioAction = action, ioResponse = responseChannel}+ readChan responseChannel+ currentTID <- myThreadId+ if currentTID == x11Thread+ then Right <$> action+ else postAndWait++postX11RequestSyncDef :: a -> IO a -> IO a+postX11RequestSyncDef def action =+ fromRight def <$> postX11RequestSync action++rawGetWindowProperty ::+ Storable a+ => Int -> Display -> Atom -> Window -> IO (Maybe [a])+rawGetWindowProperty bits d atom w =+ runMaybeT $ do+ (ptr, count) <- MaybeT $ rawGetWindowPropertyBytes bits d atom w+ lift $ withForeignPtr ptr $ peekArray count++getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar])+getWindowProperty8 = rawGetWindowProperty 8++getWindowProperty16 :: Display -> Atom -> Window -> IO (Maybe [CShort])+getWindowProperty16 = rawGetWindowProperty 16++getWindowProperty32 :: Display -> Atom -> Window -> IO (Maybe [CLong])+getWindowProperty32 = rawGetWindowProperty 32++getWMHints :: Display -> Window -> IO WMHints+getWMHints dpy w = do+ p <- safeXGetWMHints dpy w+ if p == nullPtr+ then return $ WMHints 0 False 0 0 0 0 0 0 0+ else do x <- peek p; _ <- xFree p; return x++safeGetGeometry :: Display -> Drawable ->+ IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt)+safeGetGeometry display d =+ outParameters7 (throwIfZero "getGeometry") $+ xGetGeometry display d++outParameters7 :: (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) =>+ (IO r -> IO ()) -> (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) ->+ IO (a,b,c,d,e,f,g)+outParameters7 check fn =+ alloca $ \ a_return ->+ alloca $ \ b_return ->+ alloca $ \ c_return ->+ alloca $ \ d_return ->+ alloca $ \ e_return ->+ alloca $ \ f_return ->+ alloca $ \ g_return -> do+ check (fn a_return b_return c_return d_return e_return f_return g_return)+ a <- peek a_return+ b <- peek b_return+ c <- peek c_return+ d <- peek d_return+ e <- peek e_return+ f <- peek f_return+ g <- peek g_return+ return (a,b,c,d,e,f,g)++foreign import ccall safe "HsXlib.h XGetGeometry"+ xGetGeometry :: Display -> Drawable ->+ Ptr Window -> Ptr Position -> Ptr Position -> Ptr Dimension ->+ Ptr Dimension -> Ptr Dimension -> Ptr CInt -> IO Status
− src/System/Taffybar/Information/SafeX11.hsc
@@ -1,218 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances,- InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.Information.SafeX11--- Copyright : (c) Ivan A. Malison--- License : BSD3-style (see LICENSE)------ Maintainer : Ivan A. Malison--- Stability : unstable--- Portability : unportable-------------------------------------------------------------------------------module System.Taffybar.Information.SafeX11- ( module Graphics.X11.Xlib- , module Graphics.X11.Xlib.Extras- , module System.Taffybar.Information.SafeX11- )- where--import Control.Concurrent-import Control.Exception-import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Maybe (MaybeT(..))-import Data.Either.Combinators-import Data.Typeable-import Foreign hiding (void)-import Foreign.C.Types-import GHC.ForeignPtr-import Graphics.X11.Xlib-import Graphics.X11.Xlib.Extras- hiding (rawGetWindowProperty, getWindowProperty8,- getWindowProperty16, getWindowProperty32,- xGetWMHints, getWMHints, refreshKeyboardMapping)-import Prelude-import System.IO-import System.IO.Unsafe-import System.Timeout--foreign import ccall safe "XlibExtras.h XGetWMHints"- safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)--foreign import ccall interruptible "XlibExtras.h XGetWindowProperty"- safeXGetWindowProperty ::- Display ->- Window ->- Atom ->- CLong ->- CLong ->- Bool ->- Atom ->- Ptr Atom ->- Ptr CInt ->- Ptr CULong ->- Ptr CULong ->- Ptr (Ptr CUChar) -> IO Status--rawGetWindowPropertyBytes- :: Storable a- => Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int))-rawGetWindowPropertyBytes bits d atom w =- alloca $ \actual_type_return ->- alloca $ \actual_format_return ->- alloca $ \nitems_return ->- alloca $ \bytes_after_return ->- alloca $ \prop_return -> do- ret <- postX11RequestSync $- safeXGetWindowProperty- d- w- atom- 0- 0xFFFFFFFF- False- anyPropertyType- actual_type_return- actual_format_return- nitems_return- bytes_after_return- prop_return- if fromRight (-1) ret /= 0- then return Nothing- else do- prop_ptr <- peek prop_return- actual_format <- fromIntegral `fmap` peek actual_format_return- nitems <- fromIntegral `fmap` peek nitems_return- getprop prop_ptr nitems actual_format- where- getprop prop_ptr nitems actual_format- | actual_format == 0 = return Nothing -- Property not found- | actual_format /= bits = xFree prop_ptr >> return Nothing- | otherwise = do- ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr)- return $ Just (ptr, nitems)--data SafeX11Exception = SafeX11Exception deriving (Show, Eq, Typeable)--instance Exception SafeX11Exception--data IORequest = forall a. IORequest- { ioAction :: IO a- , ioResponse :: Chan (Either SafeX11Exception a)- }--{-# NOINLINE requestQueue #-}-requestQueue :: Chan IORequest-requestQueue = unsafePerformIO newChan--{-# NOINLINE x11Thread #-}-x11Thread :: ThreadId-x11Thread = unsafePerformIO $ forkIO startHandlingX11Requests--withErrorHandler :: XErrorHandler -> IO a -> IO a-withErrorHandler new_handler action = do- handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)- original <- _xSetErrorHandler handler- res <- action- _ <- _xSetErrorHandler original- return res--deriving instance Show ErrorEvent--startHandlingX11Requests :: IO ()-startHandlingX11Requests =- withErrorHandler handleError handleX11Requests- where handleError _ xerrptr = do- putStrLn "Got error"- ee <- getErrorEvent xerrptr- print ee--handleX11Requests :: IO ()-handleX11Requests = do- IORequest {ioAction = action, ioResponse = responseChannel} <-- readChan requestQueue- res <-- catch- (maybe (Left SafeX11Exception) Right <$> timeout 500000 action)- (\e -> do- putStrLn "Got error on X11 thread"- hFlush stdout- print (e :: IOException)- return $ Left SafeX11Exception)- writeChan responseChannel res- handleX11Requests- return ()--postX11RequestSync :: IO a -> IO (Either SafeX11Exception a)-postX11RequestSync action = do- let postAndWait = do- responseChannel <- newChan :: IO (Chan (Either SafeX11Exception a))- writeChan- requestQueue- IORequest {ioAction = action, ioResponse = responseChannel}- readChan responseChannel- currentTID <- myThreadId- if currentTID == x11Thread- then Right <$> action- else postAndWait--postX11RequestSyncDef :: a -> IO a -> IO a-postX11RequestSyncDef def action =- fromRight def <$> postX11RequestSync action--rawGetWindowProperty ::- Storable a- => Int -> Display -> Atom -> Window -> IO (Maybe [a])-rawGetWindowProperty bits d atom w =- runMaybeT $ do- (ptr, count) <- MaybeT $ rawGetWindowPropertyBytes bits d atom w- lift $ withForeignPtr ptr $ peekArray count--getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar])-getWindowProperty8 = rawGetWindowProperty 8--getWindowProperty16 :: Display -> Atom -> Window -> IO (Maybe [CShort])-getWindowProperty16 = rawGetWindowProperty 16--getWindowProperty32 :: Display -> Atom -> Window -> IO (Maybe [CLong])-getWindowProperty32 = rawGetWindowProperty 32--getWMHints :: Display -> Window -> IO WMHints-getWMHints dpy w = do- p <- safeXGetWMHints dpy w- if p == nullPtr- then return $ WMHints 0 False 0 0 0 0 0 0 0- else do x <- peek p; _ <- xFree p; return x--safeGetGeometry :: Display -> Drawable ->- IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt)-safeGetGeometry display d =- outParameters7 (throwIfZero "getGeometry") $- xGetGeometry display d--outParameters7 :: (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) =>- (IO r -> IO ()) -> (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) ->- IO (a,b,c,d,e,f,g)-outParameters7 check fn =- alloca $ \ a_return ->- alloca $ \ b_return ->- alloca $ \ c_return ->- alloca $ \ d_return ->- alloca $ \ e_return ->- alloca $ \ f_return ->- alloca $ \ g_return -> do- check (fn a_return b_return c_return d_return e_return f_return g_return)- a <- peek a_return- b <- peek b_return- c <- peek c_return- d <- peek d_return- e <- peek e_return- f <- peek f_return- g <- peek g_return- return (a,b,c,d,e,f,g)--foreign import ccall safe "HsXlib.h XGetGeometry"- xGetGeometry :: Display -> Drawable ->- Ptr Window -> Ptr Position -> Ptr Position -> Ptr Dimension ->- Ptr Dimension -> Ptr Dimension -> Ptr CInt -> IO Status
src/System/Taffybar/Information/XDG/DesktopEntry.hs view
@@ -24,6 +24,7 @@ , deNotShowIn , deOnlyShowIn , existingDirs+ , getDefaultConfigHome , getDefaultDataHome , getDirectoryEntriesDefault , getDirectoryEntry@@ -39,7 +40,6 @@ import qualified Data.ConfigFile as CF import Data.List import Data.Maybe-import qualified Data.Set as S import System.Directory import System.Environment import System.FilePath.Posix@@ -53,12 +53,20 @@ existingDirs :: [FilePath] -> IO [FilePath] existingDirs dirs = do exs <- mapM fileExist dirs- return $ S.toList $ S.fromList $ map fst $ filter snd $ zip dirs exs+ let exDirs = nub $ map fst $ filter snd $ zip dirs exs+ mapM_ (putStrLn . ("Directory does not exist: " ++)) $ dirs \\ exDirs+ return exDirs +getDefaultConfigHome :: IO FilePath+getDefaultConfigHome = do+ h <- getHomeDirectory+ return $ h </> ".config"+ getDefaultDataHome :: IO FilePath getDefaultDataHome = do h <- getHomeDirectory return $ h </> ".local" </> "share"+ -- XXX: We really ought to use -- https://hackage.haskell.org/package/directory-1.3.2.2/docs/System-Directory.html#v:getXdgDirectory
src/System/Taffybar/Information/XDG/Protocol.hs view
@@ -46,18 +46,22 @@ -- Environment Variables --- | Produce a list of config locations to search, starting with XDG_CONFIG_HOME--- and XDG_CONFIG_DIRS, with fallback to /etc/xdg+-- | Produce a list of config locations to search, starting with+-- XDG_CONFIG_HOME (or $HOME/.config) and XDG_CONFIG_DIRS, with+-- fallback to /etc/xdg getXDGConfigDirs :: IO [String] getXDGConfigDirs = do- ch <- lookupEnv "XDG_CONFIG_HOME"- cd <- lookupEnv "XDG_CONFIG_DIRS"- let dirs = catMaybes [ch]- ++ maybe [] splitSearchPath cd- exDirs <- existingDirs dirs- return $ if null exDirs- then ["/etc/xdg/"]- else map normalise exDirs+ mXdgConfigHome <- fromMaybe "" <$>+ lookupEnv "XDG_CONFIG_HOME"+ xdgConfigHome <- if null mXdgConfigHome + then getDefaultConfigHome+ else return mXdgConfigHome+ xdgConfigDirs <- maybe [] splitSearchPath <$>+ lookupEnv "XDG_CONFIG_DIRS"+ let xdgDirs = if null xdgConfigDirs+ then ["/etc/xdg/"]+ else xdgConfigDirs+ existingDirs $ map normalise $ xdgConfigHome : xdgDirs getXDGMenuPrefix :: IO (Maybe String) getXDGMenuPrefix = lookupEnv "XDG_MENU_PREFIX"
src/System/Taffybar/Widget.hs view
@@ -36,7 +36,7 @@ , module System.Taffybar.Widget.NetworkGraph -- * "System.Taffybar.Widget.SNITray"- , sniTrayNew+ , module System.Taffybar.Widget.SNITray -- * "System.Taffybar.Widget.SimpleClock" , textClockNew
src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs view
@@ -24,6 +24,7 @@ where import Control.Monad+import Control.Monad.IO.Class import Graphics.UI.Gtk hiding (Menu) import System.Directory import System.FilePath.Posix@@ -41,12 +42,15 @@ -- -- The menu will look for a file named "PREFIX-applications.menu" in -- the (subdirectory "menus" of the) directories specified by the--- environment variable XDG_CONFIG_DIRS and "/etc/xdg". If no prefix--- is given (i.e. if you pass Nothing) then the value of the+-- environment variables XDG_CONFIG_HOME and XDG_CONFIG_DIRS. (If+-- XDG_CONFIG_HOME is not set or empty then $HOME/.config is used, if+-- XDG_CONFIG_DIRS is not set or empty then "/etc/xdg" is used). If+-- no prefix is given (i.e. if you pass Nothing) then the value of the -- environment variable XDG_MENU_PREFIX is used, if it is set. If -- taffybar is running inside a desktop environment like Mate, Gnome, -- XFCE etc. the environment variables XDG_CONFIG_DIRS and--- XDG_MENU_PREFIX should be set and you may create the menu like this:+-- XDG_MENU_PREFIX should be set and you may create the menu like+-- this: -- -- > let menu = menuWidgetNew Nothing --@@ -111,10 +115,10 @@ Nothing -> putStrLn $ "Icon not found: " ++ iconName -- | Create a new XDG Menu Widget.-menuWidgetNew :: Maybe String -- ^ menu name, must end with a dash,+menuWidgetNew :: MonadIO m => Maybe String -- ^ menu name, must end with a dash, -- e.g. "mate-" or "gnome-"- -> IO Widget-menuWidgetNew mMenuPrefix = do+ -> m Widget+menuWidgetNew mMenuPrefix = liftIO $ do mb <- menuBarNew m <- buildMenu mMenuPrefix addMenu mb m
src/System/Taffybar/WindowIcon.hs view
@@ -58,10 +58,12 @@ selectEWMHIcon :: Int32 -> [EWMHIcon] -> Maybe EWMHIcon selectEWMHIcon imgSize icons = listToMaybe prefIcon- where sortedIcons = sortBy (comparing ewmhHeight) icons- smallestLargerIcon = take 1 $ dropWhile ((<= fromIntegral imgSize) . ewmhHeight) sortedIcons- largestIcon = take 1 $ reverse sortedIcons- prefIcon = smallestLargerIcon ++ largestIcon+ where+ sortedIcons = sortBy (comparing ewmhHeight) icons+ smallestLargerIcon =+ take 1 $ dropWhile ((<= fromIntegral imgSize) . ewmhHeight) sortedIcons+ largestIcon = take 1 $ reverse sortedIcons+ prefIcon = smallestLargerIcon ++ largestIcon getPixbufFromEWMHIcons :: Int32 -> [EWMHIcon] -> IO (Maybe Gdk.Pixbuf) getPixbufFromEWMHIcons size = traverse pixBufFromEWMHIcon . selectEWMHIcon size@@ -96,7 +98,8 @@ getDirectoryEntryByClass klass = do entries <- MM.lookup klass <$> getDirectoryEntriesByClassName when (length entries > 1) $- logPrintF "System.Taffybar.WindowIcon" INFO "Multiple entries for: %s" (klass, entries)+ logPrintF "System.Taffybar.WindowIcon" INFO "Multiple entries for: %s"+ (klass, entries) return $ listToMaybe entries getWindowIconForAllClasses@@ -108,7 +111,8 @@ combine soFar theClass = maybeTCombine soFar (doOnClass size theClass) -getWindowIconFromDesktopEntryByClasses :: Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf)+getWindowIconFromDesktopEntryByClasses ::+ Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf) getWindowIconFromDesktopEntryByClasses = getWindowIconForAllClasses getWindowIconFromDesktopEntryByClass where getWindowIconFromDesktopEntryByClass size klass =
taffybar.cabal view
@@ -1,5 +1,5 @@ name: taffybar-version: 2.1.1+version: 2.1.2 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE
taffybar.hs.example view
@@ -1,3 +1,4 @@+-- -*- mode:haskell -*- module Main where import System.Taffybar@@ -64,9 +65,9 @@ clock = textClockNew Nothing "%a %b %_d %r" 1 layout = layoutNew defaultLayoutConfig windows = windowsNew defaultWindowsConfig- -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher- -- for a better way to set up the sni tray- tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt+ -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher+ -- for a better way to set up the sni tray+ tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt myConfig = defaultSimpleTaffyConfig { startWidgets = workspaces : map (>>= buildContentsBox) [ layout, windows ]