MPRIS2.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.MPRIS2
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This is a "Now Playing" widget that listens for MPRIS2 events on DBus. You
-- can find the MPRIS2 specification here at
-- (<https://specifications.freedesktop.org/mpris-spec/latest/>).
-----------------------------------------------------------------------------
module System.Taffybar.Widget.MPRIS2 where

import           Control.Arrow
import qualified Control.Concurrent.MVar as MV
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Reader
import           DBus
import           DBus.Client
import qualified DBus.TH as DBus
import           Data.Default (Default(..))
import           Data.GI.Base.Overloading (IsDescendantOf)
import           Data.Int
import           Data.List
import qualified Data.Map as M
import qualified Data.Text as T
import qualified GI.GLib as G
import           GI.GdkPixbuf.Objects.Pixbuf as Gdk
import qualified GI.Gtk as Gtk
import           System.Environment.XDG.DesktopEntry
import           System.Log.Logger
import           System.Taffybar.Context
import qualified System.Taffybar.DBus.Client.MPRIS2 as MPRIS2DBus
import           System.Taffybar.Information.MPRIS2
import           System.Taffybar.Util
import           System.Taffybar.Widget.Generic.AutoSizeImage
import           System.Taffybar.Widget.Util
import           System.Taffybar.WindowIcon
import           Text.Printf

mprisLog :: (MonadIO m, Show t) => Priority -> String -> t -> m ()
mprisLog = logPrintF "System.Taffybar.Widget.MPRIS2"

-- | A type representing a function that produces an IO action that adds the
-- provided widget to some container.
type WidgetAdder a m =
  (IsDescendantOf Gtk.Widget a
  , MonadIO m
  , Gtk.GObject a
  ) => a -> m ()

-- | The type of a customization function that is used to update a widget with
-- the provided now playing info. The type a should be the internal state used
-- for the widget (typically just references to the child widgets that may need
-- to be updated ). When the provided value is nothing, it means that the widget
-- does not exist yet and it should be instantiated. When the provided
-- NowPlaying value is Nothing, the dbus client is no longer, and typically the
-- widget should be hidden.
type UpdateMPRIS2PlayerWidget a =
  (forall w. WidgetAdder w IO) -> Maybe a -> Maybe NowPlaying -> TaffyIO a

-- | Configuration for an MPRIS2 Widget
data MPRIS2Config a =
  MPRIS2Config
  {
  -- | A function that will be used to wrap the outer MPRIS2 grid widget
    mprisWidgetWrapper :: Gtk.Widget -> IO Gtk.Widget
  -- | This function will be called to instantiate and update the player widgets
  -- of each dbus player client. See the docstring for `UpdateMPRIS2PlayerWidget`
  -- for more details.
  , updatePlayerWidget :: UpdateMPRIS2PlayerWidget a
  }

defaultMPRIS2Config :: MPRIS2Config MPRIS2PlayerWidget
defaultMPRIS2Config =
  MPRIS2Config
  { mprisWidgetWrapper = return
  , updatePlayerWidget = simplePlayerWidget def
  }

data MPRIS2PlayerWidget = MPRIS2PlayerWidget
  { playerLabel :: Gtk.Label
  , playerWidget :: Gtk.Widget
  }

data SimpleMPRIS2PlayerConfig = SimpleMPRIS2PlayerConfig
  { setNowPlayingLabel :: NowPlaying -> IO T.Text
  , showPlayerWidgetFn :: NowPlaying -> IO Bool
  }

defaultPlayerConfig :: SimpleMPRIS2PlayerConfig
defaultPlayerConfig = SimpleMPRIS2PlayerConfig
  { setNowPlayingLabel = playingText 20 30
  , showPlayerWidgetFn =
    \NowPlaying { npStatus = status } -> return $ status /= "Stopped"
  }

instance Default SimpleMPRIS2PlayerConfig where
  def = defaultPlayerConfig

makeExcept :: String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b
makeExcept errorString actionBuilder =
  ExceptT . fmap (maybeToEither errorString) . actionBuilder

loadIconAtSize ::
  Client -> BusName -> Int32 -> IO Gdk.Pixbuf
loadIconAtSize client busName size =
  let
    failure err =
      mprisLog WARNING "Failed to load default image: %s" err >>
               pixBufFromColor size 0
    loadDefault =
      loadIcon size "play.svg" >>= either failure return
    logErrorAndLoadDefault err =
      mprisLog WARNING "Failed to get MPRIS icon: %s" err >>
      mprisLog WARNING "MPRIS failure for: %s" busName >>
      loadDefault
    chromeSpecialCase l@(Left _) =
      if "chrom" `isInfixOf` formatBusName busName
      then Right "google-chrome" else l
    chromeSpecialCase x = x
  in
    either logErrorAndLoadDefault return =<<
    runExceptT (ExceptT (left show . chromeSpecialCase <$> MPRIS2DBus.getDesktopEntry client busName)
                          >>= makeExcept "Failed to get desktop entry"
                              getDirectoryEntryDefault
                          >>= makeExcept "Failed to get image"
                                (getImageForDesktopEntry size))

-- | This is the default player widget constructor that is used to build mpris
-- widgets. It provides only an icon and NowPlaying text.
simplePlayerWidget ::
  SimpleMPRIS2PlayerConfig -> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget

simplePlayerWidget _ _
                     (Just p@MPRIS2PlayerWidget { playerWidget = widget })
                     Nothing =
                       lift $ Gtk.widgetHide widget >> return p

simplePlayerWidget c addToParent Nothing
                     np@(Just NowPlaying { npBusName = busName }) = do
  ctx <- ask
  client <- asks sessionDBusClient
  lift $ do
    mprisLog DEBUG "Building widget for %s" busName
    image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal
    playerBox <- Gtk.gridNew
    label <- Gtk.labelNew Nothing
    ebox <- Gtk.eventBoxNew
    _ <- Gtk.onWidgetButtonPressEvent ebox $
         const $ MPRIS2DBus.playPause client busName >> return True
    Gtk.containerAdd playerBox image
    Gtk.containerAdd playerBox label
    Gtk.containerAdd ebox playerBox
    vFillCenter playerBox
    addToParent ebox
    Gtk.widgetSetVexpand playerBox True
    Gtk.widgetSetName playerBox $ T.pack $ formatBusName busName
    Gtk.widgetShowAll ebox
    Gtk.widgetHide ebox
    widget <- Gtk.toWidget ebox
    let widgetData =
          MPRIS2PlayerWidget { playerLabel = label, playerWidget = widget }
    flip runReaderT ctx $
         simplePlayerWidget c addToParent (Just widgetData) np

simplePlayerWidget config _
                     (Just w@MPRIS2PlayerWidget
                             { playerLabel = label
                             , playerWidget = widget
                             }) (Just nowPlaying) = lift $ do
  mprisLog DEBUG "Setting state %s" nowPlaying
  Gtk.labelSetMarkup label =<< setNowPlayingLabel config nowPlaying
  shouldShow <- showPlayerWidgetFn config nowPlaying
  if shouldShow
  then Gtk.widgetShowAll widget
  else Gtk.widgetHide widget
  return w

simplePlayerWidget _ _ _ _ =
  mprisLog WARNING "widget update called with no widget or %s"
             ("nowplaying" :: String) >> return undefined

-- | Construct a new MPRIS2 widget using the `simplePlayerWidget` constructor.
mpris2New :: TaffyIO Gtk.Widget
mpris2New = mpris2NewWithConfig defaultMPRIS2Config

-- | Construct a new MPRIS2 widget with the provided configuration.
mpris2NewWithConfig :: MPRIS2Config a -> TaffyIO Gtk.Widget
mpris2NewWithConfig config = ask >>= \ctx -> asks sessionDBusClient >>= \client -> lift $ do
  grid <- Gtk.gridNew
  outerWidget <- Gtk.toWidget grid >>= mprisWidgetWrapper config
  vFillCenter grid
  playerWidgetsVar <- MV.newMVar M.empty
  let
    updateWidget = updatePlayerWidget config
    updatePlayerWidgets nowPlayings playerWidgets = do
      let
        updateWidgetFromNP np@NowPlaying { npBusName = busName } =
          (busName,) <$> updateWidget (Gtk.containerAdd grid)
                       (M.lookup busName playerWidgets) (Just np)
        activeBusNames = map npBusName nowPlayings
        existingBusNames = M.keys playerWidgets
        inactiveBusNames = existingBusNames \\ activeBusNames
        callForNoPlayingAvailable busName =
          updateWidget (Gtk.containerAdd grid)
                         (M.lookup busName playerWidgets) Nothing

      -- Invoke the widgets with no NowPlaying so they can hide etc.
      mapM_ callForNoPlayingAvailable inactiveBusNames
      -- Update all the other widgets
      updatedWidgets <- M.fromList <$> mapM updateWidgetFromNP nowPlayings
      return $ M.union updatedWidgets playerWidgets

    updatePlayerWidgetsVar nowPlayings = postGUISync $
      MV.modifyMVar_ playerWidgetsVar $ flip runReaderT ctx .
        updatePlayerWidgets nowPlayings

    setPlayingClass = do
      anyVisible <- anyM Gtk.widgetIsVisible =<< Gtk.containerGetChildren grid
      if anyVisible
      then do
        addClassIfMissing "visible-children" outerWidget
        removeClassIfPresent "no-visible-children" outerWidget
      else do
        addClassIfMissing "no-visible-children" outerWidget
        removeClassIfPresent "visible-children" outerWidget

    doUpdate = do
      nowPlayings <- getNowPlayingInfo client
      updatePlayerWidgetsVar nowPlayings
      setPlayingClass

    signalCallback _ _ _ _ = doUpdate

    propMatcher = matchAny { matchPath = Just "/org/mpris/MediaPlayer2" }

    handleNameOwnerChanged _ name _ _ = do
      playerWidgets <- MV.readMVar playerWidgetsVar
      busName <- parseBusName name
      when (busName `M.member` playerWidgets) doUpdate

  _ <- Gtk.onWidgetRealize grid $ do
    updateHandler <-
      DBus.registerForPropertiesChanged client propMatcher signalCallback
    nameHandler <-
      DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged
    doUpdate
    void $ Gtk.onWidgetUnrealize grid $
         removeMatch client updateHandler >> removeMatch client nameHandler

  Gtk.widgetShow grid
  setPlayingClass
  return outerWidget

-- | Generate now playing text with the artist truncated to a maximum given by
-- the first provided int, and the song title truncated to a maximum given by
-- the second provided int.
playingText :: MonadIO m => Int -> Int -> NowPlaying -> m T.Text
playingText artistMax songMax NowPlaying {npArtists = artists, npTitle = title} =
  G.markupEscapeText formattedText (-1)
  where truncatedTitle = truncateString songMax title
        formattedText = T.pack $ if null artists
          then truncatedTitle
          else printf
           "%s - %s"
           (truncateString artistMax $ intercalate "," artists)
           truncatedTitle