summaryrefslogtreecommitdiffhomepage
path: root/src/lib/Xmobar/System
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2018-11-25 03:40:55 +0000
committerjao <jao@gnu.org>2018-11-25 03:40:55 +0000
commit0691071716e6cfa6040044be0ca782771fe6104c (patch)
treea079186bc8e4f44933a9a4c49f11ac30fcd6762b /src/lib/Xmobar/System
parentb909762b396932bf6d768c1f4beae5bbcb50f95a (diff)
downloadxmobar-0691071716e6cfa6040044be0ca782771fe6104c.tar.gz
xmobar-0691071716e6cfa6040044be0ca782771fe6104c.tar.bz2
Refactoring: Xmobar.System
Diffstat (limited to 'src/lib/Xmobar/System')
-rw-r--r--src/lib/Xmobar/System/DBus.hs73
-rw-r--r--src/lib/Xmobar/System/Localize.hsc89
-rw-r--r--src/lib/Xmobar/System/Signal.hs134
-rw-r--r--src/lib/Xmobar/System/StatFS.hsc83
4 files changed, 379 insertions, 0 deletions
diff --git a/src/lib/Xmobar/System/DBus.hs b/src/lib/Xmobar/System/DBus.hs
new file mode 100644
index 0000000..103a5a9
--- /dev/null
+++ b/src/lib/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/lib/Xmobar/System/Localize.hsc b/src/lib/Xmobar/System/Localize.hsc
new file mode 100644
index 0000000..eec5e3b
--- /dev/null
+++ b/src/lib/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/lib/Xmobar/System/Signal.hs b/src/lib/Xmobar/System/Signal.hs
new file mode 100644
index 0000000..ce39e10
--- /dev/null
+++ b/src/lib/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/lib/Xmobar/System/StatFS.hsc b/src/lib/Xmobar/System/StatFS.hsc
new file mode 100644
index 0000000..529b16a
--- /dev/null
+++ b/src/lib/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
+ }