From aa507d0bda3919e1885edb327b855908f2aafcb8 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Wed, 8 Aug 2012 12:12:17 +0200 Subject: BufferedPipeReader: A plugin for temporary data display This plugin allows to display data from multiple pipes. New data will always overwrite the currently displayed data. However, if a timeout is specified, the previous content is restored. Configuration works like this: BufferedPipeReader [ ( Timeout, "/path/to/fifo/pipe" ), (..), .. ] If Timeout is set to 0 then the content is persistent, i.e. it will be reset to any previous value, it will itself become the previous value. If Timeout is set to a negative value the earth will stop spinning, so don't do it. --- src/Plugins/BufferedPipeReader.hs | 78 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 78 insertions(+) create mode 100644 src/Plugins/BufferedPipeReader.hs (limited to 'src/Plugins') diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs new file mode 100644 index 0000000..1fb9dcb --- /dev/null +++ b/src/Plugins/BufferedPipeReader.hs @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.BufferedPipeReader +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading (temporarily) from named pipes with reset +-- +----------------------------------------------------------------------------- + +module Plugins.BufferedPipeReader where + +import Control.Monad(forM_, when) +import Control.Concurrent +import Control.Concurrent.STM +import System.IO +-- import System.IO.Unsafe(unsafePerformIO) + +import Plugins + +data BufferedPipeReader = BufferedPipeReader String [(Int, String)] + deriving (Read, Show) + +-- pipeState :: MVar String +-- pipeState = unsafePerformIO $ newMVar "" + +-- pipe :: (String -> IO ()) -> Handle -> IO () +-- pipe cb h = hGetLineSafe h >>= cb + +instance Exec BufferedPipeReader where + alias ( BufferedPipeReader a _ ) = a + start ( BufferedPipeReader _ ps ) cb = do + + (chan, str, rst) <- initV + forM_ ps $ \p -> forkIO $ reader p chan + writer chan str rst + + where + initV :: IO ( TChan (Int, String), TVar String, TVar Bool ) + initV = atomically $ do + tc <- newTChan + ts <- newTVar "" + tb <- newTVar False + return (tc, ts, tb) + + reader :: (Int, FilePath) -> TChan (Int, String) -> IO () + reader p@(to, fp) tc = do + openFile fp ReadWriteMode >>= hGetLineSafe >>= \dt -> + atomically $ writeTChan tc (to, dt) + reader p tc + + writer :: TChan (Int, String) -> TVar String -> TVar Bool -> IO () + writer tc ts otb = do + (to, dt, ntb) <- update + cb dt + when (to /= 0) $ sfork $ reset to ts ntb + writer tc ts ntb + + where + sfork :: IO () -> IO () + sfork f = forkIO f >> return () + + update :: IO (Int, String, TVar Bool) + update = atomically $ do + (to, dt) <- readTChan tc + when (to == 0) $ writeTVar ts dt + writeTVar otb False + tb <- newTVar True + return (to, dt, tb) + + reset :: Int -> TVar String -> TVar Bool -> IO () + reset to ts tb = do + threadDelay ( to * 100 * 1000 ) + readTVarIO tb >>= flip when ( readTVarIO ts >>= cb ) -- cgit v1.2.3 From 58427c76c892334522dfb28ea2d2a858469fc65a Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Thu, 9 Aug 2012 09:43:49 +0200 Subject: Cosmetic surgery Realign methods, remove unnecessary imports and remove clutter --- src/Commands.hs | 16 ++++++++-------- src/Main.hs | 2 +- src/Plugins/BufferedPipeReader.hs | 6 ------ src/Window.hs | 1 - 4 files changed, 9 insertions(+), 16 deletions(-) (limited to 'src/Plugins') diff --git a/src/Commands.hs b/src/Commands.hs index f31c53c..b501022 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -35,14 +35,14 @@ import Signal import XUtil class Show e => Exec e where - alias :: e -> String - alias e = takeWhile (not . isSpace) $ show e - rate :: e -> Int - rate _ = 10 - run :: e -> IO String - run _ = return "" - start :: e -> (String -> IO ()) -> IO () - start e cb = go + alias :: e -> String + alias e = takeWhile (not . isSpace) $ show e + rate :: e -> Int + rate _ = 10 + run :: e -> IO String + run _ = return "" + start :: e -> (String -> IO ()) -> IO () + start e cb = go where go = run e >>= cb >> tenthSeconds (rate e) >> go trigger :: e -> (Maybe SignalType -> IO ()) -> IO () trigger _ sh = sh Nothing diff --git a/src/Main.hs b/src/Main.hs index c7045b5..5ef5db6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -36,7 +36,7 @@ import System.Environment import System.Posix.Files import Control.Monad (unless) -import Signal (setupSignalHandler, SignalType(..)) +import Signal (setupSignalHandler) -- $main diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs index 1fb9dcb..e232916 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ b/src/Plugins/BufferedPipeReader.hs @@ -18,18 +18,12 @@ import Control.Monad(forM_, when) import Control.Concurrent import Control.Concurrent.STM import System.IO --- import System.IO.Unsafe(unsafePerformIO) import Plugins data BufferedPipeReader = BufferedPipeReader String [(Int, String)] deriving (Read, Show) --- pipeState :: MVar String --- pipeState = unsafePerformIO $ newMVar "" - --- pipe :: (String -> IO ()) -> Handle -> IO () --- pipe cb h = hGetLineSafe h >>= cb instance Exec BufferedPipeReader where alias ( BufferedPipeReader a _ ) = a diff --git a/src/Window.hs b/src/Window.hs index e59c5ff..9024fff 100644 --- a/src/Window.hs +++ b/src/Window.hs @@ -5,7 +5,6 @@ import Graphics.X11.Xlib hiding (textExtents, textWidth) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama -import Control.Monad.Reader import Data.Maybe(fromMaybe) import System.Posix.Process (getProcessID) -- cgit v1.2.3 From dd78c8bfa52ba0b10e6acf8bde8d467fb02a8d4e Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Thu, 9 Aug 2012 10:25:52 +0200 Subject: Implement trigger method for BufferedPipeReader Plugin Using the trigger method activity on a pipe can now cause the window to appear (reveal) and disappear again after a given timeout. The timeout for hiding the window is the same as for restoring the pipes content. The timeout value is given in tenth of seconds. --- src/Plugins/BufferedPipeReader.hs | 36 +++++++++++++++++++++++------------- 1 file changed, 23 insertions(+), 13 deletions(-) (limited to 'src/Plugins') diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs index e232916..602862e 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ b/src/Plugins/BufferedPipeReader.hs @@ -18,39 +18,48 @@ import Control.Monad(forM_, when) import Control.Concurrent import Control.Concurrent.STM import System.IO +import System.IO.Unsafe(unsafePerformIO) import Plugins +import Signal -data BufferedPipeReader = BufferedPipeReader String [(Int, String)] +data BufferedPipeReader = BufferedPipeReader String [(Int, Bool, String)] deriving (Read, Show) +signal :: MVar SignalType +signal = unsafePerformIO newEmptyMVar instance Exec BufferedPipeReader where - alias ( BufferedPipeReader a _ ) = a - start ( BufferedPipeReader _ ps ) cb = do + alias ( BufferedPipeReader a _ ) = a + + trigger br@( BufferedPipeReader _ _ ) sh = + takeMVar signal >>= sh . Just >> trigger br sh + + start ( BufferedPipeReader _ ps ) cb = do (chan, str, rst) <- initV forM_ ps $ \p -> forkIO $ reader p chan writer chan str rst where - initV :: IO ( TChan (Int, String), TVar String, TVar Bool ) + initV :: IO ( TChan (Int, Bool, String), TVar String, TVar Bool ) initV = atomically $ do tc <- newTChan ts <- newTVar "" tb <- newTVar False return (tc, ts, tb) - reader :: (Int, FilePath) -> TChan (Int, String) -> IO () - reader p@(to, fp) tc = do + reader :: (Int, Bool, FilePath) -> TChan (Int, Bool, String) -> IO () + reader p@(to, tg, fp) tc = do openFile fp ReadWriteMode >>= hGetLineSafe >>= \dt -> - atomically $ writeTChan tc (to, dt) + atomically $ writeTChan tc (to, tg, dt) reader p tc - writer :: TChan (Int, String) -> TVar String -> TVar Bool -> IO () + writer :: TChan (Int, Bool, String) -> TVar String -> TVar Bool -> IO () writer tc ts otb = do - (to, dt, ntb) <- update + (to, tg, dt, ntb) <- update cb dt + when tg $ putMVar signal Reveal when (to /= 0) $ sfork $ reset to ts ntb writer tc ts ntb @@ -58,15 +67,16 @@ instance Exec BufferedPipeReader where sfork :: IO () -> IO () sfork f = forkIO f >> return () - update :: IO (Int, String, TVar Bool) + update :: IO (Int, Bool, String, TVar Bool) update = atomically $ do - (to, dt) <- readTChan tc + (to, tg, dt) <- readTChan tc when (to == 0) $ writeTVar ts dt writeTVar otb False tb <- newTVar True - return (to, dt, tb) + return (to, tg, dt, tb) reset :: Int -> TVar String -> TVar Bool -> IO () reset to ts tb = do threadDelay ( to * 100 * 1000 ) - readTVarIO tb >>= flip when ( readTVarIO ts >>= cb ) + readTVarIO tb >>= + flip when ( putMVar signal Hide >> readTVarIO ts >>= cb ) -- cgit v1.2.3 From fc474471e12afd5ec958082a7246f2ee22fcc2cf Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Thu, 9 Aug 2012 11:44:39 +0200 Subject: Bugfix: Replace TVar with TMVar for the old value This solves a problem when there is only one pipe in place. With a default value of "" and only one pipe with a timeout the value is overwritten with "" after the timeout. To prevent this from happening a TMVar is used which will never be filled if there is only one pipe. --- src/Plugins/BufferedPipeReader.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) (limited to 'src/Plugins') diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs index 602862e..8a91967 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ b/src/Plugins/BufferedPipeReader.hs @@ -42,10 +42,10 @@ instance Exec BufferedPipeReader where writer chan str rst where - initV :: IO ( TChan (Int, Bool, String), TVar String, TVar Bool ) + initV :: IO ( TChan (Int, Bool, String), TMVar String, TVar Bool ) initV = atomically $ do tc <- newTChan - ts <- newTVar "" + ts <- newEmptyTMVar tb <- newTVar False return (tc, ts, tb) @@ -55,7 +55,7 @@ instance Exec BufferedPipeReader where atomically $ writeTChan tc (to, tg, dt) reader p tc - writer :: TChan (Int, Bool, String) -> TVar String -> TVar Bool -> IO () + writer :: TChan (Int, Bool, String) -> TMVar String -> TVar Bool -> IO () writer tc ts otb = do (to, tg, dt, ntb) <- update cb dt @@ -70,13 +70,14 @@ instance Exec BufferedPipeReader where update :: IO (Int, Bool, String, TVar Bool) update = atomically $ do (to, tg, dt) <- readTChan tc - when (to == 0) $ writeTVar ts dt + when (to == 0) $ tryPutTMVar ts dt >> return () writeTVar otb False tb <- newTVar True return (to, tg, dt, tb) - reset :: Int -> TVar String -> TVar Bool -> IO () + reset :: Int -> TMVar String -> TVar Bool -> IO () reset to ts tb = do threadDelay ( to * 100 * 1000 ) - readTVarIO tb >>= - flip when ( putMVar signal Hide >> readTVarIO ts >>= cb ) + readTVarIO tb >>= \b -> when b $ do + putMVar signal Hide + atomically (tryTakeTMVar ts) >>= maybe (return ()) cb -- cgit v1.2.3 From 6c456e9e1f881fd70e9c1b357edfc5d63f7a3204 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Thu, 9 Aug 2012 12:07:33 +0200 Subject: Bugfix: Do not hide the window when toggling is off for this pipe The window became hidden although the toggling behaviour was set to False for a particular pipe. This fixes this behaviour and hides the window only if the configuration option is set to True. --- src/Plugins/BufferedPipeReader.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'src/Plugins') diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs index 8a91967..be6a652 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ b/src/Plugins/BufferedPipeReader.hs @@ -60,7 +60,7 @@ instance Exec BufferedPipeReader where (to, tg, dt, ntb) <- update cb dt when tg $ putMVar signal Reveal - when (to /= 0) $ sfork $ reset to ts ntb + when (to /= 0) $ sfork $ reset to tg ts ntb writer tc ts ntb where @@ -75,9 +75,9 @@ instance Exec BufferedPipeReader where tb <- newTVar True return (to, tg, dt, tb) - reset :: Int -> TMVar String -> TVar Bool -> IO () - reset to ts tb = do + reset :: Int -> Bool -> TMVar String -> TVar Bool -> IO () + reset to tg ts tb = do threadDelay ( to * 100 * 1000 ) readTVarIO tb >>= \b -> when b $ do - putMVar signal Hide + when tg $ putMVar signal Hide atomically (tryTakeTMVar ts) >>= maybe (return ()) cb -- cgit v1.2.3 From 1f603c25eea15d302a4aa1ebb879bbd8198a3b82 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 11:37:22 +0200 Subject: Move safeHead to Plugins.Utils safeHead is a very general utility function with suits better into a common Util module. --- src/IPC/DBus.hs | 5 +---- src/Plugins/Utils.hs | 6 +++++- 2 files changed, 6 insertions(+), 5 deletions(-) (limited to 'src/Plugins') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index 64e3cca..4357c48 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -20,10 +20,7 @@ import Control.Monad ((>=>), join, when) import Control.Concurrent import Signal - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x +import Plugins.Utils (safeHead) instance IsVariant SignalType where toVariant = toVariant . show diff --git a/src/Plugins/Utils.hs b/src/Plugins/Utils.hs index 1dbcd40..bbfa84f 100644 --- a/src/Plugins/Utils.hs +++ b/src/Plugins/Utils.hs @@ -15,7 +15,7 @@ ------------------------------------------------------------------------------ -module Plugins.Utils (expandHome, changeLoop) where +module Plugins.Utils (expandHome, changeLoop, safeHead) where import Control.Monad import Control.Concurrent.STM @@ -37,3 +37,7 @@ changeLoop s f = atomically s >>= go new <- s guard (new /= old) return new) + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x -- cgit v1.2.3 From 901bd4c9067b05616392de238d525dd8d4a99f45 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Sat, 11 Aug 2012 21:22:45 +0200 Subject: Fix the MPRIS plugin to work with DBus >= 0.10 This commit updates the mpris plugin to use the DBus 0.10 interface. DBus-Core does no longer exist and is deprecated. DBus 0.10 does not use proxies anymore. The dependency on Data.Text also disappeared. Since I do not have/use mpris I cannot test if this works. It should however, since the functionality was just transformed to use the new interface. --- src/Plugins/Monitors/Mpris.hs | 61 ++++++++++++++++++++++++------------------- xmobar.cabal | 2 +- 2 files changed, 35 insertions(+), 28 deletions(-) (limited to 'src/Plugins') diff --git a/src/Plugins/Monitors/Mpris.hs b/src/Plugins/Monitors/Mpris.hs index 0fa181c..b899a16 100644 --- a/src/Plugins/Monitors/Mpris.hs +++ b/src/Plugins/Monitors/Mpris.hs @@ -21,43 +21,50 @@ module Plugins.Monitors.Mpris ( mprisConfig, runMPRIS1, runMPRIS2 ) where import Plugins.Monitors.Common import Text.Printf (printf) -import qualified DBus.Client.Simple as C -import DBus.Types -import DBus.Connection ( ConnectionError ) + +import DBus +import qualified DBus.Client as DC + import Data.Maybe ( fromJust ) import Data.Int ( Int32, Int64 ) import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Text as T import Control.Exception (try) class MprisVersion a where - getProxy :: a -> C.Client -> String -> IO C.Proxy - getMetadataReply :: a -> C.Client -> String -> IO [Variant] + getMethodCall :: a -> String -> MethodCall + getMetadataReply :: a -> DC.Client -> String -> IO [Variant] + getMetadataReply mv c p = fmap methodReturnBody (DC.call_ c $ getMethodCall mv p) fieldsList :: a -> [String] data MprisVersion1 = MprisVersion1 instance MprisVersion MprisVersion1 where - getProxy MprisVersion1 c p = do - let playerBusName = T.concat ["org.mpris.", T.pack p] - C.proxy c (C.busName_ playerBusName) "/Player" - getMetadataReply MprisVersion1 c p = do - player <- getProxy MprisVersion1 c p - C.call player "org.freedesktop.MediaPlayer" "GetMetadata" [] - fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title", "tracknumber" ] + getMethodCall MprisVersion1 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + } + where + busName = busName_ $ "org.mpris." ++ p + objectPath = objectPath_ $ "/Player" + interfaceName = interfaceName_ $ "org.freedesktop.MediaPlayer" + memberName = memberName_ $ "GetMetadata" + + fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title" + , "tracknumber" ] data MprisVersion2 = MprisVersion2 instance MprisVersion MprisVersion2 where - getProxy MprisVersion2 c p = do - let playerBusName = T.concat ["org.mpris.MediaPlayer2.", T.pack p] - C.proxy c (C.busName_ playerBusName) "/org/mpris/MediaPlayer2" - getMetadataReply MprisVersion2 c p = do - player <- getProxy MprisVersion2 c p - C.call player "org.freedesktop.DBus.Properties" - "Get" - (map (toVariant::String -> Variant) - ["org.mpris.MediaPlayer2.Player", "Metadata"] - ) + getMethodCall MprisVersion2 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + , methodCallBody = arguments + } + where + busName = busName_ $ "org.mpris.MediaPlayer2." ++ p + objectPath = objectPath_ $ "/org/mpris/MediaPlayer2" + interfaceName = interfaceName_ $ "org.freedesktop.DBus.Properties" + memberName = memberName_ $ "Get" + arguments = map (toVariant::String -> Variant) + ["org.mpris.MediaPlayer2.Player", "Metadata"] + fieldsList MprisVersion2 = [ "xesam:album", "xesam:artist", "mpris:artUrl" , "mpris:length", "xesam:title", "xesam:trackNumber" ] @@ -67,8 +74,8 @@ mprisConfig = mkMConfig " - " [ "album", "artist", "arturl", "length" , "title", "tracknumber" ] -dbusClient :: C.Client -dbusClient = unsafePerformIO C.connectSession +dbusClient :: DC.Client +dbusClient = unsafePerformIO DC.connectSession runMPRIS :: (MprisVersion a) => a -> String -> [String] -> Monitor String runMPRIS version playerName _ = do @@ -95,10 +102,10 @@ unpackMetadata xs = ((map (\(k, v) -> (fromVar k, fromVar v))) . unpack . head) TypeStructure _ -> unpack $ head $ structureItems $ fromVar v _ -> [] -getMetadata :: (MprisVersion a) => a -> C.Client -> String -> IO [(String, Variant)] +getMetadata :: (MprisVersion a) => a -> DC.Client -> String -> IO [(String, Variant)] getMetadata version client player = do reply <- try (getMetadataReply version client player) :: - IO (Either ConnectionError [Variant]) + IO (Either DC.ClientError [Variant]) return $ case reply of Right metadata -> unpackMetadata metadata; Left _ -> [] diff --git a/xmobar.cabal b/xmobar.cabal index 8e5b604..54f932e 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -166,7 +166,7 @@ executable xmobar cpp-options: -DDATEZONE if flag(with_mpris) || flag(all_extensions) - build-depends: dbus-core >= 0.9.2.1, text >= 0.11.1.5 && < 0.12 + build-depends: dbus >= 0.10 other-modules: Plugins.Monitors.Mpris cpp-options: -DMPRIS -- cgit v1.2.3