    {-# 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 "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 port :: Int
    port <- ChromeFaviconServerPort
    -> Maybe ChromeFaviconServerPort -> ChromeFaviconServerPort
    forall a. a -> Maybe a -> a
    fromMaybe (Int -> ChromeFaviconServerPort
    ChromeFaviconServerPort 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 (_, chan :: 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 (table :: MVar (Map Int ChromeTabImageData)
    table, _) <- 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 port :: 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 "/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 "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
    > 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
    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
    $ \currentMap :: 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 -> TaffyIO X11WindowToChromeTabId
    forall t. Typeable t => Taffy IO t -> Taffy IO t
    getStateDefault (Taffy IO X11WindowToChromeTabId -> TaffyIO X11WindowToChromeTabId)
    -> Taffy IO 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 (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 "" (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
    $ \currentMap :: 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 _ = () -> 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 "[|]%([0-9]*)%[|]" Bool
    True Bool
    True

    getTabIdFromTitle :: String -> Maybe Int
    getTabIdFromTitle :: String -> Maybe Int
    getTabIdFromTitle title :: 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 theMap :: Map X11Window Int
    theMap (win :: X11Window
    win, title :: 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 tabMap :: 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