-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.EvalServer
-- Copyright   :  (c) 2009 Daniel Schoepe
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Daniel Schoepe <daniel.schoepe@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- This module allows controlling XMonad through Haskell expressions sent
-- via a socket.
--
-----------------------------------------------------------------------------

module XMonad.Hooks.EvalServer (
                               -- * Usage
                               -- $usage

                               -- * Documentation
                               -- $documentation

                                initEVData
                               ,startServer
                               ,defaultServer
                               ,defaultServerConfig
                               ,evalEventHook
                               ,EvalServerData
                               ) where

import Control.Concurrent
import Control.Monad
import Control.Concurrent.MVar

import Data.Monoid

import System.IO

import XMonad.Actions.Eval
import XMonad

import Network

-- $usage
--
-- WARNING: This module will have the following issue if xmonad wasn't compiled with -threaded
-- (requires a modified xmonad-version): Expressions will only get evaluated when xmonad
-- receives an event, for example when the focus changes.
--
-- This module is highly experimental and might not work as expected or even cause deadlocks
-- when used with -threaded, due to the fact that xlib isn't reentrant.
--
-- This module lets you create a server that evaluates Haskell expressions in
-- the context of the currently running xmonad instance, which lets you control xmonad from
-- another process(e.g. a script).
-- To use this module add something like this to your xmonad.hs:
--
-- > import XMonad.Hooks.EvalServer
--
-- > main = do
-- >   evData <- initEVData
-- >   ..
-- >   xmonad $ .. $ defaultConfig {
-- >                   handleEventHook = evalEventHook defaultServerConfig evData
-- >                   startupHook = defaultServer evData 4242
-- >   ..
-- >   }
--
-- You can then send Haskell expressions that are to be evaluated over the socket.
-- Example using telnet:
--
-- > telnet localhost 4242
-- > windows $ W.view "1"
--
-- By default, xmonad is not built with -threaded, so commands will
-- only be executed after an event is received. xmonadcmd, which is
-- included in this package, is a workaround to this problem. After
-- sending the command, it also sends an event to the root window
-- to trigger the execution of the command.
--
-- For more information run 'xmonadcmd --help'
--

-- $documentation

-- | Data type for storing information such as the socket and received commands
data EvalServerData = EVData { evThreads :: MVar [(ThreadId,Handle)]
                             , evCommands :: MVar [(String,Handle)]
                             , evSocket :: MVar Socket }

-- | Creates the structure to store received commands and other data. A variable of this
-- type has to be passed to the other functions of this module.
initEVData :: MonadIO m => m EvalServerData
initEVData = liftIO $ liftM3 EVData (newMVar []) newEmptyMVar newEmptyMVar -- not so pretty, but fits on one line

-- | Creates a server listening on a TCP socket with the given port number.
defaultServer :: MonadIO m => EvalServerData -> PortNumber -> m ()
defaultServer cv = startServer cv . PortNumber

-- | Creates a server listening on the specified port(can also be a unix domain socket).
startServer :: MonadIO m => EvalServerData -> PortID -> m ()
startServer evdata port = liftIO $ do
  s <- listenOn port
  putMVar (evSocket evdata) s
  tid <- forkIO . forever $ accept s >>= clientThread evdata
  modifyMVar_ (evThreads evdata) $ return . ((tid,stdout):)
  return ()

-- | Default config to evaluate the received expressions
defaultServerConfig :: EvalConfig
defaultServerConfig = defaultEvalConfig { handleError = return . show }

-- | This event hook causes commands to be executed when they are received.
evalEventHook :: EvalConfig -> EvalServerData -> Event -> X All
evalEventHook evConfig evdata (ClientMessageEvent { ev_message_type = mt }) = do
  dpy <- asks display
  update <- io $ internAtom dpy "XMONAD_EVALSRV_UPD" False
  restrt <- io $ internAtom dpy "XMONAD_RESTART" False
  if mt == update
     then do
       cmds <- io . tryTakeMVar . evCommands $ evdata
       whenJust cmds $ mapM_ $ \(cmd,h) ->
          evalExpressionWithReturn evConfig cmd >>= io . hPutStrLn h
       return $ All False
     else if mt == restrt
             then shutdownServer evdata >> return (All True)
             else return $ All True
evalEventHook _ _ _ = return $ All True

shutdownServer :: MonadIO m => EvalServerData -> m ()
shutdownServer evdata = liftIO $ do
  -- we need to kill the reading thread first, otherwise hClose will block
  modifyMVar_ (evThreads evdata) $ (>> return []) . mapM_ (\(tid,h) -> killThread tid >> hClose h)
  modifyMVar_ (evSocket evdata) $ \s -> sClose s >> return s

-- | Handler for an individual client.
clientThread :: EvalServerData -> (Handle,HostName,PortNumber) -> IO ()
clientThread evdata (h,_,_) = do
  tid <- forkIO $ do
           hSetBuffering h LineBuffering
           forever $ hGetLine h >>= handleCommand h evdata
  modifyMVar_ (evThreads evdata) $ return . ((tid,h):)

-- | Handles a received command. TODO: Add a more elaborate protocol(e.g. one that allows shutting
-- down the server).
handleCommand :: Handle -> EvalServerData -> String -> IO ()
handleCommand h evdata cmd = openDisplay "" >>= \dpy -> do
  let cmds = evCommands evdata
  empt <- isEmptyMVar cmds
  if empt
     then putMVar cmds [(cmd,h)]
     else modifyMVar_ cmds (return . ((cmd,h):))
  -- normally we should use forkProcess here, but this doesn't work
  -- due to ghc issue 1185: http://hackage.haskell.org/trac/ghc/ticket/1185
  -- forkIO with -threaded could potentially cause problems, as the Xlib is
  -- not reentrant, so not using a -threaded version of xmonad and sending
  -- some event to the root window to have getEvent return might be preferable.
  forkIO $ do
    rootw <- rootWindow dpy $ defaultScreen dpy
    a <- internAtom dpy "XMONAD_EVALSRV_UPD" False
    allocaXEvent $ \e -> do
                  setEventType e clientMessage
                  setClientMessageEvent e rootw a 32 0 currentTime
                  sendEvent dpy rootw False structureNotifyMask e
                  sync dpy False
  return ()