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, 54 insertions, 10 deletions

diff --git a/src/ColorCache.hs b/src/ColorCache.hs
index 9a76a90..6313a98 100644
--- a/src/ColorCache.hs
+++ b/src/ColorCache.hs
@@ -7,7 +7,7 @@
 --
 -- Maintainer: jao@gnu.org
 -- Stability: unstable
--- Portability: portable
+-- Portability: unportable
 -- Created: Mon Sep 10, 2012 00:27
 --
 --
@@ -15,23 +15,25 @@
 --
 ------------------------------------------------------------------------------
 
+#if defined XFT
+
+module ColorCache(withColors, withDrawingColors) where
+
+import MinXft
+import Graphics.X11.Xlib
+
+#else
 module ColorCache(withColors) where
 
-#if defined XFT
--- import Graphics.X11.Xft
 #endif
+
 import Data.IORef
-import Graphics.X11.Xlib
 import System.IO.Unsafe (unsafePerformIO)
 import Control.Monad.Trans (MonadIO, liftIO)
 import Control.Exception (SomeException, handle)
 
-data DynPixel = DynPixel { allocated :: Bool
-                         , pixel     :: Pixel
-                         }
+data DynPixel = DynPixel Bool Pixel
 
--- | Get the Pixel value for a named color: if an invalid name is
--- given the black pixel will be returned.
 initColor :: Display -> String -> IO DynPixel
 initColor dpy c = handle black $ (initColor' dpy c)
   where
@@ -63,4 +65,46 @@ initColor' dpy c = do
 withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a
 withColors d cs f = do
   ps <- mapM (liftIO . initColor d) cs
-  f $ map pixel ps
+  f $ map (\(DynPixel _ pixel) -> pixel) ps
+
+#ifdef XFT
+
+type AXftColorCache = [(String, AXftColor)]
+{-# NOINLINE xftColorCache #-}
+xftColorCache :: IORef AXftColorCache
+xftColorCache = unsafePerformIO $ newIORef []
+
+getXftCachedColor :: String -> IO (Maybe AXftColor)
+getXftCachedColor name = lookup name `fmap` readIORef xftColorCache
+
+putXftCachedColor :: String -> AXftColor -> IO ()
+putXftCachedColor name cptr =
+  modifyIORef xftColorCache $ \c -> (name, cptr) : c
+
+initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor
+initAXftColor' d v cm c = do
+  cc <- getXftCachedColor c
+  c' <- case cc of
+          Just col -> return col
+          _        -> do c'' <- mallocAXftColor d v cm c
+                         putXftCachedColor c c''
+                         return c''
+  return c'
+
+initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor
+initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c)
+  where
+    black :: SomeException -> IO AXftColor
+    black = (const $ initAXftColor' d v cm "black")
+
+withDrawingColors :: -- MonadIO m =>
+                     Display -> Drawable -> String -> String
+                    -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO ()
+withDrawingColors dpy drw fc bc f = do
+  let screen = defaultScreenOfDisplay dpy
+      colormap = defaultColormapOfScreen screen
+      visual = defaultVisualOfScreen screen
+  fc' <- initAXftColor dpy visual colormap fc
+  bc' <- initAXftColor dpy visual colormap bc
+  withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc'
+#endif