diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for notifications-tray-icon + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ivan Malison (c) 2018 + +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 Ivan Malison 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,16 @@ +# notifications-tray-icon + +notifications-tray-icon provides an SNI tray icon that polls a notification +source and provides a menu with actions from that notification source. It will +add an overlay to the displayed icon when new notifications are present, and +call notify-send to display a notification when new notifications come in. + +# Sources + +For the time being, github is the only supported notification source. Support +for gmail and other sources should be coming soon. + +# Installation + +For the time being, notifications-tray-icon must be installed from source using +stack. 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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,169 @@ +module Main where + +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans.Class +import qualified Data.ByteString.Char8 as BS +import Data.Semigroup ((<>)) +import qualified Data.Text as T +import Data.Tuple.Sequence +import Data.Version (showVersion) +import qualified GitHub.Auth as GH +import Options.Applicative +import StatusNotifier.Item.Notifications.GitHub +import StatusNotifier.Item.Notifications.OverlayIcon +import StatusNotifier.Item.Notifications.Util +import System.Console.Haskeline +import System.Log.Logger +import Text.Printf + +import Paths_notifications_tray_icon (version) + +iconNameParser :: Parser String +iconNameParser = strOption + ( long "icon-name" + <> short 'n' + <> metavar "NAME" + <> value "github" + <> help "The icon the item will display" + ) + +overlayIconNameParser :: Parser String +overlayIconNameParser = strOption + ( long "overlay-icon-name" + <> short 'o' + <> metavar "NAME" + <> value "github" + <> help "The overlay icon that will be displayed when notifications are present" + ) + +busNameParser :: Parser String +busNameParser = strOption + ( long "bus-name" + <> short 'b' + <> metavar "BUS-NAME" + <> value "org.Github.Notifications" + ) + +githubTokenAuthParser :: Parser (IO GH.Auth) +githubTokenAuthParser = fmap (GH.OAuth . BS.pack . T.unpack . T.strip . T.pack) <$> + (passGetMain <$> strOption + ( long "github-token-pass" + <> metavar "TOKEN-NAME" + <> help "Use pass to get a token password to authenticate with github" + ) <|> + (gitConfigGet <$> strOption + ( long "github-token-config" + <> metavar "TOKEN-KEY" + <> help "Get a github token using the provided git config key" + )) <|> + (return <$> strOption + ( long "github-token-string" + <> metavar "TOKEN" + <> help "Provide the github token as a value" + ))) + +gitConfigGet :: String -> IO String +gitConfigGet key = do + Right value <- runCommandFromPath ["git", "config", "--get", key] + return value + +githubConfigAuthParser :: Parser (IO GH.Auth) +githubConfigAuthParser = + fmap githubAuthFromUsernamePassword <$> usernamePasswordParser + where usernamePasswordParser = + runGitConfigCommands <$> userOption <*> passwordOption + userOption = strOption + ( long "github-config-user" + <> metavar "USER-KEY" + <> help "The git config key to use to get the github user" + ) + passwordOption = strOption + ( long "github-config-password" + <> metavar "PASSWORD-KEY" + <> help "The git config key to use to get the github password" + ) + runGitConfigCommands userKey passwordKey = do + username <- gitConfigGet userKey + password <- gitConfigGet passwordKey + return (username, password) + +getUsernameAndPassword :: IO (String, String) +getUsernameAndPassword = + runInputT defaultSettings $ sequenceT (getU, getP) + where getP :: InputT IO String + getP = getPassword (Just '*') "password: " >>= maybe getP pure + getU :: InputT IO String + getU = getInputLine "username: " >>= maybe getU pure + +githubAuthFromUsernamePassword (username, password) = + GH.BasicAuth (BS.pack username) (BS.pack password) + +githubConsoleAuthParser :: Parser (IO GH.Auth) +githubConsoleAuthParser = + flag' (githubAuthFromUsernamePassword <$> getUsernameAndPassword) $ + long "github-basic-auth" + +githubAuthParser = + githubTokenAuthParser <|> githubConfigAuthParser <|> githubConsoleAuthParser + +githubParser :: Parser (IO GitHubConfig) +githubParser = fmap <$> helper <*> githubAuthParser + where helper = + flip GitHubConfig <$> option auto + ( long "poll-interval" + <> help "The amount of time to wait between refreshes of notification data" + <> value 30 + <> metavar "SECONDS" + ) + +updaterParser + = (fmap githubUpdaterNew <$> githubParser) + <|> (flag' (return $ sampleUpdater ) $ long "sample") + +logParser = + option auto + ( long "log-level" + <> short 'l' + <> help "Set the log level" + <> metavar "LEVEL" + <> value WARNING + ) + +params iconName overlayIconName busName notifications = OverlayIconParams + { iconName = iconName + , iconPath = "/StatusNotifierItem" + , iconDBusName = busName + , getOverlayName = \count -> return $ if count > 0 then T.pack overlayIconName else "" + , runUpdater = notifications + } + +startOverlayIcon getUpdater iconName overlayIconName logLevel busName = do + logger <- getLogger "StatusNotifier.Item.Notifications" + saveGlobalLogger $ setLevel logLevel logger + dbusLogger <- getLogger "DBus" + saveGlobalLogger $ setLevel logLevel dbusLogger + (params iconName overlayIconName busName <$> getUpdater) >>= buildOverlayIcon + +parser = + startOverlayIcon + <$> updaterParser <*> iconNameParser <*> overlayIconNameParser + <*> logParser <*> busNameParser + +versionOption :: Parser (a -> a) +versionOption = infoOption + (printf "notifications-tray-icon %s" versionString) + ( long "version" + <> (help $ + printf "Show the version number of notifications-tray-icon (%s)" + versionString) + ) + where versionString = showVersion version + +main :: IO () +main = do + join $ execParser $ info (helper <*> versionOption <*> parser) + ( fullDesc + <> progDesc "Run a notification monitoring tray icon" + ) + void $ forever $ threadDelay 999999999999999999 diff --git a/notifications-tray-icon.cabal b/notifications-tray-icon.cabal new file mode 100644 --- /dev/null +++ b/notifications-tray-icon.cabal @@ -0,0 +1,80 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 57d00db35b1fdd85c3ea68c5fdddd0d1d63f7b670e89007b5658006f1f6b1658 + +name: notifications-tray-icon +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/IvanMalison/notifications-tray-icon#readme +bug-reports: https://github.com/IvanMalison/notifications-tray-icon/issues +author: Ivan Malison +maintainer: IvanMalison@gmail.com +copyright: 2018 Ivan Malison +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/IvanMalison/notifications-tray-icon + +library + exposed-modules: + DBus.Proxy + StatusNotifier.Item.Notifications.GitHub + StatusNotifier.Item.Notifications.OverlayIcon + StatusNotifier.Item.Notifications.Util + other-modules: + Paths_notifications_tray_icon + hs-source-dirs: + src + default-extensions: OverloadedStrings + build-depends: + aeson + , async + , base >=4.7 && <5 + , bytestring + , containers + , dbus + , gi-dbusmenu + , gi-gio + , gi-glib + , github >=0.22 + , hslogger + , http-conduit + , http-types + , process + , regex-compat + , status-notifier-item >=0.3.0.0 + , text + , transformers >=0.3.0.0 + , vector + default-language: Haskell2010 + +executable notifications-tray-icon + main-is: Main.hs + other-modules: + Paths_notifications_tray_icon + hs-source-dirs: + app + default-extensions: OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring + , github + , haskeline + , hslogger + , notifications-tray-icon + , optparse-applicative + , text + , transformers + , tuple + default-language: Haskell2010 diff --git a/src/DBus/Proxy.hs b/src/DBus/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/DBus/Proxy.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +module DBus.Proxy where + +import Control.Arrow +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import DBus +import DBus.Client +import DBus.Internal.Message +import qualified DBus.Internal.Types as T +import qualified DBus.Introspection as I +import qualified DBus.TH as DBusTH +import Data.Coerce +import Data.Maybe +import System.Log.Logger + +data ProxyOptions = ProxyOptions Client BusName ObjectPath InterfaceName + +maybeToEither :: b -> Maybe a -> Either b a +maybeToEither = flip maybe Right . Left + +proxyAll :: Client -> BusName -> ObjectPath -> ObjectPath -> IO () +proxyAll client busName pathToProxy registrationPath = either print return =<< runExceptT (do + let introspectionCall = + (methodCall pathToProxy + (interfaceName_ "org.freedesktop.DBus.Introspectable") + "Introspect") + { methodCallDestination = Just busName } + returnValue <- ExceptT $ left methodErrorName <$> call client introspectionCall + obj <- ExceptT $ return $ do + xmlString <- maybeToEither errorInvalidParameters $ + listToMaybe (methodReturnBody returnValue) >>= fromVariant + maybeToEither errorFailed $ I.parseXML "/" xmlString + let interfaces = I.objectInterfaces obj + lift $ do + logM "DBus.Proxy" DEBUG $ show obj + when (length interfaces < 1) $ + logM "DBus.Proxy" WARNING "No interfaces found when attempting to proxy" + mapM_ runInterface interfaces) + where runInterface interface = do + let proxyOptions = ProxyOptions client busName pathToProxy $ + I.interfaceName interface + buildAndRegisterInterface proxyOptions interface registrationPath + +buildAndRegisterInterface :: ProxyOptions -> I.Interface -> ObjectPath -> IO () +buildAndRegisterInterface + options@(ProxyOptions client busName path interfaceName) + introspectionInterface registrationPath = do + let interface = buildInterface options introspectionInterface + export client registrationPath interface + forwardSignals options + +buildInterface :: ProxyOptions -> I.Interface -> Interface +buildInterface options I.Interface + { I.interfaceName = name + , I.interfaceMethods = methods + , I.interfaceProperties = properties + } = Interface + { interfaceName = name + , interfaceMethods = map (buildMethod options) methods + , interfaceProperties = map (buildProperty options) properties + , interfaceSignals = [] + } + +buildReply :: Either MethodError MethodReturn -> Reply +buildReply (Left MethodError { methodErrorName = errorName + , methodErrorBody = body + }) = ReplyError errorName body +buildReply (Right MethodReturn { methodReturnBody = body }) = + ReplyReturn body + +buildMethod :: ProxyOptions -> I.Method -> Method +buildMethod (ProxyOptions client busName path interfaceName) + introspectionMethod = Method + { methodName = I.methodName introspectionMethod + , inSignature = T.Signature [] -- TODO: make signature accurate + , outSignature = T.Signature [] + , methodHandler = lift . handler + } + where handler theMethodCall = + buildReply <$> call client + theMethodCall { methodCallPath = path + , methodCallDestination = Just busName + } + +buildProperty :: ProxyOptions -> I.Property -> Property +buildProperty (ProxyOptions client busName path interfaceName) + introspectionProperty = Property + { propertyName = propName + , propertyType = T.TypeVariant -- TODO: make this accurate + , propertyGetter = Just getter + , propertySetter = Just $ void . setter + } + where propName = memberName_ $ I.propertyName introspectionProperty + baseMethodCall = (methodCall path interfaceName propName) + { methodCallDestination = Just busName} + getter = either (const $ toVariant ("" :: String)) id <$> getProperty client baseMethodCall + setter = setProperty client baseMethodCall + +forwardSignals :: ProxyOptions -> IO () +forwardSignals (ProxyOptions client busName path interfaceName) = do + -- TODO: Handle name owner changes? + let forwardSignal = emit client + updateSignalForwarding = + void $ runExceptT $ do + nameOwnerString <- ExceptT $ DBusTH.getNameOwner client $ coerce busName + let matchRule = matchAny + { matchPath = Just path + , matchInterface = Just interfaceName + , matchSender = Just $ busName_ nameOwnerString + } + lift $ addMatch client matchRule forwardSignal + updateSignalForwarding diff --git a/src/StatusNotifier/Item/Notifications/GitHub.hs b/src/StatusNotifier/Item/Notifications/GitHub.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Item/Notifications/GitHub.hs @@ -0,0 +1,186 @@ +module StatusNotifier.Item.Notifications.GitHub where + +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.MVar as MV +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Either +import Data.Int +import Data.List +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Vector as V +import GI.Dbusmenu +import qualified GitHub.Auth as Auth +import GitHub.Data +import GitHub.Endpoints.Activity.Notifications +import Network.HTTP.Simple +import Network.HTTP.Types +import StatusNotifier.Item.Notifications.Util +import System.Log.Logger +import Text.Printf + +githubAuthFromPass passName = do + Right (token, _) <- passGet passName + return $ Auth.OAuth $ BS.pack token + +ghLog :: Priority -> String -> IO () +ghLog = logM "StatusNotifier.Item.Notifications.GitHub" + +data GitHubConfig = GitHubConfig + { ghAuth :: Auth.Auth + , ghRefreshSeconds :: Rational + } + +defaultGitHubConfig :: Auth -> GitHubConfig +defaultGitHubConfig auth = GitHubConfig + { ghAuth = auth + , ghRefreshSeconds = 20 + } + +githubUpdaterNew config@GitHubConfig + { ghAuth = auth + , ghRefreshSeconds = refreshSeconds + } update = do + + let getNotificationsFromGitHub = getNotifications auth + logAndShow :: (Show v) => Priority -> String -> v -> IO () + logAndShow level message value = + ghLog level $ printf message (show value) + + notificationsVar <- MV.newMVar V.empty + errorVar <- MV.newMVar Nothing + forceRefreshVar <- MV.newEmptyMVar + + let forceRefresh = void $ MV.tryPutMVar forceRefreshVar () + delayedRefresh = void $ forkIO $ threadDelay 1000000 >> forceRefresh + openNotificationsHTML = openURL "https://github.com/notifications" + markAllRead = markNotificationsAsRead auth + getCurrentNotifications = MV.readMVar notificationsVar + buildMenu = do + notifications <- getCurrentNotifications + root <- menuitemNew + mapM_ ((>>= menuitemChildAppend root) . makeNotificationItem config) + notifications + + separatorItem <- menuitemNew + menuitemPropertySet separatorItem MENUITEM_PROP_TYPE CLIENT_TYPES_SEPARATOR + menuitemChildAppend root separatorItem + + markAllReadItem <- makeMenuItemWithLabel "Mark all as read" + onMenuitemItemActivated markAllReadItem $ const $ markAllRead >> delayedRefresh + menuitemChildAppend root markAllReadItem + + viewItem <- makeMenuItemWithLabel "View notifications" + onMenuitemItemActivated viewItem $ const $ void openNotificationsHTML + menuitemChildAppend root viewItem + + refreshItem <- makeMenuItemWithLabel "Refresh" + onMenuitemItemActivated refreshItem $ const forceRefresh + menuitemChildAppend root refreshItem + + return root + updateNotifications newNotifications currentNotifications = + let newSortedIds = sort $ map notificationId $ V.toList newNotifications + oldSortedIds = sort $ map notificationId $ V.toList currentNotifications + in return ( newNotifications + , (newSortedIds /= oldSortedIds + , newSortedIds \\ oldSortedIds + ) + ) + updateError error = do + MV.modifyMVar_ errorVar (const $ return $ Just error) + ghLog ERROR $ printf "Error retrieving notifications %s" $ show error + return (False, []) + updateVariables = + getNotificationsFromGitHub >>= + either updateError (MV.modifyMVar notificationsVar . updateNotifications) + doUpdate = do + newRoot <- buildMenu + notificationsCount <- V.length <$> getCurrentNotifications + update notificationsCount newRoot + sendNotifications newIds = do + notifications <- getCurrentNotifications + let getById id = V.find ((== id) . notificationId) notifications + mapM_ (traverse sendNotification . getById) newIds + sendNotification notification = + runCommandFromPath [ "notify-send" + , "--icon=github" + , getNotificationSummary notification + ] + + void updateVariables + doUpdate + void $ forkIO $ forever $ do + forced <- + isRight <$> race (threadDelay (floor $ refreshSeconds * 1000000)) + (takeMVar forceRefreshVar) + ghLog DEBUG "Refreshing notifications" + (menuNeedsRebuild, newIds) <- updateVariables + sendNotifications newIds + ghLog DEBUG $ printf "Rebuild needed: %s, force: %s" + (show menuNeedsRebuild) (show forced) + when (forced || menuNeedsRebuild) doUpdate + +makeNotificationItem :: GitHubConfig -> Notification -> IO Menuitem +makeNotificationItem GitHubConfig { ghAuth = auth } + notification@Notification + { notificationId = thisNotificationId + + + } = do + let notificationText = T.pack $ getNotificationSummary notification + openHTML = openNotificationHTML auth notification + markAsRead = markNotificationAsRead auth thisNotificationId + + menuItem <- menuitemNewWithId $ fromIntegral $ untagId thisNotificationId + textVariant <- liftIO $ toGVariant notificationText + menuitemPropertySetVariant menuItem "label" textVariant + + markAsReadItem <- makeMenuItemWithLabel "Mark as read" + onMenuitemItemActivated markAsReadItem $ const $ void markAsRead + menuitemChildAppend menuItem markAsReadItem + + viewItem <- makeMenuItemWithLabel "View on GitHub" + onMenuitemItemActivated viewItem $ const openHTML + menuitemChildAppend menuItem viewItem + + return menuItem + +getNotificationSummary :: Notification -> String +getNotificationSummary + Notification + { notificationRepo = + RepoRef + { repoRefRepo = repositoryName } + , notificationSubject = + Subject + { subjectTitle = title } + } = printf "%s - %s" (untagName repositoryName) title + +getOAuthHeader :: Auth -> RequestHeaders +getOAuthHeader (OAuth token) = [("Authorization", "token " <> token)] +getOAuthHeader _ = [] + +openNotificationHTML :: Auth -> Notification -> IO () +openNotificationHTML auth notification = do + let myHeaders = getOAuthHeader auth + <> [("User-Agent", "TaffyBar-GithubNotifier")] + <> [("Accept", "application/json")] + request = setRequestHeaders myHeaders $ parseRequest_ $ T.unpack $ getUrl $ + subjectURL $ notificationSubject notification + response <- httpLBS request + ghLog DEBUG $ printf "Got response from subject url: %s" $ show response + let maybeUrl = getHTMLURL $ getResponseBody response + sequence_ $ openURL . T.unpack <$> maybeUrl + +getHTMLURL :: LBS.ByteString -> Maybe T.Text +getHTMLURL jsonText = decode jsonText >>= parseMaybe (.: "html_url") diff --git a/src/StatusNotifier/Item/Notifications/OverlayIcon.hs b/src/StatusNotifier/Item/Notifications/OverlayIcon.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Item/Notifications/OverlayIcon.hs @@ -0,0 +1,105 @@ +module StatusNotifier.Item.Notifications.OverlayIcon where + +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import DBus +import DBus.Client +import DBus.Proxy +import qualified DBus.TH as DBusTH +import qualified Data.ByteString as BS +import Data.Int +import Data.String +import qualified Data.Text as T +import GI.Dbusmenu +import qualified GI.GLib as GLib +import qualified GI.Gio as Gio +import qualified StatusNotifier.Item.Client as I +import StatusNotifier.Item.Notifications.GitHub +import StatusNotifier.Item.Notifications.Util +import qualified StatusNotifier.Watcher.Client as W +import System.Log.Logger + +type UpdateNotifications = Int -> Menuitem -> IO () + +data OverlayIconParams = OverlayIconParams + { iconName :: String + , iconPath :: String + , iconDBusName :: String + , getOverlayName :: Int -> IO T.Text + , runUpdater :: UpdateNotifications -> IO () + } + +overlayLog = logM "StatusNotifier.Item.Notifications.OverlayIcon" + +buildOverlayIcon OverlayIconParams + { iconName = name + , iconPath = path + , iconDBusName = dbusName + , getOverlayName = getOverlayIconName + , runUpdater = startNotifications + } = do + let menuPathString = path ++ "/Menu" + menuBusString = dbusName ++ ".Menu" + menuPathText = T.pack menuPathString + menuBusText = T.pack menuBusString + iconObjectPath = objectPath_ path + + client <- connectSession + + notificationCount <- newMVar 0 + root <- menuitemNew + currentRoot <- newMVar root + + connection <- Gio.busGetSync Gio.BusTypeSession Gio.noCancellable + Gio.busOwnNameOnConnection connection menuBusText [] Nothing Nothing + menuServer <- serverNew menuPathText + + mainLoop <- GLib.mainLoopNew Nothing False >>= GLib.mainLoopRef + forkIO $ GLib.mainLoopRun mainLoop + context <- GLib.mainLoopGetContext mainLoop + + let runOnMain action = + GLib.mainContextInvokeFull context 4 $ action >> return False + setRoot newRoot = runOnMain $ do + overlayLog DEBUG "Setting new root" + modifyMVar_ currentRoot $ const $ return newRoot + serverSetRoot menuServer newRoot + return False + updateOverlayCount count = do + modifyMVar_ notificationCount $ const $ return count + I.emitNewOverlayIcon client iconObjectPath + updateNotifications count newRoot = void $ + updateOverlayCount count >> setRoot newRoot + proxyMenu = + proxyAll client + (busName_ menuBusString) + (objectPath_ menuPathString) + (objectPath_ menuPathString) + clientInterface = + Interface { interfaceName = "org.kde.StatusNotifierItem" + , interfaceMethods = [] + , interfaceProperties = + [ readOnlyProperty "IconName" $ return name + , readOnlyProperty "OverlayIconName" $ + readMVar notificationCount >>= getOverlayIconName + , readOnlyProperty "Menu" $ return $ objectPath_ menuPathString + ] + , interfaceSignals = [] + } + + export client (fromString path) clientInterface + requestName client (busName_ dbusName) [] + + startNotifications updateNotifications + proxyMenu + + void $ W.registerStatusNotifierItem client dbusName + +sampleUpdater update = void $ forkIO $ forever $ do + root <- menuitemNew + child1 <- makeMenuItemWithLabel "child" + menuitemChildAppend root child1 + update 3 root + threadDelay 100000000 diff --git a/src/StatusNotifier/Item/Notifications/Util.hs b/src/StatusNotifier/Item/Notifications/Util.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Item/Notifications/Util.hs @@ -0,0 +1,62 @@ +module StatusNotifier.Item.Notifications.Util where + +import Control.Arrow +import Control.Monad.Fail +import Control.Monad.IO.Class +import Data.Maybe +import qualified Data.Text as T +import GI.Dbusmenu +import System.Exit (ExitCode (..)) +import System.Log.Logger +import qualified System.Process as P +import Text.Printf +import Text.Regex + +fieldRegex :: Regex +fieldRegex = mkRegexWithOpts "^(.*?): *(.*?)$" True True + +runCommandFromPath :: MonadIO m => [String] -> m (Either String String) +runCommandFromPath = runCommand "/usr/bin/env" + +-- | Run the provided command with the provided arguments. +runCommand :: MonadIO m => FilePath -> [String] -> m (Either String String) +runCommand cmd args = liftIO $ do + (ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args "" + logM "System.Taffybar.Util" INFO $ + printf "Running command %s with args %s" (show cmd) (show args) + return $ case ecode of + ExitSuccess -> Right stdout + ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) stderr + +passGet :: (MonadFail m, MonadIO m) => String -> m (Either String (String, [(String, String)])) +passGet credentialName = + right (getPassComponents . lines) <$> + runCommandFromPath ["pass", "show", credentialName] + where getPassComponents passLines = + let entries = + map buildEntry $ catMaybes $ + matchRegex fieldRegex <$> tail passLines + buildEntry [fieldName, fieldValue] = (fieldName, fieldValue) + buildEntry _ = ("", "") + in (head passLines, entries) + +passGetMain :: (MonadFail m, MonadIO m) => String -> m String +passGetMain name = do + Right (value, _) <- passGet name + return value + +xdgOpen :: MonadIO m => [String] -> m (Either String String) +xdgOpen args = runCommandFromPath ("xdg-open":args) + +openURL :: MonadIO m => String -> m (Either String String) +openURL = xdgOpen . return + +makeMenuItemWithLabel :: T.Text -> IO Menuitem +makeMenuItemWithLabel text = do + menuItem <- menuitemNew + textVariant <- liftIO $ toGVariant text + menuitemPropertySetVariant menuItem "label" textVariant + return menuItem + +makeSeparatorMenuItem :: IO Menuitem +makeSeparatorMenuItem = undefined