Avoiding X server leaks with XftColor cache

This patch is a first complete solution to the long-standing memory
leak (on the X server side) caused by repeteadly asking the server to
allocate XftColor instances.  Despite the fact that we were freeing
them, the server didn't seem to care... this was also happening for
non-Xft Colors, and solved in the same way we'd done here, i.e., by
caching XftColor instances.

And additional complication has been that Graphics.X11.Xft doesn't
export any function to create and retain an XftColor, nor the
necessary datatype constructors to write a compatible version outside
the module (there's no way to construct an XftColor instance to pass
to the other functions in the library).  So, i've created my own lite
version of the whole module, until the day it supports XftColor
creation.

1 files changed, 139 insertions, 0 deletions

diff --git a/src/MinXft.hsc b/src/MinXft.hsc
new file mode 100644
index 0000000..478b94a
--- /dev/null
+++ b/src/MinXft.hsc
@@ -0,0 +1,139 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+------------------------------------------------------------------------------
+-- |
+-- Module: MinXft
+-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz
+--            (c) Clemens Fruhwirth <clemens@endorphin.org> 2007
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: jao@gnu.org
+-- Stability: unstable
+-- Portability: unportable
+-- Created: Mon Sep 10, 2012 18:12
+--
+--
+-- Pared down Xft library, based on Graphics.X11.Xft and providing
+-- explicit management of XftColors, so that they can be cached.
+--
+-- Most of the code is lifted from Clemens's.
+--
+------------------------------------------------------------------------------
+
+module MinXft ( AXftColor
+              , AXftDraw
+              , AXftFont
+              , mallocAXftColor
+              , freeAXftColor
+              , withAXftDraw
+              , drawXftString
+              , drawXftRect
+              , openAXftFont
+              , closeAXftFont
+              , xftTxtExtents
+              , xft_ascent
+              , xft_descent
+              , xft_height
+              )
+
+where
+
+import Graphics.X11
+import Graphics.X11.Xlib.Types
+import Graphics.X11.Xrender
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import Codec.Binary.UTF8.String as UTF8
+
+#include <X11/Xft/Xft.h>
+
+-- Color Handling
+
+newtype AXftColor = AXftColor (Ptr AXftColor)
+
+foreign import ccall "XftColorAllocName"
+    cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool)
+
+-- this is the missing bit in X11.Xft, not implementable from the
+-- outside because XftColor does not export a constructor.
+mallocAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor
+mallocAXftColor d v cm n = do
+  color <- mallocBytes (#size XftColor)
+  withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color)
+  return (AXftColor color)
+
+foreign import ccall "XftColorFree"
+  freeAXftColor :: Display -> Visual -> Colormap -> AXftColor -> IO ()
+
+-- Font handling
+
+newtype AXftFont = AXftFont (Ptr AXftFont)
+
+xft_ascent :: AXftFont -> IO Int
+xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent}
+
+xft_descent :: AXftFont -> IO Int
+xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent}
+
+xft_height :: AXftFont -> IO Int
+xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height}
+
+foreign import ccall "XftTextExtentsUtf8"
+  cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO ()
+
+xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo
+xftTxtExtents d f string =
+    withArrayLen (map fi (UTF8.encode string)) $
+    \len str_ptr -> alloca $
+    \cglyph -> do
+      cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph
+      peek cglyph
+
+foreign import ccall "XftFontOpenName"
+  c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont
+
+openAXftFont :: Display -> Screen -> String -> IO AXftFont
+openAXftFont dpy screen name =
+    withCAString name $
+      \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname
+
+foreign import ccall "XftFontClose"
+  closeAXftFont :: Display -> AXftFont -> IO ()
+
+-- Drawing
+
+fi :: (Integral a, Num b) => a -> b
+fi = fromIntegral
+
+newtype AXftDraw = AXftDraw (Ptr AXftDraw)
+
+foreign import ccall "XftDrawCreate"
+  c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw
+
+foreign import ccall "XftDrawDestroy"
+  c_xftDrawDestroy :: AXftDraw -> IO ()
+
+withAXftDraw :: Display -> Drawable -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a
+withAXftDraw d p v c act = do
+  draw <- c_xftDrawCreate d p v c
+  a <- act draw
+  c_xftDrawDestroy draw
+  return a
+
+foreign import ccall "XftDrawStringUtf8"
+  cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO ()
+
+drawXftString :: (Integral a1, Integral a) =>
+                 AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO ()
+drawXftString d c f x y string =
+    withArrayLen (map fi (UTF8.encode string))
+      (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len))
+
+foreign import ccall "XftDrawRect"
+  cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()
+
+drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) =>
+               AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO ()
+drawXftRect draw color x y width height =
+  cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height)