diff options
Diffstat (limited to 'src/lib/Xmobar/System')
| -rw-r--r-- | src/lib/Xmobar/System/DBus.hs | 73 | ||||
| -rw-r--r-- | src/lib/Xmobar/System/Localize.hsc | 89 | ||||
| -rw-r--r-- | src/lib/Xmobar/System/Signal.hs | 134 | ||||
| -rw-r--r-- | src/lib/Xmobar/System/StatFS.hsc | 83 |
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 + } |