barbly (empty) → 0.1.0.0
raw patch · 8 files changed
+635/−0 lines, 8 filesdep +aesondep +asyncdep +attoparsecsetup-changed
Dependencies added: aeson, async, attoparsec, base, bytestring, mtl, optparse-applicative, shh, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +88/−0
- Setup.hs +2/−0
- barbly.cabal +37/−0
- cbits.m +122/−0
- src/AppKit.hs +70/−0
- src/Main.hs +281/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for barbly++## 0.1.0.0 -- 2019-08-16++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Luke Clifton++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Luke Clifton nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,88 @@+# 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+syntax.++Each instance of a barbly executable creates only one menu item. You specify+the period at which to refresh, and the command to generate the menu contents.++## Sample Scripts++Some sample scripts that are useful to use with barbly can be found in the+[scripts](./scripts) directory.++Here is an example of running the [`github_issues.sh`](./scripts/github_issues.sh)+script with barbly to monitor for new issues.++ barbly -p 60 ./scripts/github_issues.sh nixos nixpkgs++++Clicking on an item will open the issue in your browser.++## Syntax++Barbly can decode either JSON objects or BitBar syntax for the script outputs.+By default, it will attempt to auto-detect the format, but you can explicitly+tell it which format to use with the `--json` and `--bitbar` flags.++### JSON++The top level object has two fields, `title`, which is a string that will+be displayed in the status bar, and `items` which is an array of menu items+that will be displayed in the drop down menu when the title is clicked.++Each menu item is either `{}`, which creates a menu separator, or an object+with a `label` field, which will be the text for that menu item. Optionally+a menu item can have either an `exec` or a `items` field. An `items` field+would contain an array of menu items and would create a sub-menu. An `exec`+field would create a clickable menu item which executes the command described+by the array of strings in the `exec` field.++```json+{+ "title": "Example",+ "items": [+ {+ "label": "Say Hello",+ "exec": [ "say", "Hello" ]+ },+ {},+ {+ "label": "Sub Menu",+ "items": [+ {+ "label": "DuckDuckGo",+ "exec": [ "open", "https://duckduckgo.com/" ]+ }+ ]+ },+ { "label": "Information Only" }+ ]+}+```++### BitBar++The bitbar simulation is not complete. Only the following features are supported.++The text that appears in the status bar is the output of the script up until a line+containing only `---`.++After this, each line represents an item in a drop down menu. Submenus can be nested+arbitrarily by prefixing the line with `--` (one pair for each level of nesting).++Each line can contain some paramters which appear after the first `|` as key value+pairs separated by an `=`.++| Paramter Name | Effect | Example |+|---------------|----------------------------------------------|--------------------------------|+| `href` | Open the given URL or file. | href=https://www.google.com |+| | | href=/Applications/Firefox.app |+| `bash` | Run the given bash script | bash=/my/script.bash |+| `paramX` | Arguments to pass to the bash script above | bash=/script.sh param1=5 param2=example |++Menu separators can be created with lines containing only `---`.++See the scripts in the [scripts](./scripts) directory for some examples.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ barbly.cabal view
@@ -0,0 +1,37 @@+cabal-version: >=1.10+name: barbly+version: 0.1.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+license: BSD3+license-file: LICENSE+author: Luke Clifton+maintainer: lukec@themk.net+copyright: (c) 2019 Luke Clifton+category: System+build-type: Simple+extra-source-files: CHANGELOG.md, README.md++source-repository head+ type: git+ location: https://github.com/luke-clifton/barbly.git++executable barbly+ main-is: Main.hs+ other-modules: AppKit+ build-depends: + base >=4.12 && <4.13+ , shh >=0.7.0.2+ , aeson+ , text+ , optparse-applicative+ , attoparsec+ , bytestring+ , async+ , mtl+ hs-source-dirs: src+ default-language: Haskell2010+ c-sources: cbits.m+ frameworks: AppKit+ ghc-options: -threaded -Wall -Wno-type-defaults -Wno-unused-do-bind
+ cbits.m view
@@ -0,0 +1,122 @@+#import "AppKit/AppKit.h"+#import "AppKit/NSStatusBar.h"++#include <unistd.h>++void release(id o)+{+ [o release];+}+++void freeHaskellFunPtr(void (*ptr)(void));++@interface IOAction : NSObject+{+ @public void (*ioaction)(void);+}++- (void) callIOAction;+- (void) dealloc;+@end++@implementation IOAction++- (void) callIOAction+{+ self->ioaction();+}++- (void) dealloc+{+ freeHaskellFunPtr(self->ioaction);+ [super dealloc];+}++@end++/******************************************************/++void sendEvent(void)+{+ NSEvent *e = [NSEvent otherEventWithType: NSEventTypeApplicationDefined location: NSZeroPoint modifierFlags: 0 timestamp: 0 windowNumber: 0 context: nil subtype: 12 data1: 0 data2: 0];+ [NSApp postEvent: e atStart: NO];+ [e release];+}++void initApp(void)+{+ [NSApplication sharedApplication];+}++NSStatusItem *newStatusItem(void)+{+ return [[NSStatusBar systemStatusBar] statusItemWithLength:NSVariableStatusItemLength];+}++NSString *newNSString(char *volatile str)+{+ return [[NSString alloc] initWithUTF8String: str];+}++void setTitle(NSStatusItem *si, char *title)+{+ NSString *t = newNSString(title);+ si.button.title = t;+ [t release];+}++void runApp(void (*ptr)(void))+{+ [NSEvent addLocalMonitorForEventsMatchingMask: NSEventMaskApplicationDefined handler: ^NSEvent * _Nullable (NSEvent *e){+ ptr();+ return nil;+ }];+ [NSApp run];+}++NSMenu *newMenu(char *title)+{+ NSString *t = newNSString(title);+ NSMenu *r = [[NSMenu alloc] initWithTitle: t];+ [t release];+ return r;+}++NSMenuItem *newMenuItem(char *title)+{+ NSString *t = newNSString(title);+ NSMenuItem *r = [[NSMenuItem alloc] initWithTitle: t action: NULL keyEquivalent: @""];+ [t release];+ return r;+}++void assignAction(NSMenuItem *mi, void (*ptr)(void))+{+ IOAction *action = [IOAction alloc];+ action->ioaction = ptr;+ mi.target = action;+ mi.action = @selector(callIOAction);+ mi.representedObject = action;+ [action release];+}++void assignSubMenu(NSMenuItem *mi, NSMenu *m)+{+ mi.submenu = m;+}++NSMenuItem *newSeparator(void)+{+ return [NSMenuItem separatorItem];+}++void addMenuItem(NSMenu *m, NSMenuItem *i)+{+ [m addItem: i];+}++void setStatusItemMenu(NSStatusItem *si, NSMenu *m)+{+ si.menu = m;+}
+ src/AppKit.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+module AppKit where++import Control.Exception (finally, handle, SomeException(..))+import Control.Monad.Cont+import Data.ByteString (useAsCString)+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import Foreign hiding (newForeignPtr)+import Foreign.C++newtype NSStatusItem = NSStatusItem (Ptr ())+newtype NSMenu = NSMenu (Ptr ())+newtype NSMenuItem = NSMenuItem (Ptr ())++foreign import ccall "addMenuItem" addMenuItem :: NSMenu -> NSMenuItem -> IO ()+foreign import ccall "assignAction" assignAction' :: NSMenuItem -> FunPtr (IO ()) -> IO ()+foreign import ccall "assignSubMenu" assignSubMenu :: NSMenuItem -> NSMenu -> IO ()+foreign import ccall "initApp" initApp :: IO ()+foreign import ccall "newMenu" newMenu' :: CString -> IO NSMenu+foreign import ccall "newMenuItem" newMenuItem' :: CString -> IO NSMenuItem+foreign import ccall "newSeparator" newSeparator' :: IO NSMenuItem+foreign import ccall "newStatusItem" newStatusItem' :: IO NSStatusItem+foreign import ccall "release" release :: Ptr () -> IO ()+foreign import ccall "runApp" runApp' :: FunPtr (IO ()) -> IO ()+foreign import ccall "sendEvent" sendEvent :: IO ()+foreign import ccall "setStatusItemMenu" setStatusItemMenu :: NSStatusItem -> NSMenu -> IO ()+foreign import ccall "setTitle" setTitle' :: NSStatusItem -> CString -> IO ()+foreign import ccall "wrapper" wrap :: IO () -> IO (FunPtr (IO ()))++foreign export ccall freeHaskellFunPtr :: FunPtr (IO ()) -> IO ()++runApp :: IO () -> IO ()+runApp p = do+ p' <- wrap p+ runApp' p'++assignAction :: NSMenuItem -> IO () -> IO ()+assignAction mi act = do+ -- We simply handle any exceptions by printing them. No need+ -- to take down the whole process.+ ioact <- wrap (handle (\s@SomeException{} -> print s) act)+ liftIO $ assignAction' mi ioact++newStatusItem :: ContT r IO NSStatusItem+newStatusItem = ContT $ \go -> do+ si@(NSStatusItem p) <- newStatusItem'+ go si `finally` release p++newMenuItem :: Text -> ContT r IO NSMenuItem+newMenuItem s = ContT $ \go -> do+ useAsCString (Text.encodeUtf8 s) $ \cs -> do+ mi@(NSMenuItem p) <- newMenuItem' cs+ go mi `finally` release p++newMenu :: Text -> ContT r IO NSMenu+newMenu s = ContT $ \go -> do+ m@(NSMenu p) <- useAsCString (Text.encodeUtf8 s) newMenu'+ go m `finally` release p++setTitle :: NSStatusItem -> Text -> IO ()+setTitle si s = useAsCString (Text.encodeUtf8 s) $ setTitle' si++newSeparator :: ContT r IO NSMenuItem+newSeparator = ContT $ \go -> do+ mi <- newSeparator'+ go mi+ -- Does not need to be released, it's a constant.
+ src/Main.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+module Main where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad+import Control.Monad.Cont+import Data.Aeson ((.:))+import Data.Aeson.Internal ((<?>))+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.Attoparsec.Text as P+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as Char8+import Data.ByteString.Lazy (toStrict)+import Data.Char+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.Generics+import Options.Applicative+import Shh++import AppKit++data Menu = Menu+ { title :: Text+ , items :: [MenuItem]+ } deriving (Generic, JSON.FromJSON, JSON.ToJSON)++data MenuItem+ = MenuSeparator+ | MenuItem {label :: Text, exec :: [Text]}+ | MenuRaw {label :: Text, runio :: IO ()}+ | MenuSub Menu++-- Custom parser to get better error messages.+instance JSON.FromJSON MenuItem where+ parseJSON = JSON.withObject "Menu Item" $ \o ->+ parseSep o <|> parseOther o++ where+ parseSep o = do+ guard $ o == mempty+ pure MenuSeparator+ parseOther o = do+ t <- o .: "label"+ if length o == 1+ then+ pure $ MenuItem t []+ else do+ r <- Right <$> o .: "exec"+ <|> Left <$> o .: "items"+ <|> fail "Expected key \"items\" or \"exec\"."+ case r of+ Right j -> MenuItem t <$> JSON.parseJSON j <?> JSON.Key "exec"+ Left j -> MenuSub . Menu t <$> JSON.parseJSON j <?> JSON.Key "items"++instance JSON.ToJSON MenuItem where+ toJSON MenuRaw{} = error "Attempting to serialise internal structure"+ toJSON MenuSeparator = JSON.object []+ toJSON (MenuItem t e) = JSON.object+ [ ("label", JSON.toJSON t)+ , ("exec", JSON.toJSON e)+ ]+ toJSON (MenuSub (Menu t is)) = JSON.object+ [ ("label", JSON.toJSON t)+ , ("items", JSON.toJSON is)+ ]++createMenu :: Menu -> ContT r IO NSMenu+createMenu m = do+ nm <- newMenu (title m)+ mapM_ (\mi -> createMenuItem mi >>= liftIO . addMenuItem nm) (items m)+ pure nm++ where+ createMenuItem :: MenuItem -> ContT r IO NSMenuItem+ createMenuItem (MenuItem s []) = newMenuItem s+ createMenuItem (MenuItem s (cmd:args)) = do+ mi <- newMenuItem s+ liftIO (assignAction mi (exe (Text.encodeUtf8 cmd) (map Text.encodeUtf8 args)))+ pure mi+ createMenuItem (MenuRaw t a) = do+ mi <- newMenuItem t+ liftIO (assignAction mi a)+ pure mi+ createMenuItem MenuSeparator = newSeparator+ createMenuItem (MenuSub sm) = do+ nssm <- createMenu sm+ mi <- newMenuItem (title sm)+ liftIO $ assignSubMenu mi nssm+ pure mi++data Options = Options+ { debug :: Bool+ , period :: Double+ , format :: ByteString -> Menu+ , command :: [String]+ }++optionParser :: Parser Options+optionParser = Options <$> parseDebug <*> parsePeriod <*> parseFormat <*> parseCommand+ where+ parsePeriod :: Parser Double+ parsePeriod = option auto+ ( long "period"+ <> short 'p'+ <> value 300+ <> help "Period between running the command in seconds (default 300)"+ <> metavar "SECONDS"+ )++ parseFormat :: Parser (ByteString -> Menu)+ parseFormat = flag' parseBitBar+ ( long "bitbar"+ <> help "Assume script output is bitbar syntax (default auto detect)"+ ) <|>+ flag' parseJSON+ ( long "json"+ <> help "Assume script output is JSON (default auto detect)"+ ) <|>+ pure parseAuto++ parseCommand :: Parser [String]+ parseCommand = (:)+ <$> strArgument (metavar "CMD" <> help "Command to run")+ <*> many (strArgument (metavar "ARGS"))++ parseDebug :: Parser Bool+ parseDebug = switch+ ( long "debug"+ <> help "Enable menu items that assist in debugging"+ )++view :: ExecArg a => a -> IO ()+view s = writeOutput s |> exe "open" "-f"++main :: IO ()+main = runInBoundThread $ do+ opts <- execParser $ info (optionParser <**> helper) fullDesc+ mvMenu <- newEmptyMVar+ initApp+ runContT newStatusItem $ \si -> do+ let+ cmd:args = Main.command opts++ 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)+ ]+ )++ ((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+ sendEvent+ threadDelay (round $ period opts * 1000000)++ withAsync (runner) $ \_ -> do+ runApp $ takeMVar mvMenu >>= \menu -> do+ runContT (createMenu menu) $ \nsmenu -> do+ setTitle si (if Text.null (title menu) then "[no title]" else (title menu))+ setStatusItemMenu si nsmenu++-- BitBar compatible Parser+parseItem :: Int -> P.Parser MenuItem+parseItem lev = parseLevelIndicator *> P.choice+ [ parseSep+ , parseBash+ , parseOpen+ , parseSubMenu+ , parseInfo+ ]+ where+ parseLevelIndicator :: P.Parser ()+ parseLevelIndicator = do+ P.count lev (P.string "--")+ when (lev > 0) $ void $ P.space++ parseSubMenu = do+ t <- P.takeWhile (/= '\n')+ P.endOfLine+ is <- P.many1 (parseItem $ succ lev)+ 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)+ P.char '='+ s <- parseString+ P.choice [(s:) <$> parseParams (succ i), pure [s]]++parseString :: P.Parser Text+parseString = P.choice [quoted,raw]+ where+ quoted = do+ P.char '"'+ s <- parseU ""+ pure (Text.pack $ reverse s)+ parseU :: String -> P.Parser String+ parseU s = do+ P.anyChar >>= \case+ '"' -> pure s+ '\\' -> P.anyChar >>= \case+ 'n' -> parseU ('\n':s)+ c -> parseU (c:s)+ '\n' -> fail "Unexpected newline"+ c -> parseU (c:s)+ 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)++parseMenu :: P.Parser Menu+parseMenu = Menu <$> parseTitle <*> many (parseItem 0)++parseBitBar :: ByteString -> Menu+parseBitBar s = case P.parseOnly parseMenu (Text.decodeUtf8 s) of+ Left _ -> Menu "Error parsing bitbar syntax"+ [ MenuRaw "Show document" (writeOutput s |> exe "open" "-f")+ ]+ Right m -> m++parseJSON :: ByteString -> Menu+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")]+ Right m -> m++-- | Parse auto attempts to detect if this is meant to be a JSON object by looking+-- for a leading @{@. If it is, it assumes JSON output, and will report errors+-- as such. If the first non-whitespace character is anything else, it will assume+-- bitbar syntax.+parseAuto :: ByteString -> Menu+parseAuto s = case Char8.uncons (Char8.dropWhile isSpace s) of+ Just ('{',_) -> parseJSON s+ _ -> parseBitBar s