notifications-tray-icon (empty) → 0.1.0.0
raw patch · 10 files changed
+767/−0 lines, 10 filesdep +aesondep +asyncdep +basesetup-changed
Dependencies added: aeson, async, base, bytestring, containers, dbus, gi-dbusmenu, gi-gio, gi-glib, github, haskeline, hslogger, http-conduit, http-types, notifications-tray-icon, optparse-applicative, process, regex-compat, status-notifier-item, text, transformers, tuple, vector
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +16/−0
- Setup.hs +2/−0
- app/Main.hs +169/−0
- notifications-tray-icon.cabal +80/−0
- src/DBus/Proxy.hs +114/−0
- src/StatusNotifier/Item/Notifications/GitHub.hs +186/−0
- src/StatusNotifier/Item/Notifications/OverlayIcon.hs +105/−0
- src/StatusNotifier/Item/Notifications/Util.hs +62/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for notifications-tray-icon++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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
+ notifications-tray-icon.cabal view
@@ -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 <https://github.com/IvanMalison/notifications-tray-icon#readme>+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
+ src/DBus/Proxy.hs view
@@ -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
+ src/StatusNotifier/Item/Notifications/GitHub.hs view
@@ -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")
+ src/StatusNotifier/Item/Notifications/OverlayIcon.hs view
@@ -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
+ src/StatusNotifier/Item/Notifications/Util.hs view
@@ -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