{-# LINE 1 "src/Network/Skype/API/X11.hsc" #-}
module Network.Skype.API.X11 (
{-# LINE 2 "src/Network/Skype/API/X11.hsc" #-}
  Connection,
  DisplayAddress,
  connect,
  connectTo
) where


{-# LINE 9 "src/Network/Skype/API/X11.hsc" #-}

import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.STM.TChan (TChan, newBroadcastTChanIO, writeTChan)
import Control.Exception (IOException)
import Control.Exception.Lifted (catch)
import Control.Monad (mplus)
import Control.Monad.Error (Error, strMsg)
import Control.Monad.Error.Class (MonadError, throwError)
import Control.Monad.Reader (ReaderT, asks)
import Control.Monad.STM (atomically)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Control (MonadBaseControl, control)
import Data.Maybe (listToMaybe)
import Data.Monoid (mappend, mempty)
import Foreign hiding (addForeignPtrFinalizer, newForeignPtr)
import Foreign.C.Types
import Foreign.Concurrent
import System.Environment (getEnv)
import Network.Skype.Command.Misc (authenticate)
import Network.Skype.Core

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Builder as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Graphics.X11.Xlib as X
import qualified Graphics.X11.Xlib.Extras as X

data Connection = Connection
  { skypeAPI :: SkypeAPI
  , skypeNotificatonChan :: TChan Notification
  , skypeThread :: ThreadId
  }

data SkypeAPI = SkypeAPI
  { skypeDisplay :: ForeignPtr X.Display
  , skypeWindow :: X.Window
  , skypeInstanceWindow :: X.Window
  , skypeMessageBeginAtom :: X.Atom
  , skypeMessageContinueAtom :: X.Atom
  }
  deriving (Show, Eq)

type DisplayAddress = String

instance MonadIO m => MonadSkype (ReaderT Connection m) where
  sendCommand command = asks skypeAPI >>= liftIO . flip sendTo command

  getNotificationChan = asks skypeNotificatonChan

openDisplay :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)
            => DisplayAddress
            -> m (ForeignPtr X.Display)
openDisplay address = do
  display'@(X.Display display) <- liftIO (X.openDisplay address) `catch` throwError
  liftIO $ newForeignPtr display $ X.closeDisplay display'

getDisplayAddress :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)
                  => m DisplayAddress
getDisplayAddress = liftIO (getEnv "SKYPEDISPLAY" `mplus` getEnv "DISPLAY")
                    `catch` throwError

createWindow :: (Error e, MonadIO m, MonadError e m)
             => X.Display -> X.Window -> m X.Window
createWindow display root = do
  let screen = X.defaultScreen display
      pixel  = X.blackPixel display screen

  window <- liftIO $ X.createSimpleWindow display root 0 0 1 1 0 pixel pixel

  if window == X.none
     then throwError $ strMsg "Can't create the window"
     else return window

createAtom :: (Error e, MonadIO m, MonadError e m)
           => X.Display -> String -> m X.Atom
createAtom display name = do
  atom <- liftIO $ X.internAtom display name True

  if atom == X.none
    then throwError $ strMsg $ "Can't create the atom: " ++ name
    else return atom

getSkypeInstanceWindow :: (Error e, MonadIO m, MonadError e m)
                       => X.Display -> X.Window -> m X.Window
getSkypeInstanceWindow display root = do
  instanceAtom <- createAtom display "_SKYPE_INSTANCE"

  status <- liftIO $ X.getWindowProperty32 display instanceAtom root

  case status >>= listToMaybe of
    Nothing       -> throwError $ strMsg "Skype instance window is not found"
    Just property -> return $ fromIntegral property .&. 0xffffffff

connect :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)
        => ApplicationName
        -> m Connection
connect appName = flip connectTo appName =<< getDisplayAddress

connectTo :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)
          => DisplayAddress
          -> ApplicationName
          -> m Connection
connectTo address appName = do
  api <- createAPI address
  notificationChan <- liftIO newBroadcastTChanIO
  thread <- liftIO $ forkIO $
            runEventLoop api $ atomically . writeTChan notificationChan

  let connection = Connection
                   { skypeAPI = api
                   , skypeNotificatonChan = notificationChan
                   , skypeThread = thread
                   }

  result <- runSkype connection $ authenticate appName

  either (throwError . strMsg . show) (const $ return connection) result

createAPI :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)
          => String
          -> m SkypeAPI
createAPI address = do
  display <- openDisplay address

  withForeignPtr' display $ \display_ptr -> do
    let display' = X.Display display_ptr
    let root = X.defaultRootWindow display'

    window <- createWindow display' root

    liftIO $ addForeignPtrFinalizer display $
             X.destroyWindow display' window

    instanceWindow <- getSkypeInstanceWindow display' root

    messageBeginAtom <- createAtom display' "SKYPECONTROLAPI_MESSAGE_BEGIN"
    messageContinueAtom <- createAtom display' "SKYPECONTROLAPI_MESSAGE"

    return $ SkypeAPI
      { skypeDisplay             = display
      , skypeWindow              = window
      , skypeInstanceWindow      = instanceWindow
      , skypeMessageBeginAtom    = messageBeginAtom
      , skypeMessageContinueAtom = messageContinueAtom
      }

sendTo :: SkypeAPI -> BS.ByteString -> IO ()
sendTo api message =
  X.allocaXEvent $ \event_ptr ->
  withForeignPtr (skypeDisplay api) $ \display_ptr -> do
    (\hsc_ptr -> pokeByteOff hsc_ptr 0)         event_ptr (33 :: CInt)
{-# LINE 161 "src/Network/Skype/API/X11.hsc" #-}
    (\hsc_ptr -> pokeByteOff hsc_ptr 24)      event_ptr display_ptr
{-# LINE 162 "src/Network/Skype/API/X11.hsc" #-}
    (\hsc_ptr -> pokeByteOff hsc_ptr 32)       event_ptr $ skypeWindow api
{-# LINE 163 "src/Network/Skype/API/X11.hsc" #-}
    (\hsc_ptr -> pokeByteOff hsc_ptr 40) event_ptr $ skypeMessageBeginAtom api
{-# LINE 164 "src/Network/Skype/API/X11.hsc" #-}
    (\hsc_ptr -> pokeByteOff hsc_ptr 48)       event_ptr (8 :: CInt)  -- 8 bit values
{-# LINE 165 "src/Network/Skype/API/X11.hsc" #-}

    let display = X.Display display_ptr

    case splitPerChunk message of
      []       -> return ()
      (bs:[])  -> send display event_ptr bs
      (bs:bss) -> do
        send display event_ptr bs

        (\hsc_ptr -> pokeByteOff hsc_ptr 40) event_ptr $ skypeMessageContinueAtom api
{-# LINE 175 "src/Network/Skype/API/X11.hsc" #-}

        mapM_ (send display event_ptr) bss

  where
    send display event_ptr chunk = do
      let data_ptr = (\hsc_ptr -> hsc_ptr `plusPtr` 56) event_ptr
{-# LINE 181 "src/Network/Skype/API/X11.hsc" #-}

      BS.unsafeUseAsCStringLen chunk $ uncurry $ copyArray data_ptr

      X.sendEvent display (skypeInstanceWindow api) False 0 event_ptr
      X.flush display

    splitPerChunk bs
      | BS.length bs == messageChunkSize = bs : BS.singleton 0 : []
      | BS.length bs < messageChunkSize  = BS.snoc bs 0 : []
      | otherwise                        = let (xs, ys) = BS.splitAt messageChunkSize bs
                                           in  xs : splitPerChunk ys

-- | Generalized version of 'withForeignPtr'.
withForeignPtr' :: (MonadBaseControl IO m) => ForeignPtr a -> (Ptr a -> m b) -> m b
withForeignPtr' fp action =
  control $ \runInIO -> withForeignPtr fp $ runInIO . action

ptrIndex :: (Eq a, Storable a) => Ptr a -> a -> Int -> IO (Maybe Int)
ptrIndex ptr value n = go 0 value $ take n $ iterate (flip plusPtr 1) ptr
  where
    go _ _ [] = return Nothing
    go acc x (y:ys) = do
      y' <- peek y
      if y' == x
        then return $ Just acc
        else go (acc + 1) x ys

messageChunkSize :: Int
messageChunkSize = 20
{-# LINE 210 "src/Network/Skype/API/X11.hsc" #-}
{-# INLINE messageChunkSize #-}

runEventLoop :: SkypeAPI -> (BL.ByteString -> IO ()) -> IO ()
runEventLoop api action =
  X.allocaXEvent $ \event_ptr ->
  withForeignPtr (skypeDisplay api) $ \display_ptr ->
  loop mempty (X.Display display_ptr) event_ptr
  where
    loop builder display event_ptr = do
      X.nextEvent display event_ptr  -- will blocking

      eventType <- (\hsc_ptr -> peekByteOff hsc_ptr 0) event_ptr
{-# LINE 222 "src/Network/Skype/API/X11.hsc" #-}

      if eventType == X.clientMessage
      then do
        messageType <- (\hsc_ptr -> peekByteOff hsc_ptr 40) event_ptr
{-# LINE 226 "src/Network/Skype/API/X11.hsc" #-}

        if messageType == skypeMessageBeginAtom api ||
           messageType == skypeMessageContinueAtom api
        then do
          let data_ptr = (\hsc_ptr -> hsc_ptr `plusPtr` 56) event_ptr
{-# LINE 231 "src/Network/Skype/API/X11.hsc" #-}

          maybeIndex <- ptrIndex data_ptr (0 :: CChar) messageChunkSize

          case maybeIndex of
            Just i -> do
              bs <- BS.packCStringLen (data_ptr, i)
              action $ BS.toLazyByteString $ builder `mappend` BS.byteString bs
              loop mempty display event_ptr

            Nothing -> do
              bs <- BS.packCStringLen (data_ptr, messageChunkSize)
              loop (builder `mappend` BS.byteString bs) display event_ptr
        else
          loop builder display event_ptr
      else
        loop builder display event_ptr