{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances,
  InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Information.SafeX11
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar.Information.SafeX11
  ( module Graphics.X11.Xlib
  , module Graphics.X11.Xlib.Extras
  , module System.Taffybar.Information.SafeX11
  )
  where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Either.Combinators
import Data.Typeable
import Foreign hiding (void)
import Foreign.C.Types
import GHC.ForeignPtr
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
       hiding (rawGetWindowProperty, getWindowProperty8,
               getWindowProperty16, getWindowProperty32,
               xGetWMHints, getWMHints, refreshKeyboardMapping)
import Prelude
import System.IO.Unsafe
import System.Log.Logger
import System.Timeout
import Text.Printf

logHere :: Priority -> String -> IO ()
logHere = logM "System.Taffybar.Information.SafeX11"

foreign import ccall safe "XlibExtras.h XGetWMHints"
    safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)

foreign import ccall interruptible "XlibExtras.h XGetWindowProperty"
               safeXGetWindowProperty ::
               Display ->
                 Window ->
                   Atom ->
                     CLong ->
                       CLong ->
                         Bool ->
                           Atom ->
                             Ptr Atom ->
                               Ptr CInt ->
                                 Ptr CULong ->
                                   Ptr CULong ->
                                     Ptr (Ptr CUChar) -> IO Status

rawGetWindowPropertyBytes
  :: Storable a
  => Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int))
rawGetWindowPropertyBytes bits d atom w =
  alloca $ \actual_type_return ->
    alloca $ \actual_format_return ->
      alloca $ \nitems_return ->
        alloca $ \bytes_after_return ->
          alloca $ \prop_return -> do
            ret <- postX11RequestSync $
              safeXGetWindowProperty
                d
                w
                atom
                0
                0xFFFFFFFF
                False
                anyPropertyType
                actual_type_return
                actual_format_return
                nitems_return
                bytes_after_return
                prop_return
            if fromRight (-1) ret /= 0
              then return Nothing
              else do
                prop_ptr <- peek prop_return
                actual_format <- fromIntegral `fmap` peek actual_format_return
                nitems <- fromIntegral `fmap` peek nitems_return
                getprop prop_ptr nitems actual_format
  where
    getprop prop_ptr nitems actual_format
      | actual_format == 0 = return Nothing -- Property not found
      | actual_format /= bits = xFree prop_ptr >> return Nothing
      | otherwise = do
        ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr)
        return $ Just (ptr, nitems)

data SafeX11Exception = SafeX11Exception deriving (Show, Eq, Typeable)

instance Exception SafeX11Exception

data IORequest = forall a. IORequest
  { ioAction :: IO a
  , ioResponse :: Chan (Either SafeX11Exception a)
  }

{-# NOINLINE requestQueue #-}
requestQueue :: Chan IORequest
requestQueue = unsafePerformIO newChan

{-# NOINLINE x11Thread #-}
x11Thread :: ThreadId
x11Thread = unsafePerformIO $ forkIO startHandlingX11Requests

withErrorHandler :: XErrorHandler -> IO a -> IO a
withErrorHandler new_handler action = do
    handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)
    original <- _xSetErrorHandler handler
    res <- action
    _ <- _xSetErrorHandler original
    return res

deriving instance Show ErrorEvent

startHandlingX11Requests :: IO ()
startHandlingX11Requests =
  withErrorHandler handleError handleX11Requests
  where handleError _ xerrptr = do
          ee <- getErrorEvent xerrptr
          logHere WARNING $
                  printf "Handling X11 error with error handler: %s" $ show ee

handleX11Requests :: IO ()
handleX11Requests = do
  IORequest {ioAction = action, ioResponse = responseChannel} <-
    readChan requestQueue
  res <-
    catch
      (maybe (Left SafeX11Exception) Right <$> timeout 500000 action)
      (\e -> do
         logHere WARNING $ printf "Handling X11 error with catch: %s" $
                 show (e :: IOException)
         return $ Left SafeX11Exception)
  writeChan responseChannel res
  handleX11Requests
  return ()

postX11RequestSync :: IO a -> IO (Either SafeX11Exception a)
postX11RequestSync action = do
  let postAndWait = do
        responseChannel <- newChan :: IO (Chan (Either SafeX11Exception a))
        writeChan
          requestQueue
          IORequest {ioAction = action, ioResponse = responseChannel}
        readChan responseChannel
  currentTID <- myThreadId
  if currentTID == x11Thread
    then Right <$> action
    else postAndWait

postX11RequestSyncDef :: a -> IO a -> IO a
postX11RequestSyncDef def action =
  fromRight def <$> postX11RequestSync action

rawGetWindowProperty ::
  Storable a
  => Int -> Display -> Atom -> Window -> IO (Maybe [a])
rawGetWindowProperty bits d atom w =
  runMaybeT $ do
    (ptr, count) <- MaybeT $ rawGetWindowPropertyBytes bits d atom w
    lift $ withForeignPtr ptr $ peekArray count

getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar])
getWindowProperty8 = rawGetWindowProperty 8

getWindowProperty16 :: Display -> Atom -> Window -> IO (Maybe [CShort])
getWindowProperty16 = rawGetWindowProperty 16

getWindowProperty32 :: Display -> Atom -> Window -> IO (Maybe [CLong])
getWindowProperty32 = rawGetWindowProperty 32

getWMHints :: Display -> Window -> IO WMHints
getWMHints dpy w = do
    p <- safeXGetWMHints dpy w
    if p == nullPtr
        then return $ WMHints 0 False 0 0 0 0 0 0 0
        else do x <- peek p; _ <- xFree p; return x

safeGetGeometry :: Display -> Drawable ->
        IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt)
safeGetGeometry display d =
        outParameters7 (throwIfZero "getGeometry") $
                xGetGeometry display d

outParameters7 :: (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) =>
        (IO r -> IO ()) -> (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) ->
        IO (a,b,c,d,e,f,g)
outParameters7 check fn =
        alloca $ \ a_return ->
        alloca $ \ b_return ->
        alloca $ \ c_return ->
        alloca $ \ d_return ->
        alloca $ \ e_return ->
        alloca $ \ f_return ->
        alloca $ \ g_return -> do
        check (fn a_return b_return c_return d_return e_return f_return g_return)
        a <- peek a_return
        b <- peek b_return
        c <- peek c_return
        d <- peek d_return
        e <- peek e_return
        f <- peek f_return
        g <- peek g_return
        return (a,b,c,d,e,f,g)

foreign import ccall safe "HsXlib.h XGetGeometry"
        xGetGeometry :: Display -> Drawable ->
                Ptr Window -> Ptr Position -> Ptr Position -> Ptr Dimension ->
                Ptr Dimension -> Ptr Dimension -> Ptr CInt -> IO Status