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

import           Control.Concurrent
import           Control.Concurrent.STM.TChan
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.STM (atomically)
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           System.Log.Logger
import           System.Taffybar.Context
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), TChan 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
  TaffyIO ChromeTabImageDataState -> TaffyIO ChromeTabImageDataState
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (Int -> TaffyIO ChromeTabImageDataState
listenForChromeFaviconUpdates Int
port)

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

getChromeTabImageDataTable :: TaffyIO (MVar (M.Map Int ChromeTabImageData))
getChromeTabImageDataTable :: TaffyIO (MVar (Map Int ChromeTabImageData))
getChromeTabImageDataTable = do
  ChromeTabImageDataState (MVar (Map Int ChromeTabImageData)
table, TChan ChromeTabImageData
_) <- TaffyIO ChromeTabImageDataState
getChromeTabImageDataState
  MVar (Map Int ChromeTabImageData)
-> TaffyIO (MVar (Map Int ChromeTabImageData))
forall a. a -> ReaderT Context IO a
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 (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
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
  TChan ChromeTabImageData
inChan <- IO (TChan ChromeTabImageData) -> TaffyIO (TChan ChromeTabImageData)
forall a. IO a -> ReaderT Context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TChan ChromeTabImageData)
forall a. IO (TChan a)
newBroadcastTChanIO
  TChan ChromeTabImageData
outChan <- IO (TChan ChromeTabImageData) -> TaffyIO (TChan ChromeTabImageData)
forall a. IO a -> ReaderT Context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TChan ChromeTabImageData)
 -> TaffyIO (TChan ChromeTabImageData))
-> (STM (TChan ChromeTabImageData)
    -> IO (TChan ChromeTabImageData))
-> STM (TChan ChromeTabImageData)
-> TaffyIO (TChan ChromeTabImageData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (TChan ChromeTabImageData) -> IO (TChan ChromeTabImageData)
forall a. STM a -> IO a
atomically (STM (TChan ChromeTabImageData)
 -> TaffyIO (TChan ChromeTabImageData))
-> STM (TChan ChromeTabImageData)
-> TaffyIO (TChan ChromeTabImageData)
forall a b. (a -> b) -> a -> b
$ TChan ChromeTabImageData -> STM (TChan ChromeTabImageData)
forall a. TChan a -> STM (TChan a)
dupTChan TChan ChromeTabImageData
inChan
  ThreadId
_ <- IO ThreadId -> ReaderT Context IO ThreadId
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
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
queryParam Text
"tabID"
      ByteString
imageData <- ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> ActionT IO ByteString -> ActionT IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionT 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 (m :: * -> *) a. Monad m => m a -> ActionT m a
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
                    { 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
                    ()
_ <- STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan ChromeTabImageData -> ChromeTabImageData -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan ChromeTabImageData
inChan ChromeTabImageData
chromeTabImageData
                    Map Int ChromeTabImageData -> IO (Map Int ChromeTabImageData)
forall a. a -> IO a
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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Pixbuf -> IO ()
updateChannelAndMVar
  ChromeTabImageDataState -> TaffyIO ChromeTabImageDataState
forall a. a -> ReaderT Context IO a
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), TChan ChromeTabImageData)
-> ChromeTabImageDataState
ChromeTabImageDataState (MVar (Map Int ChromeTabImageData)
infoVar, TChan ChromeTabImageData
outChan)

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

getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId
getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId
getX11WindowToChromeTabId =
  TaffyIO X11WindowToChromeTabId -> TaffyIO X11WindowToChromeTabId
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (TaffyIO X11WindowToChromeTabId -> TaffyIO X11WindowToChromeTabId)
-> TaffyIO X11WindowToChromeTabId -> TaffyIO 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 (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
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 (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map X11Window Int
newMap
      handleEvent Event
_ = () -> ReaderT Context IO ()
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Unique
_ <- [String] -> (Event -> ReaderT Context IO ()) -> Taffy IO Unique
subscribeToPropertyEvents [String
ewmhWMName] Event -> ReaderT Context IO ()
handleEvent
  MVar (Map X11Window Int)
-> ReaderT Context IO (MVar (Map X11Window Int))
forall a. a -> ReaderT Context IO a
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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> ReaderT X11Context IO a
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 b a. (b -> a -> b) -> b -> [a] -> b
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