diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for barbly + +## 0.1.0.0 -- 2019-08-16 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + +![Example Menu](./doc/demo.png) + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/barbly.cabal b/barbly.cabal new file mode 100644 --- /dev/null +++ b/barbly.cabal @@ -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 diff --git a/cbits.m b/cbits.m new file mode 100644 --- /dev/null +++ b/cbits.m @@ -0,0 +1,122 @@ +#import "AppKit/AppKit.h" +#import "AppKit/NSStatusBar.h" + +#include + +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; +} diff --git a/src/AppKit.hs b/src/AppKit.hs new file mode 100644 --- /dev/null +++ b/src/AppKit.hs @@ -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. diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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