purescript_web_ext/src/Background.purs

module PureTabs.Background where

import Browser.Runtime as Runtime
import Browser.Tabs (Tab, TabId, WindowId, query, removeOne, activateTab)
import Browser.Tabs.OnActivated as TabsOnActivated
import Browser.Tabs.OnCreated as TabsOnCreated
import Browser.Tabs.OnRemoved as TabsOnRemoved
import Browser.Tabs.OnUpdated (ChangeInfo(..))
import Browser.Tabs.OnUpdated as TabsOnUpdated
import Browser.Utils (Listener, mkListenerOne, mkListenerTwo, mkListenerUnit)
import Control.Alt ((<$>))
import Control.Alternative (pure, (*>))
import Control.Bind ((>>=))
import Control.Category (identity, (>>>))
import Data.Array (fromFoldable)
import Data.Foldable (for_)
import Data.Function (flip)
import Data.Lens (_Just, over, preview, set)
import Data.Lens.At (at)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List, foldr, foldMap)
import Data.Map (empty, lookup, values)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid ((<>))
import Data.Newtype (unwrap)
import Data.Show (show)
import Data.Unit (unit)
import Debug.Trace (traceM)
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Effect.Console (log)
import Effect.Ref as Ref
import Prelude (Unit, bind, ($), discard, (<<<))
import PureTabs.Model (BackgroundEvent(..), GlobalState, SidebarEvent(..), _active, _port, _portFromWindow, _portFromWindowId, _tabFromTabIdAndWindow, _tabFromWindow, _windows, tabsToGlobalState)

type Ports
  = Ref.Ref (List Runtime.Port)

main :: Effect Unit
main = do
  log "starting background"
  launchAff_ runMain
  where
  runMain :: Aff Unit
  runMain = do
    allTabs <- query
    liftEffect
      $ do
          state <- Ref.new $ tabsToGlobalState allTabs
          initializeBackground state
          log "all listener initialized"

initializeBackground :: Ref.Ref GlobalState -> Effect Unit
initializeBackground ref = do
  TabsOnCreated.addListener $ onTabCreated ref
  (mkListenerTwo $ onTabDeleted ref) >>= TabsOnRemoved.addListener 
  TabsOnActivated.addListener $ onTabActived ref
  TabsOnUpdated.addListener $ onTabUpdated ref
  (mkListenerOne $ onConnect ref) >>= Runtime.onConnectAddListener

onTabCreated :: (Ref.Ref GlobalState) -> Tab -> Effect Unit
onTabCreated stateRef tab' = do
  state <- Ref.modify (set (_tabFromWindow tab') (Just tab')) stateRef
  log $ "tabId: " <> (show tab.id) <> " windowId " <> show tab.windowId
  case (preview (_portFromWindow tab') state) of
    Nothing -> pure unit
    Just port -> do
      _ <- Runtime.postMessageJson port $ BgTabCreated tab'
      log $ "tab " <> (show tab.id) <> " created: " <> tab.title
  where
  tab = unwrap tab'

onTabUpdated :: (Ref.Ref GlobalState) -> TabId -> ChangeInfo -> Tab -> Effect Unit
onTabUpdated stateRef tid cinfo tab' = do
  state <- Ref.modify (set (_tabFromWindow tab') (Just tab')) stateRef
  case (preview (_portFromWindow tab') state) of
    Nothing -> pure unit
    Just port -> Runtime.postMessageJson port $ BgTabUpdated tid cinfo tab'

onTabActived :: (Ref.Ref GlobalState) -> TabsOnActivated.ActiveInfo -> Effect Unit
onTabActived stateRef (TabsOnActivated.ActiveInfo aInfo) = do
  traceM aInfo
  state <- Ref.modify (updateGlobalState aInfo.previousTabId aInfo.tabId) stateRef
  case (preview (_portFromWindowId aInfo.windowId) state) of
    Nothing -> pure unit
    Just port -> Runtime.postMessageJson port $ BgTabActived aInfo.previousTabId aInfo.tabId
  where
  updateGlobalState :: (Maybe TabId) -> TabId -> GlobalState -> GlobalState
  updateGlobalState prev new state =
    let
      -- TODO: we have the windowId, we can directly get the tab from that
      -- without using _tabFromTabIdAndWindow that goes through all the windows.
      prevTab = prev >>= _tabFromTabIdAndWindow state

      prevTabF :: GlobalState -> GlobalState
      prevTabF = maybe identity (\t -> set (_activeTab t) false) prevTab

      newTab = _tabFromTabIdAndWindow state new

      newTabF :: GlobalState -> GlobalState
      newTabF = maybe identity (\t -> set (_activeTab t) true) newTab

      _activeTab t = (_tabFromWindow t) <<< _Just <<< _Newtype <<< _active
    in
      (prevTabF >>> newTabF) state

onTabDeleted :: (Ref.Ref GlobalState) -> TabId -> TabsOnRemoved.RemoveInfo -> Effect Unit
onTabDeleted stateRef tabId info = do
  state <- Ref.read stateRef
  let
    allTabs = _tabFromTabIdAndWindow state tabId

    newState = foldr (\t -> set (_tabFromWindow t) Nothing) state allTabs
  Ref.write newState stateRef
  for_ allTabs \t -> do
    let
      port = preview (_portFromWindow t) state
    maybe (pure unit) ((flip Runtime.postMessageJson) (BgTabDeleted tabId)) port

onConnect :: (Ref.Ref GlobalState) -> Runtime.Port -> Effect Unit
onConnect stateRef' port = do
  -- create a temporary listener ref that will only be held until the sidebar has sent its current window
  listenerRef <- Ref.new Nothing
  initialListener <-
    Runtime.onMessageJsonAddListener port $ windowListener
      $ onNewWindowId port stateRef' listenerRef
  -- XXX: is it possible a message arrive *before* this is executed ? 
  -- theoretically yes, and this means this way of doing is unsafe, but it's
  -- difficult for a handler to remove itself otherwise.
  Ref.write (Just initialListener) listenerRef
  where
  windowListener :: (WindowId -> Effect Unit) -> SidebarEvent -> Effect Unit
  windowListener callback msg = case msg of
    SbHasWindowId winId -> log ("bg: created winId " <> show winId) *> callback winId
    _ -> pure unit

onNewWindowId ::
  forall a.
  Runtime.Port ->
  (Ref.Ref GlobalState) ->
  ( Ref.Ref
      ( Maybe
          (Listener a)
      )
  ) ->
  WindowId -> Effect Unit
onNewWindowId port stateRef listenerRef winId = do
  -- initial state of the current window
  r <- initWindowState port stateRef winId
  -- remove the previous onMessage listener
  ogListener <- Ref.read listenerRef
  foldMap (\l -> Runtime.onMessageRemoveListener port l) ogListener
  Ref.write Nothing listenerRef
  -- send initial tabs
  maybe (pure unit)
    (\w -> Runtime.postMessageJson port $ BgInitialTabList $ fromFoldable $ values w.tabs)
    (lookup winId r.windows)
  --  add the new onMessage listener
  sidebarListener <- Runtime.onMessageJsonAddListener port $ manageSidebar stateRef port
  onDisconnectListener <- mkListenerUnit $ onDisconnect stateRef winId sidebarListener
  Runtime.portOnDisconnect port onDisconnectListener

initWindowState :: Runtime.Port -> (Ref.Ref GlobalState) -> WindowId -> Effect GlobalState
initWindowState port ref winId =
  (flip Ref.modify) ref
    $ over (_windows <<< (at winId))
        ( case _ of
            Nothing -> Just $ { tabs: empty, port: Just port }
            Just win -> Just $ set _port (Just port) win
        )

-- TODO don't pass the full ref, but only a set of function to manipulate/access 
-- the data required
manageSidebar :: (Ref.Ref GlobalState) -> Runtime.Port -> SidebarEvent -> Effect Unit
manageSidebar stateRef port (SbTabDeleted tabId) = launchAff_ $ removeOne tabId

manageSidebar stateRef port (SbTabActived tabId) = launchAff_ $ activateTab tabId

manageSidebar stateRef port msg = pure unit

onDisconnect :: forall a. (Ref.Ref GlobalState) -> WindowId -> Listener a -> Effect Unit
onDisconnect stateRef winId listener = Ref.modify_ (set (_windows <<< (at winId) <<< _Just <<< _port) Nothing) stateRef