[ghc-xmonad-contrib/f18] backport patch from 0.11.2 to sanitize DynamicLog output (potential vulnerability)

[Jens Petersen]

commit f69752a22f61809621df5bc4c26f6e71897fe83c
Author: Jens Petersen <petersen at redhat.com>
Date:   Mon Jul 22 18:15:34 2013 +0900

    backport patch from 0.11.2 to sanitize DynamicLog output (potential vulnerability)

 ghc-xmonad-contrib.spec                |    8 +++-
 xmonad-contrib-DynamicLog-0.11.2.patch |   84 ++++++++++++++++++++++++++++++++
 2 files changed, 91 insertions(+), 1 deletions(-)
---
diff --git a/ghc-xmonad-contrib.spec b/ghc-xmonad-contrib.spec
index 73d206a..a4ab259 100644
--- a/ghc-xmonad-contrib.spec
+++ b/ghc-xmonad-contrib.spec
@@ -18,7 +18,7 @@ your own extensions.
 
 Name:           ghc-%{pkg_name}
 Version:        0.11
-Release:        1%{?dist}
+Release:        1.1%{?dist}
 Summary:        %{common_summary}
 
 License:        BSD
@@ -28,6 +28,7 @@ Patch0:         xmonad-contrib-use_xft-flag.patch
 Patch1:         xmonad-contrib-0.10-xft-fonts.patch
 Patch2:         xmonad-contrib-0.10-ewmh-set-NET_WM_STATE.patch
 Patch4:         xmonad-contrib-0.10-PositionStore-dont-rescale-with-screen.patch
+Patch5:         xmonad-contrib-DynamicLog-0.11.2.patch
 
 BuildRequires:  ghc-Cabal-devel
 BuildRequires:  ghc-rpm-macros
@@ -57,6 +58,7 @@ BuildRequires:  ghc-xmonad-devel
 %patch1 -p1 -b .orig-misc-fixed
 %patch2 -p1 -b .orig-NET_WM_STATE
 %patch4 -p1 -b .orig-rescale
+%patch5 -p1 -b .orig-sanitize
 
 
 %build
@@ -80,6 +82,10 @@ BuildRequires:  ghc-xmonad-devel
 
 
 %changelog
+* Mon Jul 22 2013 Jens Petersen <petersen at redhat.com> - 0.11-1.1
+- backport patch from 0.11.2 to sanitize DynamicLog output
+  (potential vulnerability)
+
 * Fri Jan 18 2013 Jens Petersen <petersen at redhat.com> - 0.11-1
 - update to 0.11
 - BorderResize, X11-1.6, and takeFocus patches no longer needed
diff --git a/xmonad-contrib-DynamicLog-0.11.2.patch b/xmonad-contrib-DynamicLog-0.11.2.patch
new file mode 100644
index 0000000..0caa5df
--- /dev/null
+++ b/xmonad-contrib-DynamicLog-0.11.2.patch
@@ -0,0 +1,84 @@
+diff --git a/XMonad/Hooks/DynamicLog.hs b/XMonad/Hooks/DynamicLog.hs
+index 0547c80..1d256c6 100644
+--- a/XMonad/Hooks/DynamicLog.hs
++++ b/XMonad/Hooks/DynamicLog.hs
+@@ -1,4 +1,4 @@
+-{-# LANGUAGE FlexibleContexts #-}
++{-# LANGUAGE FlexibleContexts, PatternGuards #-}
+ 
+ -----------------------------------------------------------------------------
+ -- |
+@@ -57,10 +57,10 @@ module XMonad.Hooks.DynamicLog (
+ -- Useful imports
+ 
+ import Codec.Binary.UTF8.String (encodeString)
+-import Control.Monad (liftM2)
++import Control.Monad (liftM2, msum)
+ import Data.Char ( isSpace, ord )
+-import Data.List (intersperse, isPrefixOf, sortBy)
+-import Data.Maybe ( isJust, catMaybes )
++import Data.List (intersperse, stripPrefix, isPrefixOf, sortBy)
++import Data.Maybe ( isJust, catMaybes, mapMaybe )
+ import Data.Ord ( comparing )
+ import qualified Data.Map as M
+ import qualified XMonad.StackSet as S
+@@ -279,7 +279,7 @@ dynamicLogString pp = do
+     return $ encodeString . sepBy (ppSep pp) . ppOrder pp $
+                         [ ws
+                         , ppLayout pp ld
+-                        , ppTitle  pp wt
++                        , ppTitle  pp $ ppTitleSanitize pp wt
+                         ]
+                         ++ catMaybes extras
+ 
+@@ -396,14 +396,26 @@ xmobarColor fg bg = wrap t "</fc>"
+ 
+ -- | Strip xmobar markup.
+ xmobarStrip :: String -> String
+-xmobarStrip = strip [] where
++xmobarStrip = xmobarStripTags ["fc","icon","action"] where
++
++xmobarStripTags :: [String] -- ^ tags
++        -> String -> String -- ^ with all <tag>...</tag> removed
++xmobarStripTags tags = strip [] where
++    strip keep [] = keep
+     strip keep x
+-      | null x                 = keep
+-      | "<fc="  `isPrefixOf` x = strip keep (drop 1 . dropWhile (/= '>') $ x)
+-      | "</fc>" `isPrefixOf` x = strip keep (drop 5  x)
+-      | '<' == head x          = strip (keep ++ "<") (tail x)
+-      | otherwise              = let (good,x') = span (/= '<') x
+-                                 in strip (keep ++ good) x'
++        | rest: _ <- mapMaybe dropTag tags = strip keep rest
++
++
++        | '<':xs <- x = strip (keep ++ "<") xs
++        | (good,x') <- span (/= '<') x = strip (keep ++ good) x' -- this is n^2 bad... but titles have few tags
++      where dropTag :: String -> Maybe String
++            dropTag tag = msum [fmap dropTilClose (openTag tag `stripPrefix` x),
++                                                   closeTag tag `stripPrefix` x]
++
++    dropTilClose, openTag, closeTag :: String -> String
++    dropTilClose = drop 1 . dropWhile (/= '>')
++    openTag str = "<" ++ str ++ "="
++    closeTag str = "</" ++ str ++ ">"
+ 
+ -- | The 'PP' type allows the user to customize the formatting of
+ --   status information.
+@@ -427,6 +439,8 @@ data PP = PP { ppCurrent :: WorkspaceId -> String
+                -- ^ separator to use between workspace tags
+              , ppTitle :: String -> String
+                -- ^ window title format
++             , ppTitleSanitize :: String -> String
++              -- ^  escape / sanitizes input to 'ppTitle'
+              , ppLayout :: String -> String
+                -- ^ layout name format
+              , ppOrder :: [String] -> [String]
+@@ -468,6 +482,7 @@ defaultPP = PP { ppCurrent         = wrap "[" "]"
+                , ppSep             = " : "
+                , ppWsSep           = " "
+                , ppTitle           = shorten 80
++               , ppTitleSanitize   = xmobarStrip . dzenEscape
+                , ppLayout          = id
+                , ppOrder           = id
+                , ppOutput          = putStrLn