Refactoring: Xmobar.System

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
+                       }