module System.Taffybar.MPRIS2 ( mpris2New ) where
import Data.Maybe ( listToMaybe )
import DBus
import DBus.Client
import Data.List (isPrefixOf)
import Graphics.UI.Gtk hiding ( Signal, Variant )
import Text.Printf
mpris2New :: IO Widget
mpris2New = do
label <- labelNew (Nothing :: Maybe String)
widgetShowAll 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
listen 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 $ widgetShowAll w
"Paused" -> postGUIAsync $ widgetHideAll w
"Stopped" -> postGUIAsync $ widgetHideAll 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 = escapeMarkup $ printf "%s - %s" (cutoff 15 artist) (cutoff 30 title)
txt = "<span fgcolor='yellow'>▶</span> " ++ msg
postGUIAsync $ do
labelSetMarkup w txt
widgetShowAll w
where cutoff 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 $ widgetShowAll w
"Paused" -> postGUIAsync $ widgetHideAll w
"Stopped" -> postGUIAsync $ widgetHideAll w
_ -> return ()
Nothing -> do
return ()
updateSongInfo :: Label -> [(Variant, Variant)] -> IO ()
updateSongInfo w items =
case parseArtistAndTitle of
Just (artist, title) -> setSongInfo w artist title
Nothing -> return ()
where
parseArtistAndTitle = do
aLookup <- lookup (toVariant ("xesam:artist" :: String)) items
tLookup <- lookup (toVariant ("xesam:title" :: String)) items
let artists = (unpack . unpack) aLookup :: [String]
title = (unpack . unpack) tLookup :: String
artist <- listToMaybe artists
return (artist, 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 ()