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.

4 files changed, 218 insertions, 34 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
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)
diff --git a/src/XUtil.hsc b/src/XUtil.hsc
index 7683387..21dcf3e 100644
--- a/src/XUtil.hsc
+++ b/src/XUtil.hsc
@@ -2,8 +2,8 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XUtil
--- Copyright   :  (C) 2007 Andrea Rossato
---                (C) 2011, 2012 Jose Antonio Ortega Ruiz
+-- Copyright   :  (C) 2011, 2012 Jose Antonio Ortega Ruiz
+--                (C) 2007 Andrea Rossato
 -- License     :  BSD3
 --
 -- Maintainer  :  jao@gnu.org
@@ -48,11 +48,11 @@ import qualified System.IO as UTF8 (readFile,hGetLine)
 #endif
 #if defined XFT
 import Data.List
-import Graphics.X11.Xft
+import MinXft
 import Graphics.X11.Xrender
 #endif
 
-import ColorCache (withColors)
+import ColorCache
 
 readFileSafe :: FilePath -> IO String
 #if defined XFT || defined UTF8
@@ -72,7 +72,7 @@ hGetLineSafe = hGetLine
 data XFont = Core FontStruct
            | Utf8 FontSet
 #ifdef XFT
-           | Xft  XftFont
+           | Xft  AXftFont
 #endif
 
 -- | When initFont gets a font name that starts with 'xft:' it switchs
@@ -118,11 +118,11 @@ initUtf8Font d s = do
             fallBack = const $ createFontSet d miscFixedFont
 
 #ifdef XFT
-initXftFont :: Display -> String -> IO XftFont
+initXftFont :: Display -> String -> IO AXftFont
 initXftFont d s = do
   setupLocale
-  f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s)
-  addFinalizer f (xftFontClose d f)
+  f <- openAXftFont d (defaultScreenOfDisplay d) (drop 4 s)
+  addFinalizer f (closeAXftFont d f)
   return f
 #endif
 
@@ -131,7 +131,7 @@ textWidth _   (Utf8 fs) s = return $ fi $ wcTextEscapement fs s
 textWidth _   (Core fs) s = return $ fi $ Xlib.textWidth fs s
 #ifdef XFT
 textWidth dpy (Xft xftdraw) s = do
-    gi <- xftTextExtents dpy xftdraw s
+    gi <- xftTxtExtents dpy xftdraw s
     return $ xglyphinfo_xOff gi
 #endif
 
@@ -146,8 +146,8 @@ textExtents (Utf8 fs) s = do
   return (ascent, descent)
 #ifdef XFT
 textExtents (Xft xftfont) _ = do
-  ascent  <- fi `fmap` xftfont_ascent  xftfont
-  descent <- fi `fmap` xftfont_descent xftfont
+  ascent  <- fi `fmap` xft_ascent  xftfont
+  descent <- fi `fmap` xft_descent xftfont
   return (ascent, descent)
 #endif
 
@@ -168,20 +168,14 @@ printString d p (Utf8 fs) gc fc bc x y s =
 
 #ifdef XFT
 printString dpy drw fs@(Xft font) _ fc bc x y s = do
-  let screen   = defaultScreenOfDisplay dpy
-      colormap = defaultColormapOfScreen screen
-      visual   = defaultVisualOfScreen screen
   (a,d)  <- textExtents fs s
-  gi <- xftTextExtents dpy font s
-  withXftDraw dpy drw visual colormap $ \draw ->
-    (withXftColorName dpy visual colormap bc $ \color ->
-      xftDrawRect draw color (x + 1 - fi (xglyphinfo_x gi))
-                             (y - (a + d) + 1)
-                             (xglyphinfo_xOff gi)
-                             (a + d)
-                             ) >>
-    (withXftColorName dpy visual colormap fc $ \color ->
-        xftDrawString draw color font x (y - 2) s)
+  gi <- xftTxtExtents dpy font s
+  withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' ->
+    (drawXftRect draw bc' (x + 1 - fi (xglyphinfo_x gi))
+                          (y - (a + d) + 1)
+                          (xglyphinfo_xOff gi)
+                          (a + d)) >>
+    (drawXftString draw fc' font x (y - 2) s)
 #endif
 
 
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 3d17fad..f8db6a5 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -51,6 +51,10 @@ import Window
 import XUtil
 import ColorCache
 
+#ifdef XFT
+import Graphics.X11.Xft
+#endif
+
 #ifdef DBUS
 import IPC.DBus
 #endif
@@ -78,6 +82,9 @@ runX xc f = runReaderT f xc
 -- | Starts the main event loop and threads
 startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO ()
 startLoop xcfg@(XConf _ _ w _ _) sig vs = do
+#ifdef XFT
+    xftInitFtLibrary
+#endif
     tv <- atomically $ newTVar []
     _ <- forkIO (checker tv [] vs sig `catch`
                    \(SomeException _) -> void (putStrLn "Thread checker failed"))