{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.Taffybar.MPRIS2 ( mpris2New ) where
import Control.Monad ( void )
import Data.Maybe ( listToMaybe )
import DBus
import DBus.Client hiding (getProperty)
import Data.List (isPrefixOf)
import Graphics.UI.Gtk hiding ( Signal, Variant )
import Text.Printf
mpris2New :: IO Widget
mpris2New = do
label <- labelNew (Nothing :: Maybe String)
widgetHide label
_ <- on label realize $ initLabel label
return (toWidget label)
unpack :: IsVariant a => Variant -> a
unpack var = case fromVariant var of
Just x -> x
Nothing -> error("Could not unpack variant: " ++ show var)
initLabel :: Label -> IO ()
initLabel w = do
client <- connectSession
reqSongInfo w client
void $ addMatch client propMatcher (callBack w)
return ()
where callBack label s = do
let items = dictionaryItems $ unpack (signalBody s !! 1)
updatePlaybackStatus label items
updateMetadata label items
return ()
propMatcher = matchAny { matchSender = Nothing
, matchDestination = Nothing
, matchPath = Just "/org/mpris/MediaPlayer2"
, matchInterface = Just "org.freedesktop.DBus.Properties"
, matchMember = Just "PropertiesChanged"
}
reqSongInfo :: Label -> Client -> IO ()
reqSongInfo w client = do
rep <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames")
{ methodCallDestination = Just "org.freedesktop.DBus" }
let plist = unpack $ methodReturnBody rep !! 0
let players = filter (isPrefixOf "org.mpris.MediaPlayer2.") plist
case length players of
0 -> return ()
_ -> do
reply <- getProperty client (players !! 0) "Metadata"
updateSongInfo w $ dictionaryItems $ (unpack . unpack) (methodReturnBody reply !! 0)
reply' <- getProperty client (players !! 0) "PlaybackStatus"
let status = (unpack . unpack) (methodReturnBody reply' !! 0) :: String
case status of
"Playing" -> postGUIAsync $ widgetShow w
"Paused" -> postGUIAsync $ widgetHide w
"Stopped" -> postGUIAsync $ widgetHide w
_ -> return ()
getProperty :: Client -> String -> String -> IO MethodReturn
getProperty client name property = do
call_ client (methodCall "/org/mpris/MediaPlayer2" "org.freedesktop.DBus.Properties" "Get")
{ methodCallDestination = Just (busName_ name)
, methodCallBody = [ toVariant ("org.mpris.MediaPlayer2.Player" :: String),
toVariant property ]
}
setSongInfo :: Label -> String -> String -> IO ()
setSongInfo w artist title = do
let msg :: String
msg = case artist of
"" -> escapeMarkup $ printf "%s" (truncateString 30 title)
_ -> escapeMarkup $ printf "%s - %s" (truncateString 15 artist) (truncateString 30 title)
txt = "<span fgcolor='yellow'>▶</span> " ++ msg
postGUIAsync $ do
labelSetMarkup w txt
truncateString :: Int -> String -> String
truncateString n xs | length xs <= n = xs
| otherwise = take n xs ++ "…"
updatePlaybackStatus :: Label -> [(Variant, Variant)] -> IO ()
updatePlaybackStatus w items = do
case lookup (toVariant ("PlaybackStatus" :: String)) items of
Just a -> do
case (unpack . unpack) a :: String of
"Playing" -> postGUIAsync $ widgetShow w
"Paused" -> postGUIAsync $ widgetHide w
"Stopped" -> postGUIAsync $ widgetHide w
_ -> return ()
Nothing -> do
return ()
updateSongInfo :: Label -> [(Variant, Variant)] -> IO ()
updateSongInfo w items = do
let artist = case readArtist of
Just x -> x
Nothing -> ""
case readTitle of
Just title -> do
setSongInfo w artist title
Nothing -> return ()
where
readArtist :: Maybe String
readArtist = do
artist <- lookup (toVariant ("xesam:artist" :: String)) items
listToMaybe $ ((unpack . unpack) artist :: [String])
readTitle :: Maybe String
readTitle = do
title <- lookup (toVariant ("xesam:title" :: String)) items
Just $ (unpack . unpack) title
updateMetadata :: Label -> [(Variant, Variant)] -> IO ()
updateMetadata w items = do
case lookup (toVariant ("Metadata" :: String)) items of
Just meta -> do
let metaItems = dictionaryItems $ (unpack . unpack) meta
updateSongInfo w metaItems
Nothing -> return ()