diff --git a/src/QBar/BlockOutput.hs b/src/QBar/BlockOutput.hs index 9e0207a76133df933dfcd51802f3a819d9186dd9..a9654a8bc3e531bca7bb7bbd46271465662aabd5 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 8c783219ad7a7b64bccee685e80ed872bc3071e6..771244bc10daeff66f904a15c8de809167273268 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 85cd59976b56f3acd3ef3e02ed327f4f1298a0c0..276299afe7f9588dd2d876e8f80c265890b130bd 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 0000000000000000000000000000000000000000..a731aea41d001eafe912d2d62b3599efd1db5ecb --- /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'