summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/System
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar/System')
-rw-r--r--src/Xmobar/System/DBus.hs73
-rw-r--r--src/Xmobar/System/Environment.hs49
-rw-r--r--src/Xmobar/System/Kbd.hsc321
-rw-r--r--src/Xmobar/System/Localize.hsc89
-rw-r--r--src/Xmobar/System/Signal.hs134
-rw-r--r--src/Xmobar/System/StatFS.hsc83
6 files changed, 749 insertions, 0 deletions
diff --git a/src/Xmobar/System/DBus.hs b/src/Xmobar/System/DBus.hs
new file mode 100644
index 0000000..103a5a9
--- /dev/null
+++ b/src/Xmobar/System/DBus.hs
@@ -0,0 +1,73 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : DBus
+-- Copyright : (c) Jochen Keil
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- DBus IPC module for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.System.DBus (runIPC) where
+
+import DBus
+import DBus.Client hiding (interfaceName)
+import qualified DBus.Client as DC
+import Data.Maybe (isNothing)
+import Control.Concurrent.STM
+import Control.Exception (handle)
+import System.IO (stderr, hPutStrLn)
+import Control.Monad.IO.Class (liftIO)
+
+import Xmobar.System.Signal
+
+busName :: BusName
+busName = busName_ "org.Xmobar.Control"
+
+objectPath :: ObjectPath
+objectPath = objectPath_ "/org/Xmobar/Control"
+
+interfaceName :: InterfaceName
+interfaceName = interfaceName_ "org.Xmobar.Control"
+
+runIPC :: TMVar SignalType -> IO ()
+runIPC mvst = handle printException exportConnection
+ where
+ printException :: ClientError -> IO ()
+ printException = hPutStrLn stderr . clientErrorMessage
+ exportConnection = do
+ client <- connectSession
+ requestName client busName [ nameDoNotQueue ]
+ export client objectPath defaultInterface
+ { DC.interfaceName = interfaceName
+ , DC.interfaceMethods = [ sendSignalMethod mvst ]
+ }
+
+sendSignalMethod :: TMVar SignalType -> Method
+sendSignalMethod mvst = makeMethod sendSignalName
+ (signature_ [variantType $ toVariant (undefined :: SignalType)])
+ (signature_ [])
+ sendSignalMethodCall
+ where
+ sendSignalName :: MemberName
+ sendSignalName = memberName_ "SendSignal"
+
+ sendSignalMethodCall :: MethodCall -> DBusR Reply
+ sendSignalMethodCall mc = liftIO $
+ if methodCallMember mc == sendSignalName
+ then do
+ let signals :: [Maybe SignalType]
+ signals = map fromVariant (methodCallBody mc)
+ mapM_ sendSignal signals
+ if any isNothing signals
+ then return ( ReplyError errorInvalidParameters [] )
+ else return ( ReplyReturn [] )
+ else
+ return ( ReplyError errorUnknownMethod [] )
+
+ sendSignal :: Maybe SignalType -> IO ()
+ sendSignal = maybe (return ()) (atomically . putTMVar mvst)
diff --git a/src/Xmobar/System/Environment.hs b/src/Xmobar/System/Environment.hs
new file mode 100644
index 0000000..86197db
--- /dev/null
+++ b/src/Xmobar/System/Environment.hs
@@ -0,0 +1,49 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : XMobar.Environment
+-- Copyright : (c) William Song
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Will Song <incertia@incertia.net>
+-- Stability : stable
+-- Portability : portable
+--
+-- A function to expand environment variables in strings
+--
+-----------------------------------------------------------------------------
+module Xmobar.System.Environment(expandEnv) where
+
+import Control.Applicative ((<$>))
+import Data.Maybe (fromMaybe)
+import System.Environment (lookupEnv)
+
+expandEnv :: String -> IO String
+expandEnv "" = return ""
+expandEnv (c:s) = case c of
+ '$' -> do
+ envVar <- fromMaybe "" <$> lookupEnv e
+ remainder <- expandEnv s'
+ return $ envVar ++ remainder
+ where (e, s') = getVar s
+ getVar "" = ("", "")
+ getVar ('{':s'') = (takeUntil "}" s'', drop 1 . dropUntil "}" $ s'')
+ getVar s'' = (takeUntil filterstr s'', dropUntil filterstr s'')
+ filterstr = ",./? \t;:\"'~`!@#$%^&*()<>-+=\\|"
+ takeUntil f = takeWhile (not . flip elem f)
+ dropUntil f = dropWhile (not . flip elem f)
+
+ '\\' -> case s == "" of
+ True -> return "\\"
+ False -> do
+ remainder <- expandEnv $ drop 1 s
+ return $ escString s ++ remainder
+ where escString s' = let (cc:_) = s' in
+ case cc of
+ 't' -> "\t"
+ 'n' -> "\n"
+ '$' -> "$"
+ _ -> [cc]
+
+ _ -> do
+ remainder <- expandEnv s
+ return $ c : remainder
diff --git a/src/Xmobar/System/Kbd.hsc b/src/Xmobar/System/Kbd.hsc
new file mode 100644
index 0000000..b9e1d57
--- /dev/null
+++ b/src/Xmobar/System/Kbd.hsc
@@ -0,0 +1,321 @@
+{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Kbd
+-- Copyright : (c) Martin Perner
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Martin Perner <martin@perner.cc>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A keyboard layout indicator for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.System.Kbd where
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+
+import Graphics.X11.Xlib
+
+#include <X11/XKBlib.h>
+#include <X11/extensions/XKB.h>
+#include <X11/extensions/XKBstr.h>
+
+--
+-- Definition for XkbStaceRec and getKbdLayout taken from
+-- XMonad.Layout.XKBLayout
+--
+data XkbStateRec = XkbStateRec {
+ group :: CUChar,
+ locked_group :: CUChar,
+ base_group :: CUShort,
+ latched_group :: CUShort,
+ mods :: CUChar,
+ base_mods :: CUChar,
+ latched_mods :: CUChar,
+ locked_mods :: CUChar,
+ compat_state :: CUChar,
+ grab_mods :: CUChar,
+ compat_grab_mods :: CUChar,
+ lookup_mods :: CUChar,
+ compat_lookup_mods :: CUChar,
+ ptr_buttons :: CUShort
+}
+
+instance Storable XkbStateRec where
+ sizeOf _ = (#size XkbStateRec)
+ alignment _ = alignment (undefined :: CUShort)
+ poke _ _ = undefined
+ peek ptr = do
+ r_group <- (#peek XkbStateRec, group) ptr
+ r_locked_group <- (#peek XkbStateRec, locked_group) ptr
+ r_base_group <- (#peek XkbStateRec, base_group) ptr
+ r_latched_group <- (#peek XkbStateRec, latched_group) ptr
+ r_mods <- (#peek XkbStateRec, mods) ptr
+ r_base_mods <- (#peek XkbStateRec, base_mods) ptr
+ r_latched_mods <- (#peek XkbStateRec, latched_mods) ptr
+ r_locked_mods <- (#peek XkbStateRec, locked_mods) ptr
+ r_compat_state <- (#peek XkbStateRec, compat_state) ptr
+ r_grab_mods <- (#peek XkbStateRec, grab_mods) ptr
+ r_compat_grab_mods <- (#peek XkbStateRec, compat_grab_mods) ptr
+ r_lookup_mods <- (#peek XkbStateRec, lookup_mods) ptr
+ r_compat_lookup_mods <- (#peek XkbStateRec, compat_lookup_mods) ptr
+ r_ptr_buttons <- (#peek XkbStateRec, ptr_buttons) ptr
+ return XkbStateRec {
+ group = r_group,
+ locked_group = r_locked_group,
+ base_group = r_base_group,
+ latched_group = r_latched_group,
+ mods = r_mods,
+ base_mods = r_base_mods,
+ latched_mods = r_latched_mods,
+ locked_mods = r_locked_mods,
+ compat_state = r_compat_state,
+ grab_mods = r_grab_mods,
+ compat_grab_mods = r_compat_grab_mods,
+ lookup_mods = r_lookup_mods,
+ compat_lookup_mods = r_compat_lookup_mods,
+ ptr_buttons = r_ptr_buttons
+ }
+
+foreign import ccall unsafe "X11/XKBlib.h XkbGetState"
+ xkbGetState :: Display -> CUInt -> Ptr XkbStateRec -> IO CInt
+
+
+getKbdLayout :: Display -> IO Int
+getKbdLayout d = alloca $ \stRecPtr -> do
+ xkbGetState d 0x100 stRecPtr
+ st <- peek stRecPtr
+ return $ fromIntegral (group st)
+
+data XkbKeyNameRec = XkbKeyNameRec {
+ name :: Ptr CChar -- array
+}
+
+--
+-- the t_ before alias is just because of name collisions
+--
+data XkbKeyAliasRec = XkbKeyAliasRec {
+ real :: Ptr CChar, -- array
+ t_alias :: Ptr CChar -- array
+}
+
+--
+-- the t_ before geometry is just because of name collisions
+--
+data XkbNamesRec = XkbNamesRec {
+ keycodes :: Atom,
+ t_geometry :: Atom,
+ symbols :: Atom,
+ types :: Atom,
+ compat :: Atom,
+ vmods :: Ptr Atom,
+ indicators :: Ptr Atom, -- array
+ groups :: Ptr Atom, -- array
+ keys :: Ptr XkbKeyNameRec,
+ key_aliases :: Ptr CChar, -- dont care XkbKeyAliasRec,
+ radio_groups :: Ptr Atom,
+ phys_symbols :: Atom,
+ num_keys :: CUChar,
+ num_key_aliases :: CUChar,
+ num_rg :: CUShort
+}
+
+--
+-- the t_ before map, indicators and compat are just because of name collisions
+--
+data XkbDescRec = XkbDescRec {
+ t_dpy :: Ptr CChar, -- struct _XDisplay* ; don't care
+ flags :: CUShort,
+ device_spec :: CUShort,
+ min_key_code :: KeyCode,
+ max_key_code :: KeyCode,
+ ctrls :: Ptr CChar, -- XkbControlsPtr ; dont' care
+ server :: Ptr CChar, -- XkbServerMapPtr ; dont' care
+ t_map :: Ptr CChar, --XkbClientMapPtr ; dont' care
+ t_indicators :: Ptr CChar, -- XkbIndicatorPtr ; dont' care
+ names :: Ptr XkbNamesRec, -- array
+ t_compat :: Ptr CChar, -- XkbCompatMap ; dont' care
+ geom :: Ptr CChar -- XkbGeometryPtr ; dont' care
+
+}
+
+instance Storable XkbKeyNameRec where
+ sizeOf _ = (#size XkbKeyNameRec)
+ alignment _ = alignment (undefined :: CUShort)
+ poke _ _ = undefined
+ peek ptr = do
+ r_name <- (#peek XkbKeyNameRec, name) ptr
+
+ return XkbKeyNameRec {
+ name = r_name
+ }
+
+instance Storable XkbKeyAliasRec where
+ sizeOf _ = (#size XkbKeyAliasRec)
+ alignment _ = alignment (undefined :: CUShort)
+ poke _ _ = undefined
+ peek ptr = do
+ r_real <- (#peek XkbKeyAliasRec, real) ptr
+ r_alias <- (#peek XkbKeyAliasRec, alias) ptr
+
+ return XkbKeyAliasRec {
+ real = r_real,
+ t_alias = r_alias
+ }
+
+instance Storable XkbNamesRec where
+ sizeOf _ = (#size XkbNamesRec)
+ alignment _ = alignment (undefined :: CUShort)
+ poke _ _ = undefined
+ peek ptr = do
+ r_keycodes <- (#peek XkbNamesRec, keycodes) ptr
+ r_geometry <- (#peek XkbNamesRec, geometry) ptr
+ r_symbols <- (#peek XkbNamesRec, symbols ) ptr
+ r_types <- (#peek XkbNamesRec, types ) ptr
+ r_compat <- (#peek XkbNamesRec, compat ) ptr
+ r_vmods <- (#peek XkbNamesRec, vmods ) ptr
+ r_indicators <- (#peek XkbNamesRec, indicators ) ptr
+ r_groups <- (#peek XkbNamesRec, groups ) ptr
+ r_keys <- (#peek XkbNamesRec, keys ) ptr
+ r_key_aliases <- (#peek XkbNamesRec, key_aliases ) ptr
+ r_radio_groups <- (#peek XkbNamesRec, radio_groups ) ptr
+ r_phys_symbols <- (#peek XkbNamesRec, phys_symbols ) ptr
+ r_num_keys <- (#peek XkbNamesRec,num_keys ) ptr
+ r_num_key_aliases <- (#peek XkbNamesRec, num_key_aliases ) ptr
+ r_num_rg <- (#peek XkbNamesRec, num_rg ) ptr
+
+ return XkbNamesRec {
+ keycodes = r_keycodes,
+ t_geometry = r_geometry,
+ symbols = r_symbols,
+ types = r_types,
+ compat = r_compat,
+ vmods = r_vmods,
+ indicators = r_indicators,
+ groups = r_groups,
+ keys = r_keys,
+ key_aliases = r_key_aliases,
+ radio_groups = r_radio_groups,
+ phys_symbols = r_phys_symbols,
+ num_keys = r_num_keys,
+ num_key_aliases = r_num_key_aliases,
+ num_rg = r_num_rg
+ }
+
+instance Storable XkbDescRec where
+ sizeOf _ = (#size XkbDescRec)
+ alignment _ = alignment (undefined :: CUShort)
+ poke _ _ = undefined
+ peek ptr = do
+ r_dpy <- (#peek XkbDescRec, dpy) ptr
+ r_flags <- (#peek XkbDescRec, flags) ptr
+ r_device_spec <- (#peek XkbDescRec, device_spec) ptr
+ r_min_key_code <- (#peek XkbDescRec, min_key_code) ptr
+ r_max_key_code <- (#peek XkbDescRec, max_key_code) ptr
+ r_ctrls <- (#peek XkbDescRec, ctrls) ptr
+ r_server <- (#peek XkbDescRec, server) ptr
+ r_map <- (#peek XkbDescRec, map) ptr
+ r_indicators <- (#peek XkbDescRec, indicators) ptr
+ r_names <- (#peek XkbDescRec, names) ptr
+ r_compat <- (#peek XkbDescRec, compat) ptr
+ r_geom <- (#peek XkbDescRec, geom) ptr
+
+ return XkbDescRec {
+ t_dpy = r_dpy,
+ flags = r_flags,
+ device_spec = r_device_spec,
+ min_key_code = r_min_key_code,
+ max_key_code = r_max_key_code,
+ ctrls = r_ctrls,
+ server = r_server,
+ t_map = r_map,
+ t_indicators = r_indicators,
+ names = r_names,
+ t_compat = r_compat,
+ geom = r_geom
+ }
+
+--
+-- C bindings
+--
+
+foreign import ccall unsafe "X11/XKBlib.h XkbAllocKeyboard"
+ xkbAllocKeyboard :: IO (Ptr XkbDescRec)
+
+foreign import ccall unsafe "X11/XKBlib.h XkbGetNames"
+ xkbGetNames :: Display -> CUInt -> (Ptr XkbDescRec) -> IO Status
+
+foreign import ccall unsafe "X11/XKBlib.h XGetAtomName"
+ xGetAtomName :: Display -> Atom -> IO CString
+
+foreign import ccall unsafe "X11/XKBlib.h XkbFreeNames"
+ xkbFreeNames :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO ()
+
+foreign import ccall unsafe "X11/XKBlib.h XkbFreeKeyboard"
+ xkbFreeKeyboard :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO ()
+
+foreign import ccall unsafe "X11/XKBlib.h XkbSelectEventDetails"
+ xkbSelectEventDetails :: Display -> CUInt -> CUInt -> CULong -> CULong -> IO CUInt
+
+foreign import ccall unsafe "X11/XKBlib.h XkbSelectEvents"
+ xkbSelectEvents :: Display -> CUInt -> CUInt -> CUInt -> IO CUInt
+
+
+xkbUseCoreKbd :: CUInt
+xkbUseCoreKbd = #const XkbUseCoreKbd
+
+xkbStateNotify :: CUInt
+xkbStateNotify = #const XkbStateNotify
+
+xkbIndicatorStateNotify :: CUInt
+xkbIndicatorStateNotify = #const XkbIndicatorStateNotify
+
+xkbMapNotify :: CUInt
+xkbMapNotify = #const XkbMapNotify
+
+xkbMapNotifyMask :: CUInt
+xkbMapNotifyMask = #const XkbMapNotifyMask
+
+xkbNewKeyboardNotifyMask :: CUInt
+xkbNewKeyboardNotifyMask = #const XkbNewKeyboardNotifyMask
+
+xkbAllStateComponentsMask :: CULong
+xkbAllStateComponentsMask = #const XkbAllStateComponentsMask
+
+xkbGroupStateMask :: CULong
+xkbGroupStateMask = #const XkbGroupStateMask
+
+xkbSymbolsNameMask :: CUInt
+xkbSymbolsNameMask = #const XkbSymbolsNameMask
+
+xkbGroupNamesMask :: CUInt
+xkbGroupNamesMask = #const XkbGroupNamesMask
+
+type KbdOpts = [(String, String)]
+
+getLayoutStr :: Display -> IO String
+getLayoutStr dpy = do
+ kbdDescPtr <- xkbAllocKeyboard
+ status <- xkbGetNames dpy xkbSymbolsNameMask kbdDescPtr
+ str <- getLayoutStr' status dpy kbdDescPtr
+ xkbFreeNames kbdDescPtr xkbGroupNamesMask 1
+ xkbFreeKeyboard kbdDescPtr 0 1
+ return str
+
+getLayoutStr' :: Status -> Display -> (Ptr XkbDescRec) -> IO String
+getLayoutStr' st dpy kbdDescPtr =
+ if st == 0 then -- Success
+ do
+ kbdDesc <- peek kbdDescPtr
+ nameArray <- peek (names kbdDesc)
+ atom <- xGetAtomName dpy (symbols nameArray)
+ str <- peekCString atom
+ return str
+ else -- Behaviour on error
+ do
+ return "Error while requesting layout!"
diff --git a/src/Xmobar/System/Localize.hsc b/src/Xmobar/System/Localize.hsc
new file mode 100644
index 0000000..eec5e3b
--- /dev/null
+++ b/src/Xmobar/System/Localize.hsc
@@ -0,0 +1,89 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Localize
+-- Copyright : (C) 2011, 2018 Martin Perner
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Martin Perner <martin@perner.cc>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- This module provides an interface to locale information e.g. for DateL
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.System.Localize
+ ( setupTimeLocale,
+ getTimeLocale
+ ) where
+
+import Foreign.C
+#if ! MIN_VERSION_time(1,5,0)
+import qualified System.Locale as L
+#else
+import qualified Data.Time.Format as L
+#endif
+
+#ifdef UTF8
+import Codec.Binary.UTF8.String
+#endif
+
+-- get localized strings
+type NlItem = CInt
+
+#include <langinfo.h>
+foreign import ccall unsafe "langinfo.h nl_langinfo"
+ nl_langinfo :: NlItem -> IO CString
+
+#{enum NlItem,
+ , AM_STR , PM_STR \
+ , D_T_FMT , D_FMT , T_FMT , T_FMT_AMPM \
+ , ABDAY_1, ABDAY_7 \
+ , DAY_1, DAY_7 \
+ , ABMON_1, ABMON_12 \
+ , MON_1, MON_12\
+ }
+
+getLangInfo :: NlItem -> IO String
+getLangInfo item = do
+ itemStr <- nl_langinfo item
+#ifdef UTF8
+ str <- peekCString itemStr
+ return $ if isUTF8Encoded str then decodeString str else str
+#else
+ peekCString itemStr
+#endif
+
+#include <locale.h>
+foreign import ccall unsafe "locale.h setlocale"
+ setlocale :: CInt -> CString -> IO CString
+
+setupTimeLocale :: String -> IO ()
+setupTimeLocale l = withCString l (setlocale #const LC_TIME) >> return ()
+
+getTimeLocale :: IO L.TimeLocale
+getTimeLocale = do
+ -- assumes that the defined values are increasing by exactly one.
+ -- as they are defined consecutive in an enum this is reasonable
+ days <- mapM getLangInfo [day1 .. day7]
+ abdays <- mapM getLangInfo [abday1 .. abday7]
+
+ mons <- mapM getLangInfo [mon1 .. mon12]
+ abmons <- mapM getLangInfo [abmon1 .. abmon12]
+
+ amstr <- getLangInfo amStr
+ pmstr <- getLangInfo pmStr
+ dtfmt <- getLangInfo dTFmt
+ dfmt <- getLangInfo dFmt
+ tfmt <- getLangInfo tFmt
+ tfmta <- getLangInfo tFmtAmpm
+
+ let t = L.defaultTimeLocale {L.wDays = zip days abdays
+ ,L.months = zip mons abmons
+ ,L.amPm = (amstr, pmstr)
+ ,L.dateTimeFmt = dtfmt
+ ,L.dateFmt = dfmt
+ ,L.timeFmt = tfmt
+ ,L.time12Fmt = tfmta}
+ return t
diff --git a/src/Xmobar/System/Signal.hs b/src/Xmobar/System/Signal.hs
new file mode 100644
index 0000000..ce39e10
--- /dev/null
+++ b/src/Xmobar/System/Signal.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE DeriveDataTypeable, CPP #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Signal
+-- Copyright : (c) Andrea Rosatto
+-- : (c) Jose A. Ortega Ruiz
+-- : (c) Jochen Keil
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- Signal handling, including DBUS when available
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.System.Signal where
+
+import Data.Foldable (for_)
+import Data.Typeable (Typeable)
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import System.Posix.Signals
+import Graphics.X11.Types (Button)
+import Graphics.X11.Xlib.Types (Position)
+import System.IO
+
+#ifdef DBUS
+import DBus (IsVariant(..))
+import Control.Monad ((>=>))
+#endif
+
+safeHead :: [a] -> Maybe a
+safeHead [] = Nothing
+safeHead (x:_) = Just x
+
+data WakeUp = WakeUp deriving (Show,Typeable)
+instance Exception WakeUp
+
+data SignalType = Wakeup
+ | Reposition
+ | ChangeScreen
+ | Hide Int
+ | Reveal Int
+ | Toggle Int
+ | TogglePersistent
+ | Action Button Position
+ deriving (Read, Show)
+
+#ifdef DBUS
+instance IsVariant SignalType where
+ toVariant = toVariant . show
+ fromVariant = fromVariant >=> parseSignalType
+#endif
+
+parseSignalType :: String -> Maybe SignalType
+parseSignalType = fmap fst . safeHead . reads
+
+-- | Signal handling
+setupSignalHandler :: IO (TMVar SignalType)
+setupSignalHandler = do
+ tid <- newEmptyTMVarIO
+ installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing
+ installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing
+ return tid
+
+updatePosHandler :: TMVar SignalType -> IO ()
+updatePosHandler sig = do
+ atomically $ putTMVar sig Reposition
+ return ()
+
+changeScreenHandler :: TMVar SignalType -> IO ()
+changeScreenHandler sig = do
+ atomically $ putTMVar sig ChangeScreen
+ return ()
+
+
+-- | Ensures that the given IO action runs its cleanup actions ('bracket' etc.),
+-- even if a signal is caught.
+--
+-- An exception will be thrown on the thread that called this function when a
+-- signal is caught.
+withDeferSignals :: IO a -> IO a
+withDeferSignals thing = do
+ threadId <- myThreadId
+ caughtSignal <- newEmptyMVar
+
+ let signals =
+ filter (not . flip inSignalSet reservedSignals)
+ [ sigQUIT
+ , sigTERM
+ --, sigINT -- Handler already installed by GHC
+ --, sigPIPE -- Handler already installed by GHC
+ --, sigUSR1 -- Handled by setupSignalHandler
+ --, sigUSR2 -- Handled by setupSignalHandler
+
+ -- One of the following appears to cause instability, see #360
+ --, sigHUP
+ --, sigILL
+ --, sigABRT
+ --, sigFPE
+ --, sigSEGV
+ --, sigALRM
+ --, sigBUS
+ --, sigPOLL
+ --, sigPROF
+ --, sigSYS
+ --, sigTRAP
+ --, sigVTALRM
+ --, sigXCPU
+ --, sigXFSZ
+ ]
+
+ for_ signals $ \s ->
+
+ installHandler s
+ (Catch $ do
+ tryPutMVar caughtSignal s
+ hPutStrLn stderr ("xmobar: Caught signal "++show s++"; exiting...")
+ throwTo threadId ThreadKilled)
+ Nothing
+
+ thing `finally` do
+ s0 <- tryReadMVar caughtSignal
+ case s0 of
+ Nothing -> pure ()
+ Just s -> do
+ -- Run the default handler for the signal
+ -- hPutStrLn stderr ("xmobar: Running default handler for signal "++show s)
+ installHandler s Default Nothing
+ raiseSignal s
diff --git a/src/Xmobar/System/StatFS.hsc b/src/Xmobar/System/StatFS.hsc
new file mode 100644
index 0000000..529b16a
--- /dev/null
+++ b/src/Xmobar/System/StatFS.hsc
@@ -0,0 +1,83 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : StatFS
+-- Copyright : (c) Jose A Ortega Ruiz
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A binding to C's statvfs(2)
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}
+
+
+module Xmobar.System.StatFS ( FileSystemStats(..), getFileSystemStats ) where
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import Data.ByteString (useAsCString)
+import Data.ByteString.Char8 (pack)
+
+#if defined (__FreeBSD__) || defined (__OpenBSD__) || defined (__APPLE__) || defined (__DragonFly__)
+#define IS_BSD_SYSTEM
+#endif
+
+#ifdef IS_BSD_SYSTEM
+# include <sys/param.h>
+# include <sys/mount.h>
+#else
+# include <sys/vfs.h>
+#endif
+
+data FileSystemStats = FileSystemStats {
+ fsStatBlockSize :: Integer
+ -- ^ Optimal transfer block size.
+ , fsStatBlockCount :: Integer
+ -- ^ Total data blocks in file system.
+ , fsStatByteCount :: Integer
+ -- ^ Total bytes in file system.
+ , fsStatBytesFree :: Integer
+ -- ^ Free bytes in file system.
+ , fsStatBytesAvailable :: Integer
+ -- ^ Free bytes available to non-superusers.
+ , fsStatBytesUsed :: Integer
+ -- ^ Bytes used.
+ } deriving (Show, Eq)
+
+data CStatfs
+
+#ifdef IS_BSD_SYSTEM
+foreign import ccall unsafe "sys/mount.h statfs"
+#else
+foreign import ccall unsafe "sys/vfs.h statvfs"
+#endif
+ c_statfs :: CString -> Ptr CStatfs -> IO CInt
+
+toI :: CULong -> Integer
+toI = toInteger
+
+getFileSystemStats :: String -> IO (Maybe FileSystemStats)
+getFileSystemStats path =
+ allocaBytes (#size struct statfs) $ \vfs ->
+ useAsCString (pack path) $ \cpath -> do
+ res <- c_statfs cpath vfs
+ if res /= 0 then return Nothing
+ else do
+ bsize <- (#peek struct statfs, f_bsize) vfs
+ bcount <- (#peek struct statfs, f_blocks) vfs
+ bfree <- (#peek struct statfs, f_bfree) vfs
+ bavail <- (#peek struct statfs, f_bavail) vfs
+ let bpb = toI bsize
+ return $ Just FileSystemStats
+ { fsStatBlockSize = bpb
+ , fsStatBlockCount = toI bcount
+ , fsStatByteCount = toI bcount * bpb
+ , fsStatBytesFree = toI bfree * bpb
+ , fsStatBytesAvailable = toI bavail * bpb
+ , fsStatBytesUsed = toI (bcount - bfree) * bpb
+ }
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 05:44:43 +0000