{-# 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 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
  getStateDefault (listenForChromeFaviconUpdates port)

getChromeTabImageDataChannel :: TaffyIO (TChan ChromeTabImageData)
getChromeTabImageDataChannel :: TaffyIO (TChan ChromeTabImageData)
getChromeTabImageDataChannel = do
  ChromeTabImageDataState (_, chan) <- TaffyIO ChromeTabImageDataState
getChromeTabImageDataState
  return chan

getChromeTabImageDataTable :: TaffyIO (MVar (M.Map Int ChromeTabImageData))
getChromeTabImageDataTable :: TaffyIO (MVar (Map Int ChromeTabImageData))
getChromeTabImageDataTable = do
  ChromeTabImageDataState (table, _) <- TaffyIO ChromeTabImageDataState
getChromeTabImageDataState
  return table

newtype ChromeFaviconServerPort = ChromeFaviconServerPort Int

listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState
listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState
listenForChromeFaviconUpdates Int
port = do
  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
  inChan <- liftIO newBroadcastTChanIO
  outChan <- liftIO . atomically $ dupTChan inChan
  _ <- lift $ forkIO $ scotty port $
    post "/setTabImageData/:tabID" $ do
      tabID <- queryParam "tabID"
      imageData <- LBS.toStrict <$> body
      when (BS.length imageData > 0) $ lift $ do
        loader <- Gdk.pixbufLoaderNew
        Gdk.pixbufLoaderWriteBytes loader =<< Gdk.bytesNew (Just imageData)
        Gdk.pixbufLoaderClose loader
        let 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
                    return $ M.insert tabID chromeTabImageData currentMap
        Gdk.pixbufLoaderGetPixbuf loader >>= maybe (return ()) updateChannelAndMVar
  return $ ChromeTabImageDataState (infoVar, 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
  startTabMap <- Map X11Window Int -> TaffyIO (Map X11Window Int)
updateTabMap Map X11Window Int
forall k a. Map k a
M.empty
  tabMapVar <- lift $ newMVar startTabMap
  let handleEvent PropertyEvent { ev_window :: Event -> X11Window
ev_window = X11Window
window } =
        do
          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
          lift $ modifyMVar_ tabMapVar $ \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 ()
  _ <- subscribeToPropertyEvents [ewmhWMName] handleEvent
  return 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
    wins <- X11Property [X11Window]
getWindows
    titles <- mapM getWindowTitle wins
    let winsWithTitles = [X11Window] -> [String] -> [(X11Window, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [X11Window]
wins [String]
titles
    return $ foldl addTabIdEntry tabMap winsWithTitles