barbly 0.1.0.0 → 0.2.0.0
raw patch · 5 files changed
+146/−69 lines, 5 filesdep +containersdep +processdep +unixdep −shhdep ~base
Dependencies added: containers, process, unix
Dependencies removed: shh
Dependency ranges changed: base
Files
- CHANGELOG.md +4/−0
- README.md +14/−0
- barbly.cabal +5/−3
- src/AppKit.hs +1/−0
- src/Main.hs +122/−66
CHANGELOG.md view
@@ -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.
README.md view
@@ -1,4 +1,5 @@ # 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.
barbly.cabal view
@@ -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
src/AppKit.hs view
@@ -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
src/Main.hs view
@@ -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