Render.hs

-- Author:     Andy Stewart <lazycat.manatee@gmail.com>
-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>
-- 
-- Copyright (C) 2010 Andy Stewart, all rights reserved.
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Manatee.Core.Render where

import Control.Monad.State
import DBus.Client hiding (Signal)
import GHC.Conc
import Graphics.UI.Gtk hiding (Window, windowNew, Frame, frameNew, Signal, Frame, Variant, Action, plugNew, plugGetId, get)
import Manatee.Core.DBus
import Manatee.Core.Debug
import Manatee.Core.Dynload
import Manatee.Core.Page
import Manatee.Core.PageView
import Manatee.Core.Types
import Manatee.Toolkit.General.DBus
import Manatee.Toolkit.General.Maybe
import Manatee.Toolkit.General.Process
import Manatee.Toolkit.General.STM
import Manatee.Toolkit.General.Set hiding (mapM)
import Manatee.Toolkit.General.State
import Manatee.Toolkit.Widget.Plug
import System.Environment
import System.Posix.Process
import System.Posix.Types (ProcessID)

import qualified Data.Map as M
import qualified Data.Set as Set

-- | Irc client render process.
startupRender :: PageBufferNewFun -> CustomizeNewFun -> IO ()
startupRender bufferNewFun customizeNewFun = do
  -- Get program arguments.
  args <- getArgs

  case args of
    [x] -> 
        case (read x :: SpawnProcessArgs) of
          arg@(SpawnRenderProcessArgs {}) -> renderMain arg bufferNewFun customizeNewFun
          _ -> return ()
    _ -> return ()
    
-- | Render process main entry.
renderMain :: SpawnProcessArgs -> PageBufferNewFun -> CustomizeNewFun -> IO ()
renderMain (SpawnRenderProcessArgs pageId pType sId pagePath options) bufferNewFun customizeNewFun = do
  -- Init.
  unsafeInitGUIForThreadedRTS

  -- Create page list.
  pageList <- newTVarIO Set.empty 

  -- Get render process id.
  processId <- getProcessID

  -- Create client.
  let clientName = mkRenderClientName processId
  client <- mkSessionClientWithName clientName

  -- Load user's configure file.
  customizeWrap <- customizeNewFun

  -- Create page buffer.
  bufferWrap <- bufferNewFun pagePath options client pageId customizeWrap

  -- Build render client for listen dbus signal.
  pongStatusTVar <- newTVarIO GotPongMessage
  mkRenderClient client bufferWrap customizeWrap processId pageList pType pongStatusTVar

  -- Create first page.
  renderPageNew client bufferWrap pageList processId (pageId, pType, sId) True

  -- Send ping signal.
  renderSendPing client pongStatusTVar

  -- Loop.
  mainGUI

-- | Build render client for listen dbus signal.
mkRenderClient :: Client 
               -> PageBufferWrap 
               -> CustomizeWrap 
               -> ProcessID 
               -> TVar PageList 
               -> PageType 
               -> TVar PongStatus
               -> IO ()
mkRenderClient client bufferWrap customizeWrap processId pageList pType pongStatusTVar = 
  -- Build match rule.
  mkRenderMatchRules client 
    [(CloneRenderPage,          renderHandleClonePage client bufferWrap pageList processId pType)
    ,(ReparentRenderPage,       renderHandleReparentPage client bufferWrap pageList processId)
    ,(FocusRenderPage,          renderHandleFocusPage pageList)
    ,(PageViewKeyPress,         renderHandleKeyPress pageList)
    ,(DestroyRenderPage,        renderHandleDestroyPage pageList)
    ,(ExitRenderProcess,        renderHandleExitProcess client processId)
    ,(UpdateConfig,             renderHandleUpdateConfig customizeWrap)
    ,(InstallConfig,            renderHandleInstallConfig bufferWrap)
    ,(Pong,                     renderHandlePong pongStatusTVar)
    ]

-- | Handle clone render page signal.
renderHandleClonePage :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> PageType -> RenderSignalArgs -> IO ()
renderHandleClonePage client bufferWrap pageList processId pType (CloneRenderPageArgs pageId sId) = do
  debugDBusMessage $ "renderHandleClonePage: Catch CloneRenderPage signal. Box id: " ++ show sId

  renderPageNew client bufferWrap pageList processId (pageId, pType, sId) False
  
  debugDBusMessage $ "renderHandleClonePage: Finish clone page. Box id : " ++ show sId

-- | Handle re-parent render page signal.
renderHandleReparentPage :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> RenderSignalArgs -> IO ()
renderHandleReparentPage client (PageBufferWrap buffer) pageList processId (ReparentRenderPageArgs pageId oldPlugId sId) = do
  debugDBusMessage $ "renderHandleReparentPage: Catch ReparentRenderPage signal. Box id: " ++ show sId

  -- Get old plug.
  pList <- readTVarIO pageList
  let oldPage = maybeFindMin pList (\x -> pagePlugId x == oldPlugId)

  -- Try to re-parent children from old plug.
  case oldPage of
    Just op -> do
          -- Create new plug.
          newPlug <- plugNew Nothing
          let pId = plugId newPlug
              pType = pageType op 

          -- Reparent.
          writeTVarIO (pageApplyViewWrap op pageViewPlugId) pId -- update new page plug id
          widgetReparent (pageBox op) (plugBody newPlug)
          widgetShowAll $ plugBody newPlug

          -- New page.
          page <- pageNew pageId pType newPlug (pageView op)

          -- Add page to page list.
          runTVarStateT pageList $ put . Set.insert page

          -- Destroy old plug.
          renderHandleDestroyPage pageList (DestroyRenderPageArgs oldPlugId)
  
          -- Send `NewRenderPageConfirm` signal.
          let modeName = pageModeName $ pageBufferMode buffer 
          path <- pageBufferGetName buffer
          mkDaemonSignal client 
                         NewRenderPageConfirm 
                         (NewRenderPageConfirmArgs pageId pType sId pId processId modeName path False)

          debugDBusMessage $ "renderHandleReparentPage: Finish reparent page. Box id : " ++ show sId
    Nothing -> debugDBusMessage $ "Warning (renderHandleReparentPage): Cant find old plug " ++ show oldPlugId ++ " to reparent."

-- | Handle new render page signal.
renderPageNew :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> (PageId, PageType, SignalBoxId) -> Bool -> IO ()
renderPageNew client (PageBufferWrap buffer) pageList processId (pageId, pType, sId) isFirstPage = do
   -- Create page plug.
  plug <- plugNew Nothing
  let pId = plugId plug
  
  -- Create page.
  viewWrap <- pageBufferCreateView buffer pId
  page <- pageNew pageId pType plug viewWrap
  
  -- Create page and pageView.
  plugBody plug `containerAdd` pageBox page
  widgetShowAll $ plugBody plug
  
  -- Add page to page list.
  runTVarStateT pageList $ put .  Set.insert page
  
  -- Send `NewRenderPageConfirm` signal.
  let modeName = pageModeName $ pageBufferMode buffer 
  path <- pageBufferGetName buffer
  mkDaemonSignal client 
                 NewRenderPageConfirm 
                 (NewRenderPageConfirmArgs pageId pType sId pId processId modeName path isFirstPage)

-- | Handle focus render page signal.
renderHandleFocusPage :: TVar PageList -> RenderSignalArgs -> IO ()
renderHandleFocusPage pageList (FocusRenderPageArgs plugId) = do
  pl <- readTVarIO pageList
  maybeFindMin pl (\x -> pagePlugId x == plugId) 
     ?>= \ page -> pageApplyViewWrap page pageViewFocus 

-- | Handle page view key press signal.
renderHandleKeyPress :: TVar PageList -> RenderSignalArgs -> IO ()
renderHandleKeyPress pageList (PageViewKeyPressArgs plugId keystoke sEvent) = do
  pl <- readTVarIO pageList
  maybeFindMin pl (\x -> pagePlugId x == plugId) 
     ?>= \ (Page {pageView = PageViewWrap view}) -> 
       case M.lookup keystoke pageViewKeymap of
         -- Execute page view common action when match.
         Just action -> action view
         -- Otherwise pass key to page view instance.
         Nothing -> pageViewHandleKeyAction view keystoke sEvent

-- | Handle destroy render page signal.
renderHandleDestroyPage :: TVar PageList -> RenderSignalArgs -> IO ()
renderHandleDestroyPage pageList (DestroyRenderPageArgs plugId) = 
    runTVarStateT pageList $ \pl -> 
      maybeFindMin pl (\x -> pagePlugId x == plugId) ?>= \page -> do
         lift $ debugDBusMessage $ "renderHandleDestroyPage: Catch DestroyRenderPage signal. Plug id : " ++ show plugId
         -- Delete page from page list.
         put (Set.delete page pl)                              
         -- Destroy page.
         lift $ plugDestroy $ pagePlug page
                  
-- | Handle exit process signal.
renderHandleExitProcess :: Client -> ProcessID -> RenderSignalArgs -> IO ()
renderHandleExitProcess client processId (ExitRenderProcessArgs pageId) = do
  -- Send RenderProcessExitConfirm signal to daemon process.
  mkDaemonSignal client RenderProcessExitConfirm (RenderProcessExitConfirmArgs pageId processId)

  -- Quit process.
  mainQuit

-- | Handle update config signal.
renderHandleUpdateConfig :: CustomizeWrap -> RenderSignalArgs -> IO ()
renderHandleUpdateConfig customizeWrap _ = 
  loadConfig customizeWrap True

-- | Handle install config signal.
renderHandleInstallConfig :: PageBufferWrap -> RenderSignalArgs -> IO ()
renderHandleInstallConfig (PageBufferWrap buffer) _ = do
  packageName <- pageBufferPackageName buffer
  runCommand_ ("cabal install " ++ packageName ++ " --reinstall")

-- | Handle pong signal.
renderHandlePong :: TVar PongStatus -> RenderSignalArgs -> IO ()
renderHandlePong pongStatusTVar _ = 
  writeTVarIO pongStatusTVar GotPongMessage
  
-- | Send ping signal.  
-- Render process will send PING message in delay time.
-- Quit current process if not receive PONG message in next delay time.
-- Use for test daemon process whether live to avoid immortal process.
renderSendPing :: Client -> TVar PongStatus -> IO ()
renderSendPing client pongStatusTVar = do
  -- Get current process id.
  processId <- getProcessID
  let sendDelay = 5000          -- delay time to send ping message

  -- Send ping message in delay time.
  timeoutAdd (do
               pongStatus <- readTVarIO pongStatusTVar
               case pongStatus of
                 GotPongMessage -> do
                   -- Send ping signal to test whether daemon process still live.
                   mkDaemonSignal client Ping (PingArgs processId)
                   -- Change pong status to WaitPongMessage. 
                   writeTVarIO pongStatusTVar WaitPongMessage
                 WaitPongMessage -> do
                   -- Quit process if lost ping message.
                   putStrLn $ "Lost pong message from daemon process, quit process (" ++ show processId ++ ")"
                   mainQuit
               return True)
              sendDelay
  
  return ()