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

[Jens Petersen]

commit 0be1c97f27cca1b514c545f03ed618a7f0043aec
Author: Jens Petersen <petersen at redhat.com>
Date:   Mon Jul 22 21:21:25 2013 +0900

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

 ghc-xmonad-contrib.spec                |    3 +-
 xmonad-contrib-DynamicLog-0.11.2.patch |   84 ++++++++++++++++++++++++++++++++
 2 files changed, 86 insertions(+), 1 deletions(-)
---
diff --git a/ghc-xmonad-contrib.spec b/ghc-xmonad-contrib.spec
index 40347c1..9b58b70 100644
--- a/ghc-xmonad-contrib.spec
+++ b/ghc-xmonad-contrib.spec
@@ -31,6 +31,7 @@ Patch3:         xmonad-contrib-0.10-BorderResize-smaller.patch
 Patch4:         xmonad-contrib-0.10-PositionStore-dont-rescale-with-screen.patch
 Patch5:         xmonad-contrib-0.10-X11-1.6.patch
 Patch6:         xmonad-contrib-0.10-takeFocus-core.patch
+Patch7:         xmonad-contrib-DynamicLog-0.11.2.patch
 
 BuildRequires:  ghc-Cabal-devel
 BuildRequires:  ghc-rpm-macros
@@ -65,7 +66,7 @@ BuildRequires:  ghc-xmonad-devel
 %patch5 -p1 -b .orig-X11
 %endif
 %patch6 -p1 -b .orig-Focus
-
+%patch7 -p1 -b .orig-sanitize
 
 %build
 %ghc_lib_build
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