Tray.hs

{-# LANGUAGE OverloadedLabels #-}
module StatusNotifier.Tray where

import           Control.Concurrent.MVar as MV
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.Reader
import           DBus.Client
import qualified DBus.Internal.Types as DBusTypes
import qualified Data.ByteString as BS
import           Data.ByteString.Unsafe
import           Data.Coerce
import           Data.Int
import           Data.List
import qualified Data.Map.Strict as Map
import           Data.Maybe
import           Data.Ord
import qualified Data.Text as T
import           Foreign.Ptr
import qualified GI.DbusmenuGtk3.Objects.Menu as DM
import qualified GI.GLib as GLib
import           GI.GLib.Structs.Bytes
import qualified GI.Gdk as Gdk
import           GI.Gdk.Enums
import           GI.Gdk.Objects.Screen
import           GI.GdkPixbuf.Callbacks
import           GI.GdkPixbuf.Enums
import           GI.GdkPixbuf.Objects.Pixbuf
import           GI.GdkPixbuf.Structs.Pixdata
import qualified GI.Gtk as Gtk
import           GI.Gtk.Flags
import qualified GI.Gtk.Objects.Box as Gtk
import qualified GI.Gtk.Objects.HBox as Gtk
import           GI.Gtk.Objects.IconTheme
import           StatusNotifier.Host.Service
import qualified StatusNotifier.Item.Client as IC
import           StatusNotifier.Util
import           System.Directory
import           System.Log.Logger
import           System.Posix.Process
import           Text.Printf

trayLogger = logM "StatusNotifier.Tray"

themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin]

getThemeWithDefaultFallbacks :: String -> IO IconTheme
getThemeWithDefaultFallbacks themePath = do
  themeForIcon <- iconThemeNew
  defaultTheme <- iconThemeGetDefault

  runMaybeT $ do
    screen <- MaybeT screenGetDefault
    lift $ iconThemeSetScreen themeForIcon screen

  filePaths <- iconThemeGetSearchPath defaultTheme
  iconThemeAppendSearchPath themeForIcon themePath
  mapM_ (iconThemeAppendSearchPath themeForIcon) filePaths

  return themeForIcon

getIconPixbufByName :: IsIconTheme it =>  Int32 -> T.Text -> it -> IO (Maybe Pixbuf)
getIconPixbufByName size name themeForIcon = do
  trayLogger DEBUG "Getting Pixbuf from name"
  let panelName = T.pack $ printf "%s-panel" name
  hasPanelIcon <- iconThemeHasIcon themeForIcon panelName
  hasIcon <- iconThemeHasIcon themeForIcon name
  if hasIcon || hasPanelIcon
  then do
    let targetName = if hasPanelIcon then panelName else name
    iconThemeLoadIcon themeForIcon targetName size themeLoadFlags
  else do
    -- Try to load the icon as a filepath
    let nameString = T.unpack name
    fileExists <- doesFileExist nameString
    if fileExists
    then Just <$> pixbufNewFromFile name
    else return Nothing

getIconPixbufFromByteString :: Int32 -> Int32 -> BS.ByteString -> IO Pixbuf
getIconPixbufFromByteString width height byteString = do
  trayLogger DEBUG "Getting Pixbuf from bytestring"
  bytes <- bytesNew $ Just byteString
  let bytesPerPixel = 4
      rowStride = width * bytesPerPixel
      sampleBits = 8
  pixbufNewFromBytes bytes ColorspaceRgb True sampleBits width height rowStride

data ItemContext = ItemContext
  { contextName :: DBusTypes.BusName
  , contextMenu :: Maybe DM.Menu
  , contextImage :: Gtk.Image
  , contextButton :: Gtk.EventBox
  }

data TrayImageSize = Expand | TrayImageSize Int32

data TrayParams = TrayParams
  { trayHost :: Host
  , trayClient :: Client
  , trayOrientation :: Gtk.Orientation
  , trayImageSize :: TrayImageSize
  , trayIconExpand :: Bool
  }

buildTray :: TrayParams -> IO Gtk.Box
buildTray TrayParams { trayHost = Host
                       { itemInfoMap = getInfoMap
                       , addUpdateHandler = addHandler
                       , removeUpdateHandler = removeHandler
                       }
                     , trayClient = client
                     , trayOrientation = orientation
                     , trayImageSize = imageSize
                     , trayIconExpand = shouldExpand
                     } = do
  trayLogger INFO "Building tray"

  trayBox <- Gtk.boxNew orientation 0
  contextMap <- MV.newMVar Map.empty

  let getContext name = Map.lookup name <$> MV.readMVar contextMap

      getSize rectangle =
        case orientation of
          Gtk.OrientationHorizontal ->
            Gdk.getRectangleHeight rectangle
          Gtk.OrientationVertical ->
            Gdk.getRectangleWidth rectangle

      getInfo def name = fromMaybe def . Map.lookup name <$> getInfoMap

      updateIconFromInfo info@ItemInfo { itemServiceName = name } =
        getContext name >>= updateIcon
        where updateIcon Nothing = updateHandler ItemAdded info
              updateIcon (Just ItemContext { contextImage = image } ) = do
                size <- case imageSize of
                          TrayImageSize size -> return size
                          Expand -> Gtk.widgetGetAllocation image >>= getSize
                getScaledPixBufFromInfo size info >>=
                                  let handlePixbuf mpbuf =
                                        if isJust mpbuf
                                        then Gtk.imageSetFromPixbuf image mpbuf
                                        else updateHandler ItemRemoved info
                                  in handlePixbuf

      updateHandler ItemAdded
                    info@ItemInfo { menuPath = pathForMenu
                                  , itemServiceName = serviceName
                                  , itemServicePath = servicePath
                                  } =
        do
          let serviceNameStr = coerce serviceName
              servicePathStr = coerce servicePath :: String
              serviceMenuPathStr = coerce <$> pathForMenu
              logText = printf "Adding widget for %s - %s."
                        serviceNameStr servicePathStr

          trayLogger INFO logText

          button <- Gtk.eventBoxNew

          image <-
            case imageSize of
              Expand -> do
                traySize <- Gtk.widgetGetAllocation trayBox >>= getSize
                image <- getScaledPixBufFromInfo traySize info >>= Gtk.imageNewFromPixbuf
                let setPixbuf rectangle =
                      do
                        size <- getSize rectangle
                        pixBuf <- getInfo info serviceName >>= getScaledPixBufFromInfo size
                        Gtk.imageSetFromPixbuf image pixBuf
                Gtk.onWidgetSizeAllocate image setPixbuf
                return image
              TrayImageSize size -> do
                pixBuf <- getScaledPixBufFromInfo size info
                image <- Gtk.imageNewFromPixbuf pixBuf
                return image

          Gtk.containerAdd button image

          maybeMenu <- sequenceA $ DM.menuNew (T.pack serviceNameStr) .
                       T.pack <$> serviceMenuPathStr

          let context =
                ItemContext { contextName = serviceName
                            , contextMenu = maybeMenu
                            , contextImage = image
                            , contextButton = button
                            }
              popupItemForMenu menu =
                Gtk.menuPopupAtWidget menu image
                   GravitySouthWest GravityNorthWest Nothing
              popupItemMenu =
                maybe activateItem popupItemForMenu maybeMenu >> return False
              activateItem = void $ IC.activate client serviceName servicePath 0 0

          Gtk.onWidgetButtonPressEvent button $ const popupItemMenu

          MV.modifyMVar_ contextMap $ return . Map.insert serviceName context

          Gtk.widgetShowAll button
          Gtk.boxPackStart trayBox button shouldExpand True 0

      updateHandler ItemRemoved ItemInfo { itemServiceName = name }
        = getContext name >>= removeWidget
        where removeWidget Nothing =
                trayLogger INFO "Attempt to remove widget with unrecognized service name."
              removeWidget (Just ItemContext { contextButton = widgetToRemove }) =
                do
                  Gtk.containerRemove trayBox widgetToRemove
                  MV.modifyMVar_ contextMap $ return . Map.delete name

      updateHandler IconUpdated i = updateIconFromInfo i

      updateHandler IconNameUpdated i = updateIconFromInfo i

      updateHandler _ _ = return ()

      logItemInfo info message =
        trayLogger INFO $ printf "%s - %s pixmap count: %s" message
               (show $ info { iconPixmaps = []})
               (show $ length $ iconPixmaps info)

      getScaledPixBufFromInfo size info = runMaybeT $ do
        pixBuf <- MaybeT $ getPixBufFromInfo size info
        MaybeT $ pixbufScaleSimple pixBuf size size InterpTypeBilinear

      getPixBufFromInfo size
                        info@ItemInfo { iconName = name
                                      , iconThemePath = mpath
                                      , iconPixmaps = pixmaps
                                      } = do
        logItemInfo info "Getting pixbuf"
        themeForIcon <- maybe iconThemeGetDefault getThemeWithDefaultFallbacks mpath
        let tooSmall (w, h, _) = w < size || h < size
            largeEnough = filter (not . tooSmall) pixmaps
            orderer (w1, h1, _) (w2, h2, _) =
              case comparing id w1 w2 of
                EQ -> comparing id h1 h2
                a -> a
            selectedPixmap =
              if null largeEnough
              then maximumBy orderer pixmaps
              else minimumBy orderer largeEnough
            getFromPixmaps (w, h, p) =
              if BS.length p == 0
              then Nothing
              else Just $ getIconPixbufFromByteString w h p
        if null pixmaps
        then getIconPixbufByName size (T.pack name) themeForIcon
        else sequenceA $ getFromPixmaps selectedPixmap

      uiUpdateHandler updateType info =
        void $ Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $
             updateHandler updateType info >> return False

  handlerId <- addHandler uiUpdateHandler
  _ <- Gtk.onWidgetDestroy trayBox $ removeHandler handlerId
  return trayBox