From 47de4a423b805f5fd1d98b746cf1858f5e4daeac Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Thu, 20 Feb 2020 16:56:23 +0100
Subject: [PATCH] Add tag parser for active, warning, error, and critical tags
Use tag parser for 'blockScript', 'persistendBlockScript' and 'qbar pipe'.
'blockScript' no longer handles (and allows) exit codes other than 0.
---
src/QBar/BlockOutput.hs | 10 ++++++-
src/QBar/Blocks/Pipe.hs | 3 ++-
src/QBar/Core.hs | 28 +++++++------------
src/QBar/TagParser.hs | 60 +++++++++++++++++++++++++++++++++++++++++
4 files changed, 81 insertions(+), 20 deletions(-)
create mode 100644 src/QBar/TagParser.hs
diff --git a/src/QBar/BlockOutput.hs b/src/QBar/BlockOutput.hs
index 9e0207a..a9654a8 100644
--- a/src/QBar/BlockOutput.hs
+++ b/src/QBar/BlockOutput.hs
@@ -48,8 +48,16 @@ mkBlockOutput text = BlockOutput {
_invalid = False
}
+mkBlockOutput' :: BlockText -> BlockText -> BlockOutput
+mkBlockOutput' full short = BlockOutput {
+ _fullText = full,
+ _shortText = Just short,
+ _blockName = Nothing,
+ _invalid = False
+}
+
mkErrorOutput :: T.Text -> BlockOutput
-mkErrorOutput = mkBlockOutput . importantText criticalImportant
+mkErrorOutput errorText = mkBlockOutput . importantText criticalImportant $ "[" <> errorText <> "]"
emptyBlock :: BlockOutput
emptyBlock = mkBlockOutput mempty
diff --git a/src/QBar/Blocks/Pipe.hs b/src/QBar/Blocks/Pipe.hs
index 8c78321..771244b 100644
--- a/src/QBar/Blocks/Pipe.hs
+++ b/src/QBar/Blocks/Pipe.hs
@@ -3,6 +3,7 @@ module QBar.Blocks.Pipe where
import QBar.BlockOutput
import QBar.ControlSocket
import QBar.Core
+import QBar.TagParser
import Control.Concurrent.Async
import Data.Aeson (encode)
@@ -25,7 +26,7 @@ runPipeClient enableEvents mainOptions = do
pipeBlock source = PushMode <$ source >-> PP.map stringToState
where
stringToState :: String -> BlockState
- stringToState = attachHandler . mkBlockOutput . normalText . T.pack
+ stringToState = attachHandler . parseTags' . T.pack
attachHandler :: BlockOutput -> BlockState
attachHandler = if enableEvents then mkBlockState' pipeBlockName handler else mkBlockState
handler :: BlockEventHandler
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index 85cd599..276299a 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -4,6 +4,7 @@
module QBar.Core where
import QBar.BlockOutput
+import QBar.TagParser
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
@@ -311,23 +312,14 @@ blockScript path = forever $ updateBlock =<< (lift blockScriptAction)
-- I am trying to replace i3blocks scripts with native haskell blocks, so I do not need it
(exitCode, output) <- liftIO $ readProcessStdout $ shell path
return $ case exitCode of
- ExitSuccess -> createScriptBlock False normalImportant output
+ ExitSuccess -> createScriptBlock output
(ExitFailure nr) -> case nr of
- 27 -> createScriptBlock False warnImportant output
- 28 -> createScriptBlock False errorImportant output
- 29 -> createScriptBlock False criticalImportant output
- 30 -> createScriptBlock True normalImportant output
- 31 -> createScriptBlock True warnImportant output
- 32 -> createScriptBlock True errorImportant output
- 33 -> createScriptBlock True criticalImportant output
- _ -> mkErrorOutput $ "[" <> T.pack (show nr) <> "]"
- createScriptBlock :: Bool -> Importance -> C8.ByteString -> BlockOutput
- createScriptBlock active importance output = case map E.decodeUtf8 (C8.lines output) of
- (text:short:_) -> shortText ?~ normalText short $ createScriptBlock' active importance text
- (text:_) -> createScriptBlock' active importance text
- [] -> createScriptBlock' active importance "-"
- createScriptBlock' :: Bool -> Importance -> T.Text -> BlockOutput
- createScriptBlock' active importance text = blockName ?~ T.pack path $ mkBlockOutput $ mkText active importance text
+ _ -> mkErrorOutput $ "exit code " <> T.pack (show nr) <> ""
+ createScriptBlock :: C8.ByteString -> BlockOutput
+ createScriptBlock output = case map E.decodeUtf8 (C8.lines output) of
+ (text:short:_) -> parseTags'' text short
+ (text:_) -> parseTags' text
+ [] -> emptyBlock
persistentBlockScript :: FilePath -> PushBlock
-- The outer catchP only catches errors that occur during process creation
@@ -335,7 +327,7 @@ persistentBlockScript path = catchP startScriptProcess handleError
where
handleError :: IOException -> PushBlock
handleError e = do
- updateBlock . mkErrorOutput $ "[" <> T.pack (show e) <> "]"
+ updateBlock . mkErrorOutput $ T.pack (show e)
exitBlock
handleErrorWithProcess :: (Process i o e) -> IOException -> PushBlock
handleErrorWithProcess process e = do
@@ -351,7 +343,7 @@ persistentBlockScript path = catchP startScriptProcess handleError
blockFromHandle :: Handle -> PushBlock
blockFromHandle handle = forever $ do
line <- liftIO $ TIO.hGetLine handle
- updateBlock $ mkBlockOutput . normalText $ line
+ updateBlock $ parseTags' line
lift updateBar
addBlock :: IsCachable a => a -> BarIO ()
diff --git a/src/QBar/TagParser.hs b/src/QBar/TagParser.hs
new file mode 100644
index 0000000..a731aea
--- /dev/null
+++ b/src/QBar/TagParser.hs
@@ -0,0 +1,60 @@
+module QBar.TagParser where
+
+import QBar.BlockOutput
+
+import Control.Monad (void)
+import Data.Functor (($>))
+import Data.Either (either)
+import qualified Data.Text as TS
+import qualified Data.Text.Lazy as T
+import Data.Attoparsec.Text.Lazy as A
+
+type TagState = (Bool, Importance)
+
+tagParser :: Parser BlockText
+tagParser = parser (False, normalImportant)
+ where
+ parser :: TagState -> Parser BlockText
+ parser (active, importance) = mconcat <$> many' singleElementParser
+ where
+ singleElementParser :: Parser BlockText
+ singleElementParser = choice [textParser, activeTagParser, importanceTagParser]
+
+ textParser :: Parser BlockText
+ textParser = mkText active importance . T.fromStrict <$> A.takeWhile1 (notInClass "<>")
+
+ activeTagParser :: Parser BlockText
+ activeTagParser = string "<active>" *> parser (True, importance) <* string "</active>"
+
+ importanceTagParser :: Parser BlockText
+ importanceTagParser = do
+ (tag, importance') <- char '<' *> importanceParser <* char '>'
+ result <- parser (active, importance')
+ void $ string $ "</" <> tag <> ">"
+ return result
+
+ importanceParser :: Parser (TS.Text, Importance)
+ importanceParser = choice $ map mkParser importanceTags
+ where
+ mkParser :: (TS.Text, Importance) -> Parser (TS.Text, Importance)
+ mkParser (tag, importance) = string tag $> (tag, importance)
+ importanceTags :: [(TS.Text, Importance)]
+ importanceTags = [
+ ("normal", normalImportant),
+ ("warning", warnImportant),
+ ("error", errorImportant),
+ ("critical", criticalImportant)
+ ]
+
+
+parseTags :: T.Text -> Either String BlockText
+parseTags text = parseOnly (tagParser <* endOfInput) (T.toStrict text)
+
+parseTags' :: T.Text -> BlockOutput
+parseTags' = either (mkErrorOutput . T.pack) mkBlockOutput . parseTags
+
+parseTags'' :: T.Text -> T.Text -> BlockOutput
+parseTags'' full short = either (mkErrorOutput . T.pack) id $ do
+ full' <- parseTags $ full
+ short' <- parseTags $ short
+ return $ mkBlockOutput' full' short'
--
GitLab