diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for barbly +## 0.1.0.1 -- 2021-11-30 + +* Implement checkfd feature. + ## 0.1.0.0 -- 2019-08-16 * First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,5 @@ # Barbly +[![](https://img.shields.io/hackage/v/barbly.svg?colorB=%23999&label=barbly)](http://hackage.haskell.org/package/barbly) Barbly allows you to create status bar menus for macOS. It's similar to [bitbar](https://github.com/matryer/bitbar) and supports some of the same @@ -21,6 +22,8 @@ Clicking on an item will open the issue in your browser. +## Other Features + ## Syntax Barbly can decode either JSON objects or BitBar syntax for the script outputs. @@ -85,4 +88,15 @@ Menu separators can be created with lines containing only `---`. +### Example Scripts + See the scripts in the [scripts](./scripts) directory for some examples. + +### Multiple Menus + +Because each instance of barbly creates just one menu, you need to launch +multiple processes to get multiple menus. If you launch them all from a +script, this can cause the order of the resulting menu items to depend on +the whims of the scheduler. This can be alleviated by yielding between +spawning each process. A yield can be achieved by sleeping the process +for 0 seconds. diff --git a/barbly.cabal b/barbly.cabal --- a/barbly.cabal +++ b/barbly.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: barbly -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Create status bar menus for macOS from executables description: Allows you to place the stdout of a process in the macOS status bar. bug-reports: https://github.com/luke-clifton/barbly @@ -21,15 +21,17 @@ main-is: Main.hs other-modules: AppKit build-depends: - base >=4.12 && <4.13 - , shh >=0.7.0.2 + base >=4.12 && <5 , aeson + , process + , containers , text , optparse-applicative , attoparsec , bytestring , async , mtl + , unix hs-source-dirs: src default-language: Haskell2010 c-sources: cbits.m diff --git a/src/AppKit.hs b/src/AppKit.hs --- a/src/AppKit.hs +++ b/src/AppKit.hs @@ -5,6 +5,7 @@ import Control.Exception (finally, handle, SomeException(..)) import Control.Monad.Cont +import Control.Monad.IO.Class (liftIO) import Data.ByteString (useAsCString) import Data.Text (Text) import qualified Data.Text.Encoding as Text diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,18 +10,19 @@ import Control.Concurrent.Async import Control.Monad import Control.Monad.Cont -import Data.Aeson ((.:)) -import Data.Aeson.Internal (()) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson ((.:), ()) import qualified Data.Aeson as JSON - --- Importing Aeson Internal module until --- https://github.com/bos/aeson/commit/220fd9aa816fc306068de3825160a59d5df3c515 --- is released. -import qualified Data.Aeson.Internal as JSON (JSONPathElement(Key)) +import qualified Data.Aeson.Types as JSON +import System.Process +import System.Exit +import System.IO +import System.Environment import qualified Data.Attoparsec.Text as P import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString as BS import Data.ByteString.Lazy (toStrict) import Data.Char import Data.Text (Text) @@ -28,7 +30,8 @@ import qualified Data.Text.Encoding as Text import GHC.Generics import Options.Applicative -import Shh +import qualified System.IO as IO +import qualified Data.Map as Map import AppKit @@ -86,9 +89,17 @@ where createMenuItem :: MenuItem -> ContT r IO NSMenuItem createMenuItem (MenuItem s []) = newMenuItem s - createMenuItem (MenuItem s (cmd:args)) = do + createMenuItem (MenuItem s cmds) = do mi <- newMenuItem s - liftIO (assignAction mi (exe (Text.encodeUtf8 cmd) (map Text.encodeUtf8 args))) + let cmd:args = map Text.unpack cmds + let cp = (proc cmd args) + { std_in = NoStream + , std_out = NoStream + , std_err = NoStream + , close_fds = False + , delegate_ctlc = True + } + liftIO (assignAction mi (createProcess cp >>= \(_, _,_, h) -> void (waitForProcess h))) pure mi createMenuItem (MenuRaw t a) = do mi <- newMenuItem t @@ -102,9 +113,9 @@ pure mi data Options = Options - { debug :: Bool - , period :: Double - , format :: ByteString -> Menu + { debug :: Bool + , period :: Double + , format :: ByteString -> Menu , command :: [String] } @@ -116,8 +127,9 @@ ( long "period" <> short 'p' <> value 300 - <> help "Period between running the command in seconds (default 300)" + <> help "Period between running the command in seconds" <> metavar "SECONDS" + <> showDefault ) parseFormat :: Parser (ByteString -> Menu) @@ -142,8 +154,8 @@ <> help "Enable menu items that assist in debugging" ) -view :: ExecArg a => a -> IO () -view s = writeOutput s |> exe "open" "-f" +view :: String -> IO () +view = void . readProcess "/usr/bin/open" ["-f"] main :: IO () main = runInBoundThread $ do @@ -152,36 +164,47 @@ initApp runContT newStatusItem $ \si -> do let - cmd:args = Main.command opts + cmd:args = (Main.command opts) + cp = (proc cmd args) + { close_fds = False + , std_in = NoStream + , std_out = CreatePipe + , std_err = CreatePipe + } runner = forever $ do - tryFailure (exe cmd args) `pipe` capture `pipeErr` capture >>= \case - ((Left f, out), err) -> do - print f - putMVar mvMenu - ( Menu "Error!" $ - [ MenuItem (Text.pack x) [] | x <- lines (show f)] - ++ - [ MenuRaw "View stdout" (view out) - , MenuRaw "View stderr" (view err) - ] - ) + (Nothing, Just sout, Just serr, h) <- createProcess cp + + runConcurrently ((,,) + <$> Concurrently (hGetContents' sout) + <*> Concurrently (hGetContents' serr) + <*> Concurrently (waitForProcess h) + ) >>= \case + (out, err, ExitFailure f) -> do + putMVar mvMenu + ( Menu "Error!" $ + [ MenuItem (Text.pack $ "Exit failure: " ++ show f) [] ] + ++ + [ MenuRaw "View stdout" (view out) + , MenuRaw "View stderr" (view err) + ] + ) - ((Right (), res), err) -> do - let - menu' = format opts (toStrict res) - menu - | debug opts = menu' - { items = items menu' - ++ [ MenuSeparator - , MenuRaw "Debug: view output" - $ view res - , MenuRaw "Debug: view stderr" - $ view err - ] - } - | otherwise = menu' - putMVar mvMenu menu + (res, err, ExitSuccess) -> do + let + menu' = format opts (Text.encodeUtf8 $ Text.pack res) + menu + | debug opts = menu' + { items = items menu' + ++ [ MenuSeparator + , MenuRaw "Debug: view output" + $ view res + , MenuRaw "Debug: view stderr" + $ view err + ] + } + | otherwise = menu' + putMVar mvMenu menu sendEvent threadDelay (round $ period opts * 1000000) @@ -195,8 +218,7 @@ parseItem :: Int -> P.Parser MenuItem parseItem lev = parseLevelIndicator *> P.choice [ parseSep - , parseBash - , parseOpen + , parseGeneric , parseSubMenu , parseInfo ] @@ -213,25 +235,37 @@ pure $ MenuSub $ Menu t is parseSep = P.string "---" *> P.endOfLine *> pure MenuSeparator - parseBody = P.takeTill (\s -> s == '|' || s == '\n') - parseTags p = (P.char '|' >> P.skipSpace) *> p <* P.endOfLine parseInfo = MenuItem <$> (P.takeWhile (/= '\n') <* P.endOfLine) <*> pure [] - parseOpen = MenuItem <$> parseBody <*> ((\s -> ["open", s]) <$> parseTags parseURL) - parseURL = P.string "href=" *> parseString - parseBash = MenuItem <$> parseBody <*> parseTags parseBash' - parseBash' = do - P.string "bash=" - cmd <- parseString - params <- P.choice [parseParams 1, pure []] - pure (cmd:params) - parseParams :: Int -> P.Parser [Text] - parseParams i = do - P.skipSpace - P.string "param" - P.string (Text.pack $ show i) + parseGeneric = do + (name, params) <- parseBodyWithTags + let pglob = Map.fromListWith (++) $ map (fmap (:[])) params + case lookup "href" params of + Just s -> pure $ MenuItem name ["/usr/bin/open", s] + _ -> case lookup "bash" params of + Just cmd -> do + pure $ MenuItem name $ cmd : (Map.findWithDefault [] "param" pglob) + _ -> fail "hmm" + +parseBodyWithTags :: P.Parser (Text, [(Text, Text)]) +parseBodyWithTags = do + t <- P.takeTill (\s -> s == '|' || s == '\n') + ts <- parseAllTags + optional $ P.skipWhile P.isHorizontalSpace + P.endOfLine + pure (t, ts) + +parseAllTags :: P.Parser [(Text, Text)] +parseAllTags = P.option [] $ do + P.char '|' + optional $ P.skipWhile P.isHorizontalSpace + P.sepBy parseGenericTag (P.skipWhile P.isHorizontalSpace) + where + parseGenericTag :: P.Parser (Text, Text) + parseGenericTag = do + key <- P.takeWhile isAlphaNum P.char '=' - s <- parseString - P.choice [(s:) <$> parseParams (succ i), pure [s]] + val <- parseString + pure (key, val) parseString :: P.Parser Text parseString = P.choice [quoted,raw] @@ -252,15 +286,37 @@ raw = P.takeWhile (\c -> isAlphaNum c || c `elem` "./()[]{}!@#$%^&*,:;-\\") parseTitle :: P.Parser Text -parseTitle = Text.strip . Text.pack <$> P.manyTill P.anyChar (void (P.string "---\n") <|> P.endOfInput) +--parseTitle = Text.strip . Text.pack <$> P.manyTill P.anyChar (void (P.string "---\n") <|> P.endOfInput) +parseTitle = do + (t, ts) <- parseBodyWithTags + void (P.string "---\n") <|> P.endOfInput + pure t parseMenu :: P.Parser Menu parseMenu = Menu <$> parseTitle <*> many (parseItem 0) +stripControlSequences :: ByteString -> ByteString +stripControlSequences i = case Char8.uncons i of + Just ('\ESC', r) -> go1 r + Just (c, r) -> Char8.cons c (stripControlSequences r) + Nothing -> Char8.empty + + where + go1 :: ByteString -> ByteString + go1 i = case Char8.uncons i of + Just ('[', r) -> go2 r + Just (a, r) -> Char8.cons a $ stripControlSequences r + Nothing -> Char8.empty + + go2 :: ByteString -> ByteString + go2 i = case BS.uncons i of + Just (c, r) -> if c >= 0x40 && c <= 0x7E then stripControlSequences r else go2 r + Nothing -> Char8.empty + parseBitBar :: ByteString -> Menu -parseBitBar s = case P.parseOnly parseMenu (Text.decodeUtf8 s) of +parseBitBar s = case P.parseOnly parseMenu (Text.decodeUtf8 $ stripControlSequences s) of Left _ -> Menu "Error parsing bitbar syntax" - [ MenuRaw "Show document" (writeOutput s |> exe "open" "-f") + [ MenuRaw "Show document" (view $ Text.unpack $ Text.decodeUtf8 s) ] Right m -> m @@ -268,7 +324,7 @@ parseJSON s = case JSON.eitherDecodeStrict' s of Left e -> Menu "Error parsing json" $ [MenuItem l [] | l <- Text.lines (Text.pack e)] - ++ [MenuRaw "Open JSON document" (writeOutput s |> exe "open" "-f")] + ++ [MenuRaw "Open JSON document" (view $ Text.unpack $ Text.decodeUtf8 s)] Right m -> m -- | Parse auto attempts to detect if this is meant to be a JSON object by looking