{-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.Information.Chrome where

import           BroadcastChan
import           Control.Concurrent
import           Control.Monad
import           Control.Monad.Trans.Class
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as M
import           Data.Maybe
import qualified GI.GLib as Gdk
import qualified GI.GdkPixbuf as Gdk
import           Prelude
import           System.Log.Logger
import           System.Taffybar.Context hiding (logIO)
import           System.Taffybar.Information.EWMHDesktopInfo
import           System.Taffybar.Information.SafeX11
import           Text.Read hiding (lift)
import           Text.Regex
import           Web.Scotty

logIO :: System.Log.Logger.Priority -> String -> IO ()
logIO :: Priority -> String -> IO ()
logIO = String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Information.Chrome"

data ChromeTabImageData = ChromeTabImageData
  { ChromeTabImageData -> Pixbuf
tabImageData :: Gdk.Pixbuf
  , ChromeTabImageData -> Int
tabImageDataId :: Int
  }

newtype ChromeTabImageDataState =
  ChromeTabImageDataState
  (MVar (M.Map Int ChromeTabImageData), BroadcastChan Out ChromeTabImageData)

getChromeTabImageDataState :: TaffyIO ChromeTabImageDataState
getChromeTabImageDataState :: TaffyIO ChromeTabImageDataState
getChromeTabImageDataState = do
  ChromeFaviconServerPort Int
port <- ChromeFaviconServerPort
-> Maybe ChromeFaviconServerPort -> ChromeFaviconServerPort
forall a. a -> Maybe a -> a
fromMaybe (Int -> ChromeFaviconServerPort
ChromeFaviconServerPort Int
5000) (Maybe ChromeFaviconServerPort -> ChromeFaviconServerPort)
-> ReaderT Context IO (Maybe ChromeFaviconServerPort)
-> ReaderT Context IO ChromeFaviconServerPort
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Context IO (Maybe ChromeFaviconServerPort)
forall t. Typeable t => Taffy IO (Maybe t)
getState
  Taffy IO ChromeTabImageDataState
-> Taffy IO ChromeTabImageDataState
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (Int -> TaffyIO ChromeTabImageDataState
listenForChromeFaviconUpdates Int
port)

getChromeTabImageDataChannel :: TaffyIO (BroadcastChan Out ChromeTabImageData)
getChromeTabImageDataChannel :: TaffyIO (BroadcastChan Out ChromeTabImageData)
getChromeTabImageDataChannel = do
  ChromeTabImageDataState (MVar (Map Int ChromeTabImageData)
_, BroadcastChan Out ChromeTabImageData
chan) <- TaffyIO ChromeTabImageDataState
getChromeTabImageDataState
  BroadcastChan Out ChromeTabImageData
-> TaffyIO (BroadcastChan Out ChromeTabImageData)
forall (m :: * -> *) a. Monad m => a -> m a
return BroadcastChan Out ChromeTabImageData
chan

getChromeTabImageDataTable :: TaffyIO (MVar (M.Map Int ChromeTabImageData))
getChromeTabImageDataTable :: TaffyIO (MVar (Map Int ChromeTabImageData))
getChromeTabImageDataTable = do
  ChromeTabImageDataState (MVar (Map Int ChromeTabImageData)
table, BroadcastChan Out ChromeTabImageData
_) <- TaffyIO ChromeTabImageDataState
getChromeTabImageDataState
  MVar (Map Int ChromeTabImageData)
-> TaffyIO (MVar (Map Int ChromeTabImageData))
forall (m :: * -> *) a. Monad m => a -> m a
return MVar (Map Int ChromeTabImageData)
table

newtype ChromeFaviconServerPort = ChromeFaviconServerPort Int

listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState
listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState
listenForChromeFaviconUpdates Int
port = do
  MVar (Map Int ChromeTabImageData)
infoVar <- IO (MVar (Map Int ChromeTabImageData))
-> TaffyIO (MVar (Map Int ChromeTabImageData))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (MVar (Map Int ChromeTabImageData))
 -> TaffyIO (MVar (Map Int ChromeTabImageData)))
-> IO (MVar (Map Int ChromeTabImageData))
-> TaffyIO (MVar (Map Int ChromeTabImageData))
forall a b. (a -> b) -> a -> b
$ Map Int ChromeTabImageData
-> IO (MVar (Map Int ChromeTabImageData))
forall a. a -> IO (MVar a)
newMVar Map Int ChromeTabImageData
forall k a. Map k a
M.empty
  BroadcastChan In ChromeTabImageData
inChan <- ReaderT Context IO (BroadcastChan In ChromeTabImageData)
forall (m :: * -> *) a. MonadIO m => m (BroadcastChan In a)
newBroadcastChan
  BroadcastChan Out ChromeTabImageData
outChan <- BroadcastChan In ChromeTabImageData
-> TaffyIO (BroadcastChan Out ChromeTabImageData)
forall (m :: * -> *) (dir :: Direction) a.
MonadIO m =>
BroadcastChan dir a -> m (BroadcastChan Out a)
newBChanListener BroadcastChan In ChromeTabImageData
inChan
  ThreadId
_ <- IO ThreadId -> ReaderT Context IO ThreadId
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ThreadId -> ReaderT Context IO ThreadId)
-> IO ThreadId -> ReaderT Context IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> ScottyM () -> IO ()
scotty Int
port (ScottyM () -> IO ()) -> ScottyM () -> IO ()
forall a b. (a -> b) -> a -> b
$
    RoutePattern -> ActionM () -> ScottyM ()
post RoutePattern
"/setTabImageData/:tabID" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
      Int
tabID <- Text -> ActionM Int
forall a. Parsable a => Text -> ActionM a
param Text
"tabID"
      ByteString
imageData <- ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> ActionT Text IO ByteString -> ActionT Text IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT Text IO ByteString
body
      Bool -> ActionM () -> ActionM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
BS.length ByteString
imageData Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ IO () -> ActionM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ do
        PixbufLoader
loader <- IO PixbufLoader
forall (m :: * -> *). (HasCallStack, MonadIO m) => m PixbufLoader
Gdk.pixbufLoaderNew
        PixbufLoader -> Bytes -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbufLoader a) =>
a -> Bytes -> m ()
Gdk.pixbufLoaderWriteBytes PixbufLoader
loader (Bytes -> IO ()) -> IO Bytes -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString -> IO Bytes
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe ByteString -> m Bytes
Gdk.bytesNew (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
imageData)
        PixbufLoader -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbufLoader a) =>
a -> m ()
Gdk.pixbufLoaderClose PixbufLoader
loader
        let updateChannelAndMVar :: Pixbuf -> IO ()
updateChannelAndMVar Pixbuf
pixbuf =
              let chromeTabImageData :: ChromeTabImageData
chromeTabImageData =
                    ChromeTabImageData :: Pixbuf -> Int -> ChromeTabImageData
ChromeTabImageData
                    { tabImageData :: Pixbuf
tabImageData = Pixbuf
pixbuf
                    , tabImageDataId :: Int
tabImageDataId = Int
tabID
                    }
              in
                MVar (Map Int ChromeTabImageData)
-> (Map Int ChromeTabImageData -> IO (Map Int ChromeTabImageData))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map Int ChromeTabImageData)
infoVar ((Map Int ChromeTabImageData -> IO (Map Int ChromeTabImageData))
 -> IO ())
-> (Map Int ChromeTabImageData -> IO (Map Int ChromeTabImageData))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Int ChromeTabImageData
currentMap ->
                  do
                    Bool
_ <- BroadcastChan In ChromeTabImageData
-> ChromeTabImageData -> IO Bool
forall (m :: * -> *) a.
MonadIO m =>
BroadcastChan In a -> a -> m Bool
writeBChan BroadcastChan In ChromeTabImageData
inChan ChromeTabImageData
chromeTabImageData
                    Map Int ChromeTabImageData -> IO (Map Int ChromeTabImageData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Int ChromeTabImageData -> IO (Map Int ChromeTabImageData))
-> Map Int ChromeTabImageData -> IO (Map Int ChromeTabImageData)
forall a b. (a -> b) -> a -> b
$ Int
-> ChromeTabImageData
-> Map Int ChromeTabImageData
-> Map Int ChromeTabImageData
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
tabID ChromeTabImageData
chromeTabImageData Map Int ChromeTabImageData
currentMap
        PixbufLoader -> IO (Maybe Pixbuf)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbufLoader a) =>
a -> m (Maybe Pixbuf)
Gdk.pixbufLoaderGetPixbuf PixbufLoader
loader IO (Maybe Pixbuf) -> (Maybe Pixbuf -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (Pixbuf -> IO ()) -> Maybe Pixbuf -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Pixbuf -> IO ()
updateChannelAndMVar
  ChromeTabImageDataState -> TaffyIO ChromeTabImageDataState
forall (m :: * -> *) a. Monad m => a -> m a
return (ChromeTabImageDataState -> TaffyIO ChromeTabImageDataState)
-> ChromeTabImageDataState -> TaffyIO ChromeTabImageDataState
forall a b. (a -> b) -> a -> b
$ (MVar (Map Int ChromeTabImageData),
 BroadcastChan Out ChromeTabImageData)
-> ChromeTabImageDataState
ChromeTabImageDataState (MVar (Map Int ChromeTabImageData)
infoVar, BroadcastChan Out ChromeTabImageData
outChan)

newtype X11WindowToChromeTabId = X11WindowToChromeTabId (MVar (M.Map X11Window Int))

getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId
getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId
getX11WindowToChromeTabId =
  Taffy IO X11WindowToChromeTabId -> Taffy IO X11WindowToChromeTabId
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (Taffy IO X11WindowToChromeTabId
 -> Taffy IO X11WindowToChromeTabId)
-> Taffy IO X11WindowToChromeTabId
-> Taffy IO X11WindowToChromeTabId
forall a b. (a -> b) -> a -> b
$ MVar (Map X11Window Int) -> X11WindowToChromeTabId
X11WindowToChromeTabId (MVar (Map X11Window Int) -> X11WindowToChromeTabId)
-> ReaderT Context IO (MVar (Map X11Window Int))
-> TaffyIO X11WindowToChromeTabId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Context IO (MVar (Map X11Window Int))
maintainX11WindowToChromeTabId

maintainX11WindowToChromeTabId :: TaffyIO (MVar (M.Map X11Window Int))
maintainX11WindowToChromeTabId :: ReaderT Context IO (MVar (Map X11Window Int))
maintainX11WindowToChromeTabId = do
  Map X11Window Int
startTabMap <- Map X11Window Int -> TaffyIO (Map X11Window Int)
updateTabMap Map X11Window Int
forall k a. Map k a
M.empty
  MVar (Map X11Window Int)
tabMapVar <- IO (MVar (Map X11Window Int))
-> ReaderT Context IO (MVar (Map X11Window Int))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (MVar (Map X11Window Int))
 -> ReaderT Context IO (MVar (Map X11Window Int)))
-> IO (MVar (Map X11Window Int))
-> ReaderT Context IO (MVar (Map X11Window Int))
forall a b. (a -> b) -> a -> b
$ Map X11Window Int -> IO (MVar (Map X11Window Int))
forall a. a -> IO (MVar a)
newMVar Map X11Window Int
startTabMap
  let handleEvent :: Event -> ReaderT Context IO ()
handleEvent PropertyEvent { ev_window :: Event -> X11Window
ev_window = X11Window
window } =
        do
          String
title <- String -> X11Property String -> TaffyIO String
forall a. a -> X11Property a -> TaffyIO a
runX11Def String
"" (X11Property String -> TaffyIO String)
-> X11Property String -> TaffyIO String
forall a b. (a -> b) -> a -> b
$ X11Window -> X11Property String
getWindowTitle X11Window
window
          IO () -> ReaderT Context IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Context IO ()) -> IO () -> ReaderT Context IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Map X11Window Int)
-> (Map X11Window Int -> IO (Map X11Window Int)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map X11Window Int)
tabMapVar ((Map X11Window Int -> IO (Map X11Window Int)) -> IO ())
-> (Map X11Window Int -> IO (Map X11Window Int)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map X11Window Int
currentMap -> do
            let newMap :: Map X11Window Int
newMap = Map X11Window Int -> (X11Window, String) -> Map X11Window Int
addTabIdEntry Map X11Window Int
currentMap (X11Window
window, String
title)
            Priority -> String -> IO ()
logIO Priority
DEBUG (Map X11Window Int -> String
forall a. Show a => a -> String
show Map X11Window Int
newMap)
            Map X11Window Int -> IO (Map X11Window Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Map X11Window Int
newMap
      handleEvent Event
_ = () -> ReaderT Context IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Unique
_ <- [String] -> Listener -> Taffy IO Unique
subscribeToPropertyEvents [String
ewmhWMName] Event -> ReaderT Context IO ()
Listener
handleEvent
  MVar (Map X11Window Int)
-> ReaderT Context IO (MVar (Map X11Window Int))
forall (m :: * -> *) a. Monad m => a -> m a
return MVar (Map X11Window Int)
tabMapVar

tabIDRegex :: Regex
tabIDRegex :: Regex
tabIDRegex = String -> Bool -> Bool -> Regex
mkRegexWithOpts String
"[|]%([0-9]*)%[|]" Bool
True Bool
True

getTabIdFromTitle :: String -> Maybe Int
getTabIdFromTitle :: String -> Maybe Int
getTabIdFromTitle String
title =
  Regex -> String -> Maybe [String]
matchRegex Regex
tabIDRegex String
title Maybe [String] -> ([String] -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe Maybe String -> (String -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe

addTabIdEntry :: M.Map X11Window Int -> (X11Window, String) -> M.Map X11Window Int
addTabIdEntry :: Map X11Window Int -> (X11Window, String) -> Map X11Window Int
addTabIdEntry Map X11Window Int
theMap (X11Window
win, String
title) =
          Map X11Window Int
-> (Int -> Map X11Window Int) -> Maybe Int -> Map X11Window Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map X11Window Int
theMap (((Int -> Map X11Window Int -> Map X11Window Int)
-> Map X11Window Int -> Int -> Map X11Window Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int -> Map X11Window Int -> Map X11Window Int)
 -> Map X11Window Int -> Int -> Map X11Window Int)
-> (Int -> Map X11Window Int -> Map X11Window Int)
-> Map X11Window Int
-> Int
-> Map X11Window Int
forall a b. (a -> b) -> a -> b
$ X11Window -> Int -> Map X11Window Int -> Map X11Window Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert X11Window
win) Map X11Window Int
theMap) (Maybe Int -> Map X11Window Int) -> Maybe Int -> Map X11Window Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
getTabIdFromTitle String
title

updateTabMap :: M.Map X11Window Int -> TaffyIO (M.Map X11Window Int)
updateTabMap :: Map X11Window Int -> TaffyIO (Map X11Window Int)
updateTabMap Map X11Window Int
tabMap =
  Map X11Window Int
-> X11Property (Map X11Window Int) -> TaffyIO (Map X11Window Int)
forall a. a -> X11Property a -> TaffyIO a
runX11Def Map X11Window Int
tabMap (X11Property (Map X11Window Int) -> TaffyIO (Map X11Window Int))
-> X11Property (Map X11Window Int) -> TaffyIO (Map X11Window Int)
forall a b. (a -> b) -> a -> b
$ do
    [X11Window]
wins <- X11Property [X11Window]
getWindows
    [String]
titles <- (X11Window -> X11Property String)
-> [X11Window] -> ReaderT X11Context IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM X11Window -> X11Property String
getWindowTitle [X11Window]
wins
    let winsWithTitles :: [(X11Window, String)]
winsWithTitles = [X11Window] -> [String] -> [(X11Window, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [X11Window]
wins [String]
titles
    Map X11Window Int -> X11Property (Map X11Window Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map X11Window Int -> X11Property (Map X11Window Int))
-> Map X11Window Int -> X11Property (Map X11Window Int)
forall a b. (a -> b) -> a -> b
$ (Map X11Window Int -> (X11Window, String) -> Map X11Window Int)
-> Map X11Window Int -> [(X11Window, String)] -> Map X11Window Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map X11Window Int -> (X11Window, String) -> Map X11Window Int
addTabIdEntry Map X11Window Int
tabMap [(X11Window, String)]
winsWithTitles