aslatter / xhb

X Haskell Bindings

The goal of this project is to provide a Haskell library for interacting with an X server, using XCB as a model.

The bedrock of the library will be datatypes and serialization code automatically generated from the 'xproto' XML files:

To build the generated files execute:

chmod +x generate.sh
./generate.sh

The generated routines are in the patched directory.

To build the .cabal file to install the library run:

chmod +x cabalize.sh
./cabalize.sh

To test that the generated files build successfully execute:

cabal configure
cabal build

Details

The tools we use to do the code generation are in the build-tools folder.

We require the packages xcb-types, haskell-src and HStringTemplate, which are installed into a Cabal sandbox in the 'build-tools' folder.

How To Hack

There are three bash scripts that live in the top-level of this project:

generate.sh

This file generates Haskell source from the X Protocol XML description into the directory generated.

If the file patch is found, it is used to patch the generated files. The result of patching is placed into the directory patched.

makepatch.sh

The difference between the generated directory and working directory is saved into the file patch. The script generate.sh is then called.

parse.sh

The XML files are parsed and then pretty-printed to a human-readable form into the directory parsed.

The intent is that the results of parsing can be isolated from the results of code generation to make finding bugs easier.

cabalize.sh

Creates a package description (Cabal) file for the XHB project. You'd be best running generate.sh before trying anything like cabal install or cabal sdist.

clean.sh

Deletes the Haskell programs that drive generate.sh, parse.sh and cabalize.sh. You'll need to run this or the shell scripts won't notice any changes you've made to the underlying Haskell code.

version.sh

Defines the xproto version we will attempt to build against. If the XML files for this version are not in the resources directory, they will be downloaded.

xhb's Issues

Any error will trigger STM locking.

https://github.com/Magicloud/WMF/tree/dev is my code. I could not figure out why.

upgrade?

Hello,

Thanks for sharing xhb.

The latest version of libxcb is 1.11.1. Just want to check if there is any reason there has not been an upgrade since 1.6.

Thanks

Use 'cabal sandbox' for build-tools

If we use a sandbox for the build-tools we don't have to rely on having build-tool dependencies already installed - we can install them into the sandbox.

readLoop hangs if there is an error without a pending reply

Problem
I believe I stumbled onto the same/related problem as #9 (and maybe #6): Whenever my event handling code causes an X11 Error (like mapWindow causing a BadWindow) it seems like no further errors or events are handled by my xhb client (and yes, I run the error and event handler separate from the main "thread" using forkIO).

Hand-waivy explanation
It seems there are two types of requests - those expecting a reply (like listExtensions) and those who don't (like mapWindow). The root cause of the problem seems to lie within the readLoop and their corresponding readLoopError (and readLoopReply) functions. Whenever an error/reply/event is read from the connection it's fed to either readLoopError/readLoopReply/readLoopEvent synchronously. Now, in case of an error readLoopError will try to check if the error is in reply of a previous request (by using readTChan one the pending replies queue, which will block if the queue is empty!). And there lies the problem - when I am sending a mapWindow (i.e. a request without expecting a reply) and cause an error, the readLoopError function will hang indefinitely at readTChan (until you do a request which is expecting a reply, which will fill up the "pending reply" queue) and thus won't return to the eventLoop and in turn block all event/error handling.

Steps to reproduce
It's quite easy to reproduce using xhb's Demo.hs, simply change the handleEvent function to produce an error and you'll only see the first event (likely EnterNotify) and then it'll hang:

-- print events from the queue
handleEvent ::X.Connection -> IO ()
handleEvent c = do
  forkIO $ forever $ do
      e <- X.waitForEvent c
      putStrLn $ showEvent e
      -- deliberately cause an error by mapping an invalid window
      wid <- X.newResource c
      X.mapWindow c wid
      -- from here on the readLoop will "hang"
      -- to unblock it, simply send a dummy request
      -- which expects a reply, like this:
      -- _ <- X.listExtensions c
      return ()

Possible solution
Instead of using readTChan in readLoopError (and maybe readLoopReply) use tryReadTChan in order to not block the readLoop on an empty pending reply queue. In case of tryReadTChan returning Nothing simply push the error to the error queue and return. So far it seems to work with: requests not expecting a reply, requests expecting a reply and also expecting a reply but causing an error.

Not sure of all edge cases though, I've only dug deep enough to fix my own use cases.

Eq, Ord and Enum instances for Bitmasks, SimpleEnums and the like

This would be pretty handy for things like [MapIndexShift .. MapIndex5] and comparing ButtonIndex or KeyButMask values.
These are just examples I stumbled upon, while using XHB.
Comparing Xids like Window and Drawable without using fromXid $ toXid would be helpful too.
I think it's safe (and sensible) to generate Eq, Ord, and Enum instances for all CARD{8,16,32} values.

RandR Deserialisation Error

I am getting an error when I try to access the returned Graphics.XHB.Gen.RandR.GetScreenInfoReply value.

When I try and run my program, I get the following output:

HAS XRANDR!
jrandr: Data.Binary.Get.runGet at position 72: not enough bytes

I am using version 0.6.2015.8.1.

Here is my program:

module Main where

import Foreign.C.String
import qualified Data.ByteString.Lazy as BS
import Control.Concurrent
import Control.Monad

import qualified Graphics.XHB as X
import qualified Graphics.XHB.Gen.RandR as R

import System.IO

main = do
  connectionM <- X.connect

  case connectionM of
    Nothing -> putStrLn "failed to get connection"
    Just c -> randr c

randr :: X.Connection -> IO ()
randr c = do

  listReceipt <- X.listExtensions c

  replyOrError <- X.getReply listReceipt
  let extensions = case replyOrError of
                        Left e -> error $ "error in extensions request" ++ show e
                        Right listRep ->  listExtensionNames listRep

  screenInfoReceipt <-
    if "RANDR" `elem` extensions
       then putStrLn "HAS XRANDR!" >> R.getScreenInfo c (X.getRoot c)
       else error "NO XRANDR :-("

  replyOrError <- X.getReply screenInfoReceipt
  let info = case replyOrError of
                  Left e -> error (show e)
                  Right info -> info

  print info

listExtensionNames :: X.ListExtensionsReply -> [String]
listExtensionNames = map strToString . X.names_ListExtensionsReply

strToString :: X.STR -> String
strToString = map castCCharToChar . X.name_STR

ConfigureWindow produces MkLengthError

Hello,

I've written a rudimentary program which does issues MapWindow and ConfigureWindow Requests when it receives MapRequest and ConfigureRequest events.

The problem I'm observing is specifically with xterm. I start an Xnest instance, run my program and start xterm. Xterm produces two ConfigureRequest events and one MapRequest.

For the first ConfigureRequest event the subsequent ConfigureWindow request succeeds, but for the second I get a LengthError for the window value.
Which is very weird, because the window xid is actually correct (I take it directly from the event).

I've tried a simple C program which does the same and even bound some calls via FFI to try it out. Both tests were successful, hence I suspect a bug in XHB.

Below is the XHB based sample program.

{-# LANGUAGE ExistentialQuantification #-}

import Data.Maybe
import System.IO
import System.IO.Unsafe
import Control.Monad.Reader (void)
import Control.Monad (forever)
import Graphics.XHB
import Graphics.XHB.Connection.Open

main :: IO ()
main = do
    (handle, xauth, dispname) <- open ""
    mkConnection handle xauth dispname >>= run handle

run :: Handle -> Maybe Connection -> IO ()
run _ Nothing = return ()
run connHandle (Just connection) = do
    changeWindowAttributes connection (getRoot connection)
        $ toValueParam [(CWEventMask, toMask [ EventMaskSubstructureRedirect
                                             , EventMaskSubstructureNotify
                                             ])]

    forever $! waitForEvent connection >>= showEvent connection

data EventHandler c b = forall a . Event a => EventHandler (c -> a -> b)

dispatch :: Connection -> [EventHandler Connection (IO ())] -> SomeEvent -> IO ()
dispatch _ [] _ = return ()
dispatch c (EventHandler handler:hs) e = do
    maybe (print "Nothing Event") (handler c) (fromEvent e)
    dispatch c hs e

handleMapRequest :: Connection -> MapRequestEvent -> IO ()
handleMapRequest c e = do
    print e
    mapWindow c (window_MapRequestEvent e)
    void $ getInputFocus c

handleConfigureRequest :: Connection -> ConfigureRequestEvent -> IO ()
handleConfigureRequest c e = do
    print e
    configureWindow c cw
    pollForError c >>= handleError
    void $ getInputFocus c

    where
    cw = (MkConfigureWindow window mask values)

    handleError Nothing = print "ConfigureWindow SUCCESS"
    handleError (Just se) = putStrLn ("ConfigureWindow ERROR: " ++ show se)

    window = window_ConfigureRequestEvent e
    mask = toMask $ value_mask_ConfigureRequestEvent e
    values = toValueParam $ copyValues (value_mask_ConfigureRequestEvent e)

    copyValues [] = []
    copyValues (ConfigWindowX:ms) = (ConfigWindowX, fromIntegral $ x_ConfigureRequestEvent e) : copyValues ms
    copyValues (ConfigWindowY:ms) = (ConfigWindowY, fromIntegral $ y_ConfigureRequestEvent e) : copyValues ms
    copyValues (ConfigWindowWidth:ms) = (ConfigWindowWidth, fromIntegral $ width_ConfigureRequestEvent e) : copyValues ms
    copyValues (ConfigWindowHeight:ms) = (ConfigWindowHeight, fromIntegral $ height_ConfigureRequestEvent e) : copyValues ms
    copyValues (_:ms) = copyValues ms

showEvent :: Connection -> SomeEvent -> IO ()
showEvent c = tryEvents c hs (print showEventBase)
    where hs = [ EventHandler handleMapRequest
               , EventHandler handleConfigureRequest
               ]

showEventBase :: String
showEventBase = "unhandled event"

tryEvents :: Connection -> [EventHandler Connection b] -> b -> SomeEvent -> b
tryEvents c hs z ev =
    case foldr tryEv Nothing hs of
        Nothing -> z
        Just x -> x
 where tryEv _ j@Just{} = j
       tryEv h Nothing = case h of
          EventHandler fn -> do
            ev' <- fromEvent ev
            return $ fn c ev'

DestroyNotify: thread blocked indefinitely in an STM transaction

I get repeatable BlockedIndefinitelyOnSTM exceptions whenever a client exits and a DestroyNotify event is issued.
Edit:
The error happens only if the window which generates the DestroyNotify event had its focus set with SetInputFocus. If then a request (e.g. ConfigureWindow) is issued prior to the DestroyNotify event, e.g. in response to a LeaveNotify event on the now non-existing window, the error will occur.

Edit 2:
As a workaround I've getInputFocus c >>= void . getReply in the LeaveNotify event handler. Now the error doesn't occur anymore.

Proposition: Change record function names to dataStructure_member

I'd like to propose to rename the record functions with the data structure name first.
E.g.: root_x_MotionNotifyEvent to motionNotifyEvent_root_x.
This has two advantages:
First, it reflects the namespace -> member mapping better.
Second, if you use a code completion engine, starting to type motionNo.. will automatically show you a list of all members of the data structure.

Since XHB is still in an early stage, I think it would not be to worse to change the API.

Create 'clean' shell script

This should clean up the build-tools project and any generated files (but not downloaded resources).

Build failures

I've noticed build failures in the latest xhb-0.6.2015.8.1 due to missing bounds on network and binary. As a Hackage trustee, I have made a revision to fix this: https://hackage.haskell.org/package/xhb-0.6.2015.8.1/revisions/.

Older versions also have missing bounds, but haven't figured out yet what these bounds should be. For example:

$ cabal install xhb --constraint 'xhb < 0.6' --constraint 'network < 3'
Resolving dependencies...
Build profile: -w ghc-8.10.7 -O1
In order, the following will be built (use -v for more details):
 - xhb-0.5.2014.4.10 (lib:xhb) (requires build)
Starting     xhb-0.5.2014.4.10 (all, legacy fallback)
Building     xhb-0.5.2014.4.10 (all, legacy fallback)

Failed to build xhb-0.5.2014.4.10.
Build log (
/home/simon/.cabal/logs/ghc-8.10.7/xhb-0.5.2014.4.10-1c2a99b6c201c64a5ff28269805ea5b5ed99dee4ab5ca3e2433ce3c8e1f83405.log
):
Warning: xhb.cabal:28:29: version operators used. To use version operators the
package needs to specify at least 'cabal-version: >= 1.8'.
Configuring xhb-0.5.2014.4.10...
Preprocessing library for xhb-0.5.2014.4.10..
Building library for xhb-0.5.2014.4.10..
[ 1 of 61] Compiling Graphics.XHB.Connection.Auth ( Graphics/XHB/Connection/Auth.hs, dist/build/Graphics/XHB/Connection/Auth.o, dist/build/Graphics/XHB/Connection/Auth.dyn_o )

Graphics/XHB/Connection/Auth.hs:11:1: warning: [-Wdeprecations]
    Module ‘Network.BSD’ is deprecated:
      This platform dependent module is no longer supported.
   |
11 | import Network.BSD (getHostName)
   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Graphics/XHB/Connection/Auth.hs:23:27: warning: [-Wdeprecations]
    In the use of ‘getHostName’ (imported from Network.BSD):
    Deprecated: "This platform dependent module is no longer supported."
   |
23 |         f x | isLocal x = getHostName >>= \h ->
   |                           ^^^^^^^^^^^
[ 2 of 61] Compiling Graphics.XHB.Connection.Open ( Graphics/XHB/Connection/Open.hs, dist/build/Graphics/XHB/Connection/Open.o, dist/build/Graphics/XHB/Connection/Open.dyn_o )

Graphics/XHB/Connection/Open.hs:86:5: error:
    • Non type-variable argument
        in the constraint: Text.Parsec.Prim.Stream s m Char
      (Use FlexibleContexts to permit this)
    • When checking the inferred type
        eat :: forall s (m :: * -> *) b u.
               Text.Parsec.Prim.Stream s m Char =>
               Char -> b -> Text.Parsec.Prim.ParsecT s u m b
      In an equation for ‘parseDisplay’:
          parseDisplay xs
            = parse exp "" xs
            where
                exp
                  = do p <- option "" (try $ skip '/') <?> "protocol"
                       ....
                eat c s = char c >> return s
                anyExcept c = many1 (noneOf [c])
                skip c = anyExcept c >>= eat c
                ....
   |
86 |     eat c s = char c >> return s
   |     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Graphics/XHB/Connection/Open.hs:87:5: error:
    • Non type-variable argument
        in the constraint: Text.Parsec.Prim.Stream s m Char
      (Use FlexibleContexts to permit this)
    • When checking the inferred type
        anyExcept :: forall s (m :: * -> *) u.
                     Text.Parsec.Prim.Stream s m Char =>
                     Char -> Text.Parsec.Prim.ParsecT s u m [Char]
      In an equation for ‘parseDisplay’:
          parseDisplay xs
            = parse exp "" xs
            where
                exp
                  = do p <- option "" (try $ skip '/') <?> "protocol"
                       ....
                eat c s = char c >> return s
                anyExcept c = many1 (noneOf [c])
                skip c = anyExcept c >>= eat c
                ....
   |
87 |     anyExcept c = many1 (noneOf [c])
   |     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
cabal: Failed to build xhb-0.5.2014.4.10. See the build log above for details.

If I'd know which GHC version introduced the requirement of FlexibleContexts for this code, I could add a corresponding bound on base.

Stackage

Hi Antoine,

would you mind adding xhb to stackage?

It's compiling very well for me on the current snapshot (nightly-2015-09-02).

Thanks!