Connection.hs

{- |

Basic functions for initiating and working with a connection to an
X11 server.

-}

module Graphics.XHB.Connection
    (Connection
    ,connect
    ,connectTo
    ,displayInfo
    ,connectionSetup
    ,mkConnection
    ,newResource
    ,pollForEvent
    ,waitForEvent
    ,pollForError
    ,waitForError
    ,setCrashOnError
    ,SomeError
    ,SomeEvent
    ,getRoot
    )
    where

import Data.Word

-- MAY import generated type modules (XHB.Gen.*.Types)
-- MAY NOT import other generated modules

import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad

import System.IO
import System.ByteOrder

import Foreign.C.String

import Data.List (genericLength)
import Data.Maybe
import Data.Monoid(mempty)
import qualified Data.Map as M

import Data.ByteString.Lazy(ByteString)
import qualified Data.ByteString.Lazy as BS

import Data.Binary.Get
import Data.Binary.Put

import Data.Bits

import Graphics.XHB.Gen.Xproto.Types
import Graphics.XHB.Gen.Extension

import Graphics.XHB.Connection.Types
import Graphics.XHB.Connection.Internal
import Graphics.XHB.Connection.Open
import Graphics.XHB.Shared

import Graphics.X11.Xauth

-- | Returns the 'Setup' information returned by the server
-- during the initiation of the connection.
connectionSetup :: Connection -> Setup
connectionSetup = conf_setup . conn_conf

newResource :: XidLike a => Connection -> IO a
newResource c = do
  xidM <- nextXid c
  case xidM of
    Just xid -> return . fromXid $ xid
    Nothing -> error "resource ids exhausted" -- request more here

nextXid :: Connection -> IO (Maybe Xid)
nextXid c = atomically $ do
              let tv =  conn_resource_ids c
              xids <- readTVar tv
              case xids of
                [] -> return Nothing
                (x:xs) -> do
                   writeTVar tv xs
                   return . return $ x


pollForEvent :: Connection -> IO (Maybe SomeEvent)
pollForEvent c = atomically $ pollTChan $ conn_event_queue c

waitForEvent :: Connection -> IO SomeEvent
waitForEvent c = atomically $ readTChan $ conn_event_queue c
                
pollForError :: Connection -> IO (Maybe SomeError)
pollForError c = atomically $ pollTChan $ conn_error_queue c

waitForError :: Connection -> IO SomeError
waitForError c = atomically $ readTChan $ conn_error_queue c

pollTChan :: TChan a -> STM (Maybe a)
pollTChan tc = do
  empty <- isEmptyTChan tc
  if empty then return Nothing
   else Just `liftM` readTChan tc


-- | If you don't feel like writing error handlers, but at least want to know that
-- one happened for debugging purposes, call this to have execution come to an
-- abrupt end if an error is received.
setCrashOnError :: Connection -> IO ()
setCrashOnError c = do
  forkIO $ do
    waitForError c
    error "Received error from server.  Crashing."
  return ()


-- Any response from the server is first read into
-- this type.
data GenericReply = GenericReply
    {grep_response_type :: ResponseType
    ,grep_error_code :: Word8
    ,grep_sequence :: Word16
    ,grep_reply_length :: Word32 -- only useful for replies
    }

data ResponseType
    = ResponseTypeEvent Word8
    | ResponseTypeError
    | ResponseTypeReply

instance Deserialize GenericReply where
    deserialize = do
      type_flag <- deserialize
      let rType = case type_flag of
                    0 -> ResponseTypeError
                    1 -> ResponseTypeReply
                    _ -> ResponseTypeEvent type_flag
      code <- deserialize
      sequence <- deserialize
      reply_length <- deserialize
      return $ GenericReply rType code sequence reply_length



-- state maintained by the read loop
data ReadLoop = ReadLoop
    {read_error_queue :: TChan SomeError -- write only
    ,read_event_queue :: TChan SomeEvent -- write only
    ,read_input_queue :: Handle -- read only
    ,read_reps :: TChan PendedReply -- read only
    ,read_config :: ConnectionConfig
    ,read_extensions :: TVar ExtensionMap
    }

---- Processing for events/errors

-- reverse-lookup infrastructure for extensions.  Not pretty or
-- maybe not even fast. But it is straight-forward.
queryExtMap :: (QueryExtensionReply -> Word8)
            -> ReadLoop -> Word8 -> IO (Maybe (ExtensionId, Word8))
queryExtMap f r code = do
  ext_map <- atomically . readTVar $ read_extensions r
  return $ findFromCode ext_map
 where findFromCode xmap = foldr go Nothing (M.toList xmap)
       go (ident, extInfo) old
           | num <= code =
               case old of
                 Just (_oldIndent, oldNum) |  oldNum > num -> old
                 _ -> Just (ident, num)
           | otherwise = old
         where num = f extInfo

-- | Returns the extension id and the base event code
extensionIdFromEventCode :: ReadLoop -> Word8
                         -> IO (Maybe (ExtensionId, Word8))
extensionIdFromEventCode = queryExtMap first_event_QueryExtensionReply

-- | Returns the extension id and the base error code
extensionIdFromErrorCode :: ReadLoop -> Word8
                         -> IO (Maybe (ExtensionId, Word8))
extensionIdFromErrorCode = queryExtMap first_error_QueryExtensionReply


bsToError :: ReadLoop
          -> ByteString -- ^Raw data
          -> Word8 -- ^Error code
          -> IO SomeError
bsToError _r chunk code | code < 128 = case deserializeError code of
     Nothing -> return . toError . UnknownError $ chunk
     Just getAction -> return $ runGet getAction chunk
bsToError r chunk code
    = extensionIdFromErrorCode r code >>= \errInfo -> case errInfo of
         Nothing -> return . toError . UnknownError $ chunk
         Just (extId, baseErr) ->
             case errorDispatch extId (code - baseErr) of
               Nothing -> return . toError . UnknownError $ chunk
               Just getAction -> return $ runGet getAction chunk
                 

bsToEvent :: ReadLoop
          -> ByteString -- ^Raw data
          -> Word8 -- ^Event code
          -> IO SomeEvent
bsToEvent _r chunk code | code < 64 = case deserializeEvent code of
    Nothing -> return . toEvent . UnknownEvent $ chunk
    Just getAction -> return $ runGet getAction chunk
bsToEvent r chunk code
    = extensionIdFromEventCode r code >>= \evInfo -> case evInfo of
         Nothing -> return . toEvent . UnknownEvent $ chunk
         Just (extId, baseEv) ->
             case eventDispatch extId (code - baseEv) of
               Nothing -> return . toEvent . UnknownEvent $ chunk
               Just getAction -> return $ runGet getAction chunk

deserializeInReadLoop rl = deserialize

readBytes :: ReadLoop -> Int -> IO ByteString
readBytes rl n = BS.hGet (read_input_queue rl) n

-- the read loop slurps bytes off of the handle, and places
-- them into the appropriate shared structure.
readLoop :: ReadLoop -> IO ()
readLoop rl = do
  chunk <- readBytes rl 32
  let genRep = flip runGet chunk $ deserialize
               
  case grep_response_type genRep of
    ResponseTypeError -> readLoopError rl genRep chunk
    ResponseTypeReply -> readLoopReply rl genRep chunk
    ResponseTypeEvent _ -> readLoopEvent rl genRep chunk
  readLoop rl

-- handle a response to a request
readLoopReply :: ReadLoop -> GenericReply -> ByteString -> IO ()
readLoopReply rl genRep chunk = do

  -- grab the rest of the response bytes
  let rlength = grep_reply_length genRep
  extra <- readBytes rl $ fromIntegral $ 4 * rlength
  let bytes = chunk `BS.append` extra

  -- place the response into the pending reply TMVar, or discard it
  atomically $ do
    nextPend <- readTChan $ read_reps rl
    if (pended_sequence nextPend) == (grep_sequence genRep)
     then putReceipt (pended_reply nextPend) $ Right bytes
     else unGetTChan (read_reps rl) nextPend


-- take the bytes making up the error response, shove it in
-- a queue.
--
-- If the error corresponds to one of the pending replies,
-- place the error into the pending reply TMVar instead.
readLoopError rl genRep chunk = do
  let errorCode = grep_error_code genRep

  err <- bsToError rl chunk errorCode
  atomically $ do
    nextPend <- readTChan $ read_reps rl
    if (pended_sequence nextPend) == (grep_sequence genRep)
     then putReceipt (pended_reply nextPend) $ Left err 
     else do
       unGetTChan (read_reps rl) nextPend
       writeTChan (read_error_queue rl) err

-- take the bytes making up the event response, shove it in
-- a queue
readLoopEvent rl genRep chunk = do
    ev <- bsToEvent rl chunk eventCode
    atomically $ writeTChan (read_event_queue rl) ev

 where eventCode = case grep_response_type genRep of
                     ResponseTypeEvent w -> w .&. 127

-- | Connect to the the default display.
connect :: IO (Maybe Connection)
connect = connectTo ""

-- | Connect to the display specified.
-- The string must be of the format used in the
-- DISPLAY environment variable.
connectTo :: String -> IO (Maybe Connection)
connectTo display = do
  (h, xau, dispName) <- open display
  hSetBuffering h NoBuffering
  mkConnection h xau dispName

-- | Returns the information about what we originally tried to
-- connect to.
displayInfo :: Connection -> DispName
displayInfo = conn_dispInfo

-- Handshake with the server
-- parse result of handshake
-- launch the thread which holds the handle for reading
mkConnection :: Handle -> Maybe Xauth -> DispName -> IO (Maybe Connection)
mkConnection hnd auth dispInfo = do
  errorQueue <- newTChanIO
  eventQueue <- newTChanIO
  replies <- newTChanIO
  sequence <- initialSequence
  extensions <- newTVarIO mempty

  wrappedHandle <- newMVar hnd 

  confM <- handshake hnd auth
  if isNothing confM then return Nothing else do
  let Just conf = confM

  rIds <- newTVarIO $ resourceIds conf

  let rlData = ReadLoop errorQueue eventQueue hnd replies conf extensions
  
  readTid <- forkIO $ readLoop rlData

  return $ Just $ 
     Connection
      errorQueue
      eventQueue
      readTid
      wrappedHandle
      replies
      conf
      sequence
      rIds
      extensions
      dispInfo

resourceIds :: ConnectionConfig -> [Xid]
resourceIds cc = resourceIdsFromSetup $ conf_setup cc

resourceIdsFromSetup :: Setup -> [Xid]
resourceIdsFromSetup s =
    let base = resource_id_base_Setup s
        mask = resource_id_mask_Setup s
        max = mask
        step = mask .&. (-mask)
    in map MkXid $ map (.|. base) [0,step .. max]

-- first 8 bytes of the response from the setup request
data GenericSetup = GenericSetup
                  {setup_status :: SetupStatus
                  ,setup_length :: Word16
                  }
                    deriving Show

instance Deserialize GenericSetup where
    deserialize = do
      status <- deserialize
      skip 5
      length <- deserialize
      return $ GenericSetup status length 

data SetupStatus = SetupFailed | SetupAuthenticate | SetupSuccess
 deriving Show

instance Deserialize SetupStatus where
    deserialize = wordToStatus `liftM` deserialize
        where wordToStatus :: Word8 -> SetupStatus
              wordToStatus 0 = SetupFailed
              wordToStatus 1 = SetupSuccess
              wordToStatus 2 = SetupAuthenticate
              wordToStatus n = error $ 
                     "Unkonwn setup status flag: " ++ show n

-- send the setup request to the server,
-- receive the setup response
handshake :: Handle -> Maybe Xauth -> IO (Maybe ConnectionConfig)
handshake hnd auth = do

  -- send setup request
  let requestChunk =  runPut $ serialize $ setupRequest auth
  BS.hPut hnd $ requestChunk

  -- grab an 8-byte chunk to get the response type and size
  firstChunk <- BS.hGet hnd 8

  let genSetup = runGet deserialize firstChunk

  -- grab the rest of the setup response
  secondChunk <- BS.hGet hnd $ fromIntegral $ (4 *) $ setup_length genSetup
  let setupBytes = firstChunk `BS.append` secondChunk

  -- handle the response type
  case setup_status genSetup of
    SetupFailed -> do
       let failed = runGet deserialize setupBytes
           failMessage = map castCCharToChar (reason_SetupFailed failed)
       hPutStrLn stderr failMessage
       return Nothing
    SetupAuthenticate -> do
       let auth = runGet deserialize setupBytes
           authMessage = map castCCharToChar (reason_SetupAuthenticate auth)
       hPutStrLn stderr authMessage
       return Nothing
    SetupSuccess -> do
       let setup = runGet deserialize setupBytes
       return . return $ ConnectionConfig setup
       
padBS n = BS.replicate n 0

initialSequence :: IO (TVar SequenceId)
initialSequence = newTVarIO 1

setupRequest :: Maybe Xauth -> SetupRequest
setupRequest auth = MkSetupRequest
                  (fromIntegral $ byteOrderToNum byteOrder)
                  11       -- major version
                  0        -- minor version
                  anamelen -- auth name length
                  adatalen -- auth data length
                  -- TODO this manual padding is a horrible hack, it should be
                  -- done by the serialization instance
                  (aname ++ replicate (requiredPadding anamelen) 0)
                           -- auth name
                  (adata ++ replicate (requiredPadding adatalen) 0)
                           -- auth data
 where
    (anamelen, aname, adatalen, adata) = case auth of
        Nothing -> (0, [], 0, [])
        Just (Xauth n d) -> (genericLength n, n, genericLength d, d)


-- | I plan on deprecating this one soon, but until I put together
-- some sort of 'utils' package, it will live here.
--
-- Given a connection, this function returns the root window of the
-- first screen.
--
-- If your display string specifies a screen other than the first,
-- this probably doesnt do what you want.
getRoot :: Connection -> WINDOW
getRoot = root_SCREEN . head . roots_Setup . conf_setup . conn_conf