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/Environment.hs | 49 | ||||
-rw-r--r-- | src/lib/Xmobar/System/Kbd.hsc | 321 | ||||
-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 |
6 files changed, 0 insertions, 749 deletions
diff --git a/src/lib/Xmobar/System/DBus.hs b/src/lib/Xmobar/System/DBus.hs deleted file mode 100644 index 103a5a9..0000000 --- a/src/lib/Xmobar/System/DBus.hs +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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/Environment.hs b/src/lib/Xmobar/System/Environment.hs deleted file mode 100644 index 86197db..0000000 --- a/src/lib/Xmobar/System/Environment.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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/lib/Xmobar/System/Kbd.hsc b/src/lib/Xmobar/System/Kbd.hsc deleted file mode 100644 index b9e1d57..0000000 --- a/src/lib/Xmobar/System/Kbd.hsc +++ /dev/null @@ -1,321 +0,0 @@ -{-# 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/lib/Xmobar/System/Localize.hsc b/src/lib/Xmobar/System/Localize.hsc deleted file mode 100644 index eec5e3b..0000000 --- a/src/lib/Xmobar/System/Localize.hsc +++ /dev/null @@ -1,89 +0,0 @@ -{-# 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 deleted file mode 100644 index ce39e10..0000000 --- a/src/lib/Xmobar/System/Signal.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# 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 deleted file mode 100644 index 529b16a..0000000 --- a/src/lib/Xmobar/System/StatFS.hsc +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - } |