notifications-tray-icon 0.1.1.0 → 0.2.0.0
raw patch · 14 files changed
+938/−75 lines, 14 filesdep +directorydep +filepathdep +gogol
Dependencies added: directory, filepath, gogol, gogol-gmail, http-client, mtl, network, resourcet
Files
- ChangeLog.md +12/−1
- app/Main.hs +173/−56
- data/icons/hicolor/index.theme +10/−0
- data/icons/hicolor/scalable/apps/gitea.svg +1/−0
- data/icons/hicolor/scalable/apps/github.svg +1/−0
- data/icons/hicolor/scalable/apps/gmail.svg +7/−0
- data/icons/hicolor/scalable/apps/notification-indicator.svg +3/−0
- notifications-tray-icon.cabal +26/−2
- src/Gitea/API.hs +108/−0
- src/StatusNotifier/Item/Notifications/GitHub.hs +12/−10
- src/StatusNotifier/Item/Notifications/Gitea.hs +135/−0
- src/StatusNotifier/Item/Notifications/Gmail.hs +439/−0
- src/StatusNotifier/Item/Notifications/OverlayIcon.hs +7/−3
- src/StatusNotifier/Item/Notifications/Util.hs +4/−3
ChangeLog.md view
@@ -1,3 +1,14 @@ # Changelog for notifications-tray-icon -## Unreleased changes+## 0.2.0.0++- Add Gmail notification tray icon with browser-based OAuth2 loopback flow+- Add Gitea notification tray icon with REST API client+- Refactor CLI to use subcommands (github, gmail, gitea, sample)+- Bundle SVG icons (gmail, github, gitea, notification-indicator) with IconThemePath+- Fix build compatibility with GHC 9.10 and latest dependencies+- Update CI to use cachix/install-nix-action v30++## 0.1.1.0++- Initial release
app/Main.hs view
@@ -9,77 +9,107 @@ import Data.Tuple.Sequence import Data.Version (showVersion) import qualified GitHub.Auth as GH+import Gitea.API import Options.Applicative+import StatusNotifier.Item.Notifications.Gitea import StatusNotifier.Item.Notifications.GitHub+import StatusNotifier.Item.Notifications.Gmail 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)+import Paths_notifications_tray_icon (version, getDataDir)+import System.FilePath ((</>)) -iconNameParser :: Parser String-iconNameParser = strOption- ( long "icon-name"- <> short 'n'- <> metavar "NAME"- <> value "github"- <> help "The icon the item will display"- )+-- | Shared options that apply to all subcommands.+data SharedOpts = SharedOpts+ { sharedIconName :: Maybe String+ , sharedOverlay :: Maybe String+ , sharedBusName :: Maybe String+ , sharedLogLevel :: Priority+ } -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"- )+sharedOptsParser :: Parser SharedOpts+sharedOptsParser = SharedOpts+ <$> optional (strOption+ ( long "icon-name"+ <> short 'n'+ <> metavar "NAME"+ <> help "The icon the item will display"+ ))+ <*> optional (strOption+ ( long "overlay-icon-name"+ <> short 'o'+ <> metavar "NAME"+ <> help "The overlay icon that will be displayed when notifications are present"+ ))+ <*> optional (strOption+ ( long "bus-name"+ <> short 'b'+ <> metavar "BUS-NAME"+ ))+ <*> option auto+ ( long "log-level"+ <> short 'l'+ <> help "Set the log level"+ <> metavar "LEVEL"+ <> value WARNING+ ) -busNameParser :: Parser String-busNameParser = strOption- ( long "bus-name"- <> short 'b'- <> metavar "BUS-NAME"- <> value "org.Github.Notifications"+-- | Per-subcommand defaults.+data SubcommandDefaults = SubcommandDefaults+ { defaultIconName :: String+ , defaultBusName :: String+ }++-- | Resolve shared options with per-subcommand defaults.+resolveOpts :: SharedOpts -> SubcommandDefaults -> (String, String, String, Priority)+resolveOpts shared defaults =+ ( maybe (defaultIconName defaults) id (sharedIconName shared)+ , maybe "notification-indicator" id (sharedOverlay shared)+ , maybe (defaultBusName defaults) id (sharedBusName shared)+ , sharedLogLevel shared ) +-- GitHub auth parsers++gitConfigGet :: String -> IO String+gitConfigGet key = do+ Right value <- runCommandFromPath ["git", "config", "--get", key]+ return value+ githubTokenAuthParser :: Parser (IO GH.Auth) githubTokenAuthParser = fmap (GH.OAuth . BS.pack . T.unpack . T.strip . T.pack) <$> (passGetMain <$> strOption- ( long "github-token-pass"+ ( long "token-pass" <> metavar "TOKEN-NAME" <> help "Use pass to get a token password to authenticate with github" ) <|> (gitConfigGet <$> strOption- ( long "github-token-config"+ ( long "token-config" <> metavar "TOKEN-KEY" <> help "Get a github token using the provided git config key" )) <|> (return <$> strOption- ( long "github-token-string"+ ( long "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"+ ( long "config-user" <> metavar "USER-KEY" <> help "The git config key to use to get the github user" ) passwordOption = strOption- ( long "github-config-password"+ ( long "config-password" <> metavar "PASSWORD-KEY" <> help "The git config key to use to get the github password" )@@ -102,13 +132,13 @@ githubConsoleAuthParser :: Parser (IO GH.Auth) githubConsoleAuthParser = flag' (githubAuthFromUsernamePassword <$> getUsernameAndPassword) $- long "github-basic-auth"+ long "basic-auth" githubAuthParser = githubTokenAuthParser <|> githubConfigAuthParser <|> githubConsoleAuthParser -githubParser :: Parser (IO GitHubConfig)-githubParser = fmap <$> helper <*> githubAuthParser+githubSubParser :: Parser (IO GitHubConfig)+githubSubParser = fmap <$> helper <*> githubAuthParser where helper = flip GitHubConfig <$> option auto ( long "poll-interval"@@ -117,38 +147,122 @@ <> metavar "SECONDS" ) -updaterParser- = (fmap githubUpdaterNew <$> githubParser)- <|> (flag' (return $ sampleUpdater ) $ long "sample")+-- Gmail parser -logParser =- option auto- ( long "log-level"- <> short 'l'- <> help "Set the log level"- <> metavar "LEVEL"- <> value WARNING+gmailSubParser :: Parser (IO GmailConfig)+gmailSubParser = buildConfig <$> clientIdOption <*> clientSecretOption+ <*> optional tokenFileOption <*> pollIntervalOption+ where+ buildConfig cid secret tokenFile interval = return $ GmailConfig+ { gmailClientId = T.pack cid+ , gmailClientSecret = T.pack secret+ , gmailTokenFile = tokenFile+ , gmailRefreshSeconds = interval+ }+ clientIdOption = strOption+ ( long "client-id"+ <> metavar "CLIENT_ID"+ <> help "Google OAuth2 client ID for Gmail API"+ )+ clientSecretOption = strOption+ ( long "client-secret"+ <> metavar "CLIENT_SECRET"+ <> help "Google OAuth2 client secret for Gmail API"+ )+ tokenFileOption = strOption+ ( long "token-file"+ <> metavar "PATH"+ <> help "Path to store Gmail OAuth token (default: XDG config dir)"+ )+ pollIntervalOption = option auto+ ( long "poll-interval"+ <> help "Seconds between Gmail checks"+ <> value 30+ <> metavar "SECONDS"+ )++-- Gitea parser++giteaSubParser :: Parser (IO GiteaUpdaterConfig)+giteaSubParser = mkConfig <$> baseUrlOption <*> giteaTokenAuthParser <*> pollIntervalOption+ where+ baseUrlOption = strOption+ ( long "url"+ <> metavar "URL"+ <> help "The base URL of the Gitea instance (e.g. https://gitea.example.com)"+ )+ giteaTokenAuthParser = fmap (GiteaToken . BS.pack . T.unpack . T.strip . T.pack) <$>+ (passGetMain <$> strOption+ ( long "token-pass"+ <> metavar "TOKEN-NAME"+ <> help "Use pass to get a token to authenticate with Gitea"+ ) <|>+ (gitConfigGet <$> strOption+ ( long "token-config"+ <> metavar "TOKEN-KEY"+ <> help "Get a Gitea token using the provided git config key"+ )) <|>+ (return <$> strOption+ ( long "token-string"+ <> metavar "TOKEN"+ <> help "Provide the Gitea token as a value"+ )))+ pollIntervalOption = option auto+ ( long "poll-interval"+ <> help "The amount of time to wait between refreshes of notification data"+ <> value 30+ <> metavar "SECONDS"+ )+ mkConfig baseUrl getAuth interval = do+ auth <- getAuth+ return GiteaUpdaterConfig+ { giteaConfig = GiteaConfig { giteaAuth = auth, giteaBaseUrl = baseUrl }+ , giteaRefreshSeconds = interval+ }++-- | Each subcommand returns (IO updater, defaults).+type SubcommandResult = (IO (UpdateNotifications -> IO ()), SubcommandDefaults)++subcommandParser :: Parser SubcommandResult+subcommandParser = hsubparser+ ( command "github" (info+ ((,) <$> (fmap githubUpdaterNew <$> githubSubParser)+ <*> pure (SubcommandDefaults "github" "org.Github.Notifications"))+ (progDesc "GitHub notification tray icon"))+ <> command "gmail" (info+ ((,) <$> (fmap gmailUpdaterNew <$> gmailSubParser)+ <*> pure (SubcommandDefaults "gmail" "org.Gmail.Notifications"))+ (progDesc "Gmail notification tray icon"))+ <> command "gitea" (info+ ((,) <$> (fmap giteaUpdaterNew <$> giteaSubParser)+ <*> pure (SubcommandDefaults "gitea" "org.Gitea.Notifications"))+ (progDesc "Gitea notification tray icon"))+ <> command "sample" (info+ (pure (return sampleUpdater, SubcommandDefaults "github" "org.Sample.Notifications"))+ (progDesc "Sample tray icon for testing")) ) -params iconName overlayIconName busName notifications = OverlayIconParams+mkOverlayIconParams :: String -> String -> String -> String -> (UpdateNotifications -> IO ()) -> OverlayIconParams+mkOverlayIconParams themePath iconName overlayName busName updater = OverlayIconParams { iconName = iconName , iconPath = "/StatusNotifierItem" , iconDBusName = busName- , getOverlayName = \count -> return $ if count > 0 then T.pack overlayIconName else ""- , runUpdater = notifications+ , iconThemePath = Just themePath+ , getOverlayName = \count -> return $ if count > 0 then T.pack overlayName else ""+ , runUpdater = updater } -startOverlayIcon getUpdater iconName overlayIconName logLevel busName = do+run :: SharedOpts -> SubcommandResult -> IO ()+run shared (getUpdater, defaults) = do+ let (iconName, overlayName, busName, logLevel) = resolveOpts shared defaults 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+ dataDir <- getDataDir+ let themePath = dataDir </> "icons"+ updater <- getUpdater+ buildOverlayIcon $ mkOverlayIconParams themePath iconName overlayName busName updater versionOption :: Parser (a -> a) versionOption = infoOption@@ -159,6 +273,9 @@ versionString) ) where versionString = showVersion version++parser :: Parser (IO ())+parser = run <$> sharedOptsParser <*> subcommandParser main :: IO () main = do
+ data/icons/hicolor/index.theme view
@@ -0,0 +1,10 @@+[Icon Theme]+Name=notifications-tray-icon+Comment=Icons for notifications-tray-icon+Directories=scalable/apps++[scalable/apps]+Size=48+MinSize=16+MaxSize=256+Type=Scalable
+ data/icons/hicolor/scalable/apps/gitea.svg view
@@ -0,0 +1,1 @@+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 640 640" width="32" height="32"><path d="M395.9 484.2l-126.9-61c-12.5-6-17.9-21.2-11.8-33.8l61-126.9c6-12.5 21.2-17.9 33.8-11.8 17.2 8.3 27.1 13 27.1 13l-.1-109.2 16.7-.1.1 117.1s57.4 24.2 83.1 40.1c3.7 2.3 10.2 6.8 12.9 14.4 2.1 6.1 2 13.1-1 19.3l-61 126.9c-6.2 12.7-21.4 18.1-33.9 12z" fill="#fff"/><g fill="#609926"><path d="M622.7 149.8c-4.1-4.1-9.6-4-9.6-4s-117.2 6.6-177.9 8c-13.3.3-26.5.6-39.6.7v117.2c-5.5-2.6-11.1-5.3-16.6-7.9 0-36.4-.1-109.2-.1-109.2-29 .4-89.2-2.2-89.2-2.2s-141.4-7.1-156.8-8.5c-9.8-.6-22.5-2.1-39 1.5-8.7 1.8-33.5 7.4-53.8 26.9C-4.9 212.4 6.6 276.2 8 285.8c1.7 11.7 6.9 44.2 31.7 72.5 45.8 56.1 144.4 54.8 144.4 54.8s12.1 28.9 30.6 55.5c25 33.1 50.7 58.9 75.7 62 63 0 188.9-.1 188.9-.1s12 .1 28.3-10.3c14-8.5 26.5-23.4 26.5-23.4S547 483 565 451.5c5.5-9.7 10.1-19.1 14.1-28 0 0 55.2-117.1 55.2-231.1-1.1-34.5-9.6-40.6-11.6-42.6zM125.6 353.9c-25.9-8.5-36.9-18.7-36.9-18.7S69.6 321.8 60 295.4c-16.5-44.2-1.4-71.2-1.4-71.2s8.4-22.5 38.5-30c13.8-3.7 31-3.1 31-3.1s7.1 59.4 15.7 94.2c7.2 29.2 24.8 77.7 24.8 77.7s-26.1-3.1-43-9.1zm300.3 107.6s-6.1 14.5-19.6 15.4c-5.8.4-10.3-1.2-10.3-1.2s-.3-.1-5.3-2.1l-112.9-55s-10.9-5.7-12.8-15.6c-2.2-8.1 2.7-18.1 2.7-18.1L322 273s4.8-9.7 12.2-13c.6-.3 2.3-1 4.5-1.5 8.1-2.1 18 2.8 18 2.8L467.4 315s12.6 5.7 15.3 16.2c1.9 7.4-.5 14-1.8 17.2-6.3 15.4-55 113.1-55 113.1z"/><path d="M326.8 380.1c-8.2.1-15.4 5.8-17.3 13.8-1.9 8 2 16.3 9.1 20 7.7 4 17.5 1.8 22.7-5.4 5.1-7.1 4.3-16.9-1.8-23.1l24-49.1c1.5.1 3.7.2 6.2-.5 4.1-.9 7.1-3.6 7.1-3.6 4.2 1.8 8.6 3.8 13.2 6.1 4.8 2.4 9.3 4.9 13.4 7.3.9.5 1.8 1.1 2.8 1.9 1.6 1.3 3.4 3.1 4.7 5.5 1.9 5.5-1.9 14.9-1.9 14.9-2.3 7.6-18.4 40.6-18.4 40.6-8.1-.2-15.3 5-17.7 12.5-2.6 8.1 1.1 17.3 8.9 21.3 7.8 4 17.4 1.7 22.5-5.3 5-6.8 4.6-16.3-1.1-22.6 1.9-3.7 3.7-7.4 5.6-11.3 5-10.4 13.5-30.4 13.5-30.4.9-1.7 5.7-10.3 2.7-21.3-2.5-11.4-12.6-16.7-12.6-16.7-12.2-7.9-29.2-15.2-29.2-15.2s0-4.1-1.1-7.1c-1.1-3.1-2.8-5.1-3.9-6.3 4.7-9.7 9.4-19.3 14.1-29-4.1-2-8.1-4-12.2-6.1-4.8 9.8-9.7 19.7-14.5 29.5-6.7-.1-12.9 3.5-16.1 9.4-3.4 6.3-2.7 14.1 1.9 19.8l-24.6 50.4z"/></g></svg>
+ data/icons/hicolor/scalable/apps/github.svg view
@@ -0,0 +1,1 @@+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 16 16" class="svg octicon-mark-github" width="16" height="16" aria-hidden="true"><path d="M8 0c4.42 0 8 3.58 8 8a8.01 8.01 0 0 1-5.45 7.59c-.4.08-.55-.17-.55-.38 0-.27.01-1.13.01-2.2 0-.75-.25-1.23-.54-1.48 1.78-.2 3.65-.88 3.65-3.95 0-.88-.31-1.59-.82-2.15.08-.2.36-1.02-.08-2.12 0 0-.67-.22-2.2.82-.64-.18-1.32-.27-2-.27s-1.36.09-2 .27c-1.53-1.03-2.2-.82-2.2-.82-.44 1.1-.16 1.92-.08 2.12-.51.56-.82 1.28-.82 2.15 0 3.06 1.86 3.75 3.64 3.95-.23.2-.44.55-.51 1.07-.46.21-1.61.55-2.33-.66-.15-.24-.6-.83-1.23-.82-.67.01-.27.38.01.53.34.19.73.9.82 1.13.16.45.68 1.31 2.69.94 0 .67.01 1.3.01 1.49 0 .21-.15.45-.55.38A7.995 7.995 0 0 1 0 8c0-4.42 3.58-8 8-8"/></svg>
+ data/icons/hicolor/scalable/apps/gmail.svg view
@@ -0,0 +1,7 @@+<svg xmlns="http://www.w3.org/2000/svg" viewBox="52 42 88 66">+<path fill="#4285f4" d="M58 108h14V74L52 59v43c0 3.32 2.69 6 6 6"/>+<path fill="#34a853" d="M120 108h14c3.32 0 6-2.69 6-6V59l-20 15"/>+<path fill="#fbbc04" d="M120 48v26l20-15v-8c0-7.42-8.47-11.65-14.4-7.2"/>+<path fill="#ea4335" d="M72 74V48l24 18 24-18v26L96 92"/>+<path fill="#c5221f" d="M52 51v8l20 15V48l-5.6-4.2c-5.94-4.45-14.4-.22-14.4 7.2"/>+</svg>
+ data/icons/hicolor/scalable/apps/notification-indicator.svg view
@@ -0,0 +1,3 @@+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 16 16" width="16" height="16">+ <circle cx="12" cy="4" r="4" fill="#e74c3c"/>+</svg>
notifications-tray-icon.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack name: notifications-tray-icon-version: 0.1.1.0+version: 0.2.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@@ -18,6 +18,13 @@ extra-source-files: README.md ChangeLog.md+data-files:+ icons/hicolor/index.theme+ icons/hicolor/scalable/apps/gitea.svg+ icons/hicolor/scalable/apps/github.svg+ icons/hicolor/scalable/apps/gmail.svg+ icons/hicolor/scalable/apps/notification-indicator.svg+data-dir: data source-repository head type: git@@ -26,7 +33,10 @@ library exposed-modules: DBus.Proxy+ Gitea.API+ StatusNotifier.Item.Notifications.Gitea StatusNotifier.Item.Notifications.GitHub+ StatusNotifier.Item.Notifications.Gmail StatusNotifier.Item.Notifications.OverlayIcon StatusNotifier.Item.Notifications.Util other-modules:@@ -35,6 +45,8 @@ src default-extensions: OverloadedStrings+ DataKinds+ TypeFamilies build-depends: aeson , async@@ -42,15 +54,23 @@ , bytestring , containers , dbus+ , directory+ , filepath , gi-dbusmenu , gi-gio , gi-glib , github >=0.24+ , gogol >=1.0+ , gogol-gmail >=1.0 , hslogger+ , http-client , http-conduit , http-types+ , mtl+ , network , process , regex-compat+ , resourcet , status-notifier-item >=0.3.0.0 , text , transformers >=0.3.0.0@@ -65,10 +85,14 @@ app default-extensions: OverloadedStrings+ DataKinds+ TypeFamilies ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , bytestring+ , directory+ , filepath , github , haskeline , hslogger
+ src/Gitea/API.hs view
@@ -0,0 +1,108 @@+module Gitea.API+ ( GiteaAuth(..)+ , GiteaConfig(..)+ , GiteaNotification(..)+ , GiteaNotificationRepo(..)+ , GiteaNotificationSubject(..)+ , getNotifications+ , markNotificationRead+ , markAllNotificationsRead+ ) where++import Data.Aeson+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import Network.HTTP.Simple+import Network.HTTP.Types++data GiteaAuth = GiteaToken BS.ByteString++data GiteaConfig = GiteaConfig+ { giteaAuth :: GiteaAuth+ , giteaBaseUrl :: String+ }++data GiteaNotificationSubject = GiteaNotificationSubject+ { giteaSubjectTitle :: T.Text+ , giteaSubjectUrl :: Maybe T.Text+ , giteaSubjectHtmlUrl :: Maybe T.Text+ , giteaSubjectLatestCommentHtmlUrl :: Maybe T.Text+ , giteaSubjectType :: T.Text+ , giteaSubjectState :: Maybe T.Text+ } deriving (Show)++instance FromJSON GiteaNotificationSubject where+ parseJSON = withObject "GiteaNotificationSubject" $ \v ->+ GiteaNotificationSubject+ <$> v .: "title"+ <*> v .:? "url"+ <*> v .:? "html_url"+ <*> v .:? "latest_comment_html_url"+ <*> v .: "type"+ <*> v .:? "state"++data GiteaNotification = GiteaNotification+ { giteaNotificationId :: Int+ , giteaNotificationRepo :: GiteaNotificationRepo+ , giteaNotificationSubject :: GiteaNotificationSubject+ , giteaNotificationUnread :: Bool+ } deriving (Show)++data GiteaNotificationRepo = GiteaNotificationRepo+ { giteaRepoFullName :: T.Text+ , giteaRepoHtmlUrl :: T.Text+ } deriving (Show)++instance FromJSON GiteaNotificationRepo where+ parseJSON = withObject "GiteaNotificationRepo" $ \v ->+ GiteaNotificationRepo+ <$> v .: "full_name"+ <*> v .: "html_url"++instance FromJSON GiteaNotification where+ parseJSON = withObject "GiteaNotification" $ \v ->+ GiteaNotification+ <$> v .: "id"+ <*> v .: "repository"+ <*> v .: "subject"+ <*> v .: "unread"++authHeaders :: GiteaAuth -> RequestHeaders+authHeaders (GiteaToken token) = [("Authorization", "token " <> token)]++giteaRequest :: GiteaConfig -> String -> Request+giteaRequest GiteaConfig { giteaAuth = auth, giteaBaseUrl = baseUrl } path =+ setRequestHeaders (authHeaders auth <> [("Accept", "application/json")])+ $ parseRequest_ (baseUrl <> "/api/v1" <> path)++getNotifications :: GiteaConfig -> IO (Either String [GiteaNotification])+getNotifications config = do+ let request = giteaRequest config "/notifications"+ response <- httpLBS request+ let status = getResponseStatusCode response+ return $ if status == 200+ then case eitherDecode (getResponseBody response) of+ Left err -> Left $ "JSON decode error: " <> err+ Right ns -> Right ns+ else Left $ "HTTP error: " <> show status++markNotificationRead :: GiteaConfig -> Int -> IO (Either String ())+markNotificationRead config notifId = do+ let request = setRequestMethod "PATCH"+ $ giteaRequest config ("/notifications/threads/" <> show notifId)+ response <- httpLBS request+ let status = getResponseStatusCode response+ return $ if status >= 200 && status < 300+ then Right ()+ else Left $ "HTTP error: " <> show status++markAllNotificationsRead :: GiteaConfig -> IO (Either String ())+markAllNotificationsRead config = do+ let request = setRequestMethod "PUT"+ $ giteaRequest config "/notifications"+ response <- httpLBS request+ let status = getResponseStatusCode response+ return $ if status >= 200 && status < 300+ then Right ()+ else Left $ "HTTP error: " <> show status
src/StatusNotifier/Item/Notifications/GitHub.hs view
@@ -172,16 +172,18 @@ 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+openNotificationHTML auth notification =+ case subjectURL $ notificationSubject notification of+ Nothing -> ghLog WARNING "Notification has no subject URL"+ Just url -> do+ let myHeaders = getOAuthHeader auth+ <> [("User-Agent", "TaffyBar-GithubNotifier")]+ <> [("Accept", "application/json")]+ request = setRequestHeaders myHeaders $ parseRequest_ $ T.unpack $ getUrl url+ 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/Gitea.hs view
@@ -0,0 +1,135 @@+module StatusNotifier.Item.Notifications.Gitea where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.MVar as MV+import Control.Monad+import Data.Either+import Data.List+import qualified Data.Text as T+import GI.Dbusmenu+import Gitea.API+import StatusNotifier.Item.Notifications.Util+import System.Log.Logger+import Text.Printf++giteaLog :: Priority -> String -> IO ()+giteaLog = logM "StatusNotifier.Item.Notifications.Gitea"++data GiteaUpdaterConfig = GiteaUpdaterConfig+ { giteaConfig :: GiteaConfig+ , giteaRefreshSeconds :: Rational+ }++giteaUpdaterNew :: GiteaUpdaterConfig -> (Int -> Menuitem -> IO ()) -> IO ()+giteaUpdaterNew GiteaUpdaterConfig+ { giteaConfig = config+ , giteaRefreshSeconds = refreshSeconds+ } update = do++ notificationsVar <- MV.newMVar []+ errorVar <- MV.newMVar Nothing+ forceRefreshVar <- MV.newEmptyMVar++ let forceRefresh = void $ MV.tryPutMVar forceRefreshVar ()+ delayedRefresh = void $ forkIO $ threadDelay 1000000 >> forceRefresh+ openNotificationsHTML =+ openURL $ giteaBaseUrl config <> "/notifications"+ markAllRead = void $ markAllNotificationsRead config+ getCurrentNotifications = MV.readMVar notificationsVar+ buildMenu = do+ notifications <- getCurrentNotifications+ root <- menuitemNew+ mapM_ ((>>= menuitemChildAppend root) . makeGiteaNotificationItem 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 giteaNotificationId newNotifications+ oldSortedIds = sort $ map giteaNotificationId currentNotifications+ in return ( newNotifications+ , (newSortedIds /= oldSortedIds+ , newSortedIds \\ oldSortedIds+ )+ )+ updateError err = do+ MV.modifyMVar_ errorVar (const $ return $ Just err)+ giteaLog ERROR $ printf "Error retrieving notifications %s" err+ return (False, [])+ updateVariables =+ getNotifications config >>=+ either updateError (MV.modifyMVar notificationsVar . updateNotifications)+ doUpdate = do+ newRoot <- buildMenu+ notificationsCount <- length <$> getCurrentNotifications+ update notificationsCount newRoot+ sendNotifications newIds = do+ notifications <- getCurrentNotifications+ let getById nid = find ((== nid) . giteaNotificationId) notifications+ mapM_ (traverse sendNotification . getById) newIds+ sendNotification notification =+ runCommandFromPath [ "notify-send"+ , "--icon=gitea"+ , getGiteaNotificationSummary notification+ ]++ void updateVariables+ doUpdate+ void $ forkIO $ forever $ do+ forced <-+ isRight <$> race (threadDelay (floor $ refreshSeconds * 1000000))+ (takeMVar forceRefreshVar)+ giteaLog DEBUG "Refreshing notifications"+ (menuNeedsRebuild, newIds) <- updateVariables+ sendNotifications newIds+ giteaLog DEBUG $ printf "Rebuild needed: %s, force: %s"+ (show menuNeedsRebuild) (show forced)+ when (forced || menuNeedsRebuild) doUpdate++makeGiteaNotificationItem :: GiteaConfig -> GiteaNotification -> IO Menuitem+makeGiteaNotificationItem config notification = do+ let notifId = giteaNotificationId notification+ notificationText = T.pack $ getGiteaNotificationSummary notification+ subject = giteaNotificationSubject notification+ openHTML = case giteaSubjectHtmlUrl subject of+ Just url -> void $ openURL $ T.unpack url+ Nothing -> case giteaSubjectLatestCommentHtmlUrl subject of+ Just url -> void $ openURL $ T.unpack url+ Nothing -> giteaLog WARNING "Notification has no HTML URL"+ markAsRead = void $ markNotificationRead config notifId++ menuItem <- menuitemNewWithId $ fromIntegral notifId+ textVariant <- toGVariant notificationText+ menuitemPropertySetVariant menuItem "label" textVariant++ markAsReadItem <- makeMenuItemWithLabel "Mark as read"+ onMenuitemItemActivated markAsReadItem $ const markAsRead+ menuitemChildAppend menuItem markAsReadItem++ viewItem <- makeMenuItemWithLabel "View on Gitea"+ onMenuitemItemActivated viewItem $ const openHTML+ menuitemChildAppend menuItem viewItem++ return menuItem++getGiteaNotificationSummary :: GiteaNotification -> String+getGiteaNotificationSummary notification =+ printf "%s - %s"+ (T.unpack $ giteaRepoFullName $ giteaNotificationRepo notification)+ (T.unpack $ giteaSubjectTitle $ giteaNotificationSubject notification)
+ src/StatusNotifier/Item/Notifications/Gmail.hs view
@@ -0,0 +1,439 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module StatusNotifier.Item.Notifications.Gmail+ ( GmailConfig(..)+ , defaultGmailConfig+ , setupGmailEnv+ , gmailUpdaterNew+ ) where++import Control.Concurrent+import Control.Concurrent.Async (race)+import Control.Concurrent.MVar as MV+import Control.Exception (SomeException, bracket, try)+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.ByteString.Char8 as BS8+import Data.Either (isRight)+import Data.List (sort, (\\))+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Proxy (Proxy(..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import GI.Dbusmenu+import Gogol+ ( Env+ , LogLevel(..)+ , newEnvWith+ , newLogger+ , send+ , runResourceT+ )+import Gogol.Auth+ ( OAuthClient(..)+ , OAuthCode(..)+ , ClientId(..)+ , GSecret(..)+ , saveAuthorizedUser+ , fromFilePath+ )+import Gogol.Auth.Scope (KnownScopes(..), queryEncodeScopes)+import Gogol.Internal.Auth+ ( AuthorizedUser(..)+ , OAuthToken(..)+ , accountsURL+ , refreshRequest+ , textBody+ , tokenRequest+ )+import qualified Gogol.Internal.Logger as GLogger+import Gogol.Prelude (toQueryParam)+import Gogol.Gmail+ ( GmailUsersMessagesList(..)+ , GmailUsersMessagesGet(..)+ , GmailUsersMessagesModify(..)+ , ListMessagesResponse(..)+ , Message(..)+ , MessagePart(..)+ , MessagePartHeader(..)+ , ModifyMessageRequest(..)+ , UsersMessagesGetFormat(..)+ , Gmail'Modify+ , newGmailUsersMessagesList+ , newGmailUsersMessagesGet+ , newGmailUsersMessagesModify+ , newModifyMessageRequest+ )+import Network.HTTP.Conduit (newManager, tlsManagerSettings)+import qualified Network.HTTP.Client as Client+import Network.Socket+import Network.Socket.ByteString (recv, sendAll)+import StatusNotifier.Item.Notifications.Util+import System.Directory (createDirectoryIfMissing, doesFileExist, getXdgDirectory, XdgDirectory(..))+import System.FilePath ((</>))+import System.IO (hFlush, stdout)+import System.Log.Logger+import Text.Printf++-- | Configuration for the Gmail notifier.+data GmailConfig = GmailConfig+ { gmailClientId :: T.Text+ , gmailClientSecret :: T.Text+ , gmailTokenFile :: Maybe FilePath+ , gmailRefreshSeconds :: Rational+ }++-- | Create a default config. You must provide client ID and secret.+defaultGmailConfig :: T.Text -> T.Text -> GmailConfig+defaultGmailConfig cid csecret = GmailConfig+ { gmailClientId = cid+ , gmailClientSecret = csecret+ , gmailTokenFile = Nothing+ , gmailRefreshSeconds = 30+ }++gmailLog :: Priority -> String -> IO ()+gmailLog = logM "StatusNotifier.Item.Notifications.Gmail"++-- | Extract the message ID from a Message, avoiding conflict with Prelude.id.+messageId :: Message -> Maybe T.Text+messageId Message{id = mid} = mid++-- | A summary of a Gmail message for display.+data MessageSummary = MessageSummary+ { msId :: T.Text+ , msSender :: T.Text+ , msSubject :: T.Text+ , msSnippet :: T.Text+ } deriving (Show, Eq)++-- | Determine the token file path, defaulting to XDG config directory.+getTokenFilePath :: GmailConfig -> IO FilePath+getTokenFilePath GmailConfig{..} =+ case gmailTokenFile of+ Just fp -> return fp+ Nothing -> do+ dir <- getXdgDirectory XdgConfig "notifications-tray-icon"+ createDirectoryIfMissing True dir+ return $ dir </> "gmail-token.json"++-- | Build an OAuth2 authorization URL with a loopback redirect URI.+loopbackAuthURL :: OAuthClient -> Int -> T.Text+loopbackAuthURL client port =+ accountsURL+ <> "?response_type=code"+ <> "&client_id=" <> toQueryParam (_clientId client)+ <> "&redirect_uri=" <> loopbackRedirectURI port+ <> "&scope=" <> T.decodeUtf8 (queryEncodeScopes (scopeVals (Proxy :: Proxy '[Gmail'Modify])))+ <> "&access_type=offline"++loopbackRedirectURI :: Int -> T.Text+loopbackRedirectURI port = "http://localhost:" <> T.pack (show port)++-- | Exchange an authorization code for a token using the loopback redirect URI.+exchangeCodeLoopback+ :: OAuthClient -> OAuthCode s -> Int+ -> GLogger.Logger+ -> Client.Manager -> IO (OAuthToken s)+exchangeCodeLoopback client code port =+ refreshRequest $+ tokenRequest+ { Client.requestBody = textBody $+ "grant_type=authorization_code"+ <> "&client_id=" <> toQueryParam (_clientId client)+ <> "&client_secret=" <> toQueryParam (_clientSecret client)+ <> "&code=" <> toQueryParam code+ <> "&redirect_uri=" <> loopbackRedirectURI port+ }++-- | Start a temporary HTTP server, wait for the OAuth redirect, extract the code.+waitForOAuthRedirect :: Int -> IO T.Text+waitForOAuthRedirect port = do+ let hints = defaultHints { addrSocketType = Stream, addrFlags = [AI_PASSIVE] }+ addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show port)+ bracket (openSocket addr) close $ \sock -> do+ setSocketOption sock ReuseAddr 1+ bind sock (addrAddress addr)+ listen sock 1+ (conn, _) <- accept sock+ request <- recv conn 4096+ let code = extractCodeFromRequest request+ responseBody = case code of+ Just _ -> "Authorization successful! You can close this window."+ Nothing -> "Authorization failed. No code received."+ response = BS8.unlines+ [ "HTTP/1.1 200 OK"+ , "Content-Type: text/plain"+ , "Connection: close"+ , ""+ , responseBody+ ]+ sendAll conn response+ close conn+ case code of+ Just c -> return c+ Nothing -> fail "No authorization code received in OAuth redirect"++-- | Extract the 'code' query parameter from an HTTP GET request.+extractCodeFromRequest :: BS8.ByteString -> Maybe T.Text+extractCodeFromRequest req = do+ firstLine <- case BS8.lines req of+ (l:_) -> Just l+ [] -> Nothing+ -- Parse "GET /path?code=xxx&... HTTP/1.1"+ path <- case BS8.words firstLine of+ (_:p:_) -> Just p+ _ -> Nothing+ let query = BS8.dropWhile (/= '?') path+ params = parseQueryParams (BS8.drop 1 query) -- drop the '?'+ lookup "code" params++-- | Parse query parameters from a query string like "code=xxx&scope=yyy"+parseQueryParams :: BS8.ByteString -> [(BS8.ByteString, T.Text)]+parseQueryParams qs =+ [ (key, T.decodeUtf8 val)+ | part <- BS8.split '&' qs+ , let (key, rest) = BS8.break (== '=') part+ val = BS8.drop 1 rest -- drop the '='+ , not (BS8.null key)+ ]++-- | Set up a gogol Env for Gmail with Gmail'Modify scope.+--+-- If a saved token file exists, loads credentials from it.+-- Otherwise, runs the OAuth2 loopback flow: opens the browser,+-- captures the redirect on localhost, exchanges the code, and saves the token.+setupGmailEnv :: GmailConfig -> IO (Env '[Gmail'Modify])+setupGmailEnv config@GmailConfig{..} = do+ tokenPath <- getTokenFilePath config+ mgr <- newManager tlsManagerSettings+ lgr <- newLogger Error stdout++ let client = OAuthClient+ { _clientId = ClientId gmailClientId+ , _clientSecret = GSecret gmailClientSecret+ }++ exists <- doesFileExist tokenPath+ if exists+ then do+ gmailLog INFO $ printf "Loading saved token from %s" tokenPath+ creds <- fromFilePath tokenPath+ newEnvWith creds lgr mgr+ else do+ let port = 8914+ authUrl = loopbackAuthURL client port+ gmailLog INFO "Starting OAuth2 loopback flow"+ putStrLn "Opening browser for Gmail authorization..."+ void $ xdgOpen [T.unpack authUrl]+ putStrLn $ "Waiting for authorization redirect on port " ++ show port ++ "..."+ code <- waitForOAuthRedirect port+ gmailLog INFO "Authorization code received"++ -- Exchange the code ourselves (with matching loopback redirect_uri)+ token <- exchangeCodeLoopback client+ (OAuthCode code :: OAuthCode '[Gmail'Modify])+ port lgr mgr++ -- Build an AuthorizedUser from the exchange result and save it+ let authorizedUser = AuthorizedUser+ { _userId = _clientId client+ , _userRefresh = case _tokenRefresh token of+ Just r -> r+ Nothing -> error "OAuth token exchange did not return a refresh token"+ , _userSecret = _clientSecret client+ }+ saveAuthorizedUser tokenPath True authorizedUser+ gmailLog INFO $ printf "Token saved to %s" tokenPath++ -- Now load from the saved file to create the Env+ creds <- fromFilePath tokenPath+ newEnvWith creds lgr mgr++-- | Extract a header value by name from a Message's payload headers.+getHeader :: T.Text -> Message -> Maybe T.Text+getHeader headerName msg = do+ part <- msg.payload+ hdrs <- part.headers+ let matching = filter (\h -> h.name == Just headerName) hdrs+ case matching of+ (h:_) -> h.value+ [] -> Nothing++-- | Build a MessageSummary from a full Message response.+getMessageSummary :: Message -> Maybe MessageSummary+getMessageSummary msg = do+ msgId <- messageId msg+ let sender = fromMaybe "(unknown)" $ getHeader "From" msg+ subject = fromMaybe "(no subject)" $ getHeader "Subject" msg+ snip = fromMaybe "" msg.snippet+ return MessageSummary+ { msId = msgId+ , msSender = sender+ , msSubject = subject+ , msSnippet = snip+ }++-- | Shorten a sender string for display. Extracts just the name part+-- from "Name <email>" format, or returns as-is.+shortenSender :: T.Text -> T.Text+shortenSender s+ | T.null before = s+ | otherwise = T.strip before+ where+ before = T.takeWhile (/= '<') s++-- | Format a notification summary string for display.+formatSummary :: MessageSummary -> String+formatSummary MessageSummary{..} =+ printf "%s - %s" (T.unpack $ shortenSender msSender) (T.unpack msSubject)++-- | Create a menu item for a single Gmail message.+makeGmailMenuItem :: Env '[Gmail'Modify] -> IO () -> MessageSummary -> IO Menuitem+makeGmailMenuItem env onMarkedRead summary@MessageSummary{..} = do+ menuItem <- menuitemNew+ let label = T.pack $ formatSummary summary+ textVariant <- liftIO $ toGVariant label+ menuitemPropertySetVariant menuItem "label" textVariant++ -- Sub-items: mark as read & open in browser+ markReadItem <- makeMenuItemWithLabel "Mark as read"+ onMenuitemItemActivated markReadItem $ const $ void $ forkIO $ do+ let modReq = newModifyMessageRequest+ { removeLabelIds = Just ["UNREAD"]+ }+ result <- try $ runResourceT $ send env (newGmailUsersMessagesModify msId modReq)+ case (result :: Either SomeException Message) of+ Right _ -> do+ gmailLog DEBUG $ printf "Marked message %s as read" (T.unpack msId)+ onMarkedRead+ Left err -> gmailLog ERROR $ printf "Failed to mark %s as read: %s" (T.unpack msId) (show err)+ menuitemChildAppend menuItem markReadItem++ openItem <- makeMenuItemWithLabel "Open in Gmail"+ onMenuitemItemActivated openItem $ const $+ void $ openURL $ "https://mail.google.com/mail/u/0/#inbox/" ++ T.unpack msId+ menuitemChildAppend menuItem openItem++ return menuItem++-- | The main updater function. Polls Gmail for unread inbox messages,+-- builds a tray menu, and sends desktop notifications for new arrivals.+--+-- Signature matches what OverlayIcon expects:+-- @GmailConfig -> (Int -> Menuitem -> IO ()) -> IO ()@+gmailUpdaterNew :: GmailConfig+ -> (Int -> Menuitem -> IO ())+ -> IO ()+gmailUpdaterNew config update = do+ env <- setupGmailEnv config++ summariesVar <- MV.newMVar []+ errorVar <- MV.newMVar (Nothing :: Maybe String)+ forceRefreshVar <- MV.newEmptyMVar++ let forceRefresh = void $ MV.tryPutMVar forceRefreshVar ()+ delayedRefresh = void $ forkIO $ threadDelay 1000000 >> forceRefresh+ refreshSeconds = gmailRefreshSeconds config++ -- Fetch the list of unread inbox messages and retrieve their metadata.+ fetchMessages :: IO (Either String [MessageSummary])+ fetchMessages = do+ result <- try $ runResourceT $ do+ let listReq = newGmailUsersMessagesList+ { q = Just "is:unread in:inbox"+ , maxResults = 50+ }+ listResp <- send env listReq+ let msgStubs = fromMaybe [] listResp.messages+ msgIds = mapMaybe (\m -> messageId m) msgStubs+ forM msgIds $ \mid' -> do+ let getReq = (newGmailUsersMessagesGet mid')+ { format = UsersMessagesGetFormat_Metadata+ , metadataHeaders = Just ["From", "Subject"]+ }+ send env getReq+ case (result :: Either SomeException [Message]) of+ Left err -> return $ Left $ show err+ Right msgs -> return $ Right $ mapMaybe getMessageSummary msgs++ getCurrentSummaries = MV.readMVar summariesVar++ buildMenu = do+ sums <- getCurrentSummaries+ root <- menuitemNew+ mapM_ (\s -> makeGmailMenuItem env delayedRefresh s >>= menuitemChildAppend root) sums++ separatorItem <- menuitemNew+ menuitemPropertySet separatorItem MENUITEM_PROP_TYPE CLIENT_TYPES_SEPARATOR+ menuitemChildAppend root separatorItem++ openInboxItem <- makeMenuItemWithLabel "Open Gmail"+ onMenuitemItemActivated openInboxItem $ const $+ void $ openURL "https://mail.google.com"+ menuitemChildAppend root openInboxItem++ refreshItem <- makeMenuItemWithLabel "Refresh"+ onMenuitemItemActivated refreshItem $ const forceRefresh+ menuitemChildAppend root refreshItem++ return root++ updateVariables = do+ result <- fetchMessages+ case result of+ Left err -> do+ MV.modifyMVar_ errorVar (const $ return $ Just err)+ gmailLog ERROR $ printf "Error fetching Gmail: %s" err+ return (False, [])+ Right newSummaries -> do+ MV.modifyMVar_ errorVar (const $ return Nothing)+ MV.modifyMVar summariesVar $ \oldSummaries -> do+ let newIds = sort $ map msId newSummaries+ oldIds = sort $ map msId oldSummaries+ return ( newSummaries+ , ( newIds /= oldIds+ , newIds \\ oldIds+ )+ )++ doUpdate = do+ newRoot <- buildMenu+ count <- length <$> getCurrentSummaries+ update count newRoot++ sendNotifications newIds = do+ sums <- getCurrentSummaries+ let getById i = filter ((== i) . msId) sums+ forM_ newIds $ \i ->+ case getById i of+ (s:_) -> sendNotification s+ [] -> return ()++ sendNotification summary =+ void $ runCommandFromPath+ [ "notify-send"+ , "--icon=mail-unread"+ , T.unpack $ shortenSender $ msSender summary+ , T.unpack $ msSubject summary+ ]++ -- Initial fetch and menu build+ void updateVariables+ doUpdate++ -- Polling loop+ void $ forkIO $ forever $ do+ forced <-+ isRight <$> race (threadDelay (floor $ refreshSeconds * 1000000))+ (takeMVar forceRefreshVar)+ gmailLog DEBUG "Refreshing Gmail notifications"+ (menuNeedsRebuild, newIds) <- updateVariables+ sendNotifications newIds+ gmailLog DEBUG $ printf "Gmail rebuild needed: %s, force: %s"+ (show menuNeedsRebuild) (show forced)+ when (forced || menuNeedsRebuild) doUpdate
src/StatusNotifier/Item/Notifications/OverlayIcon.hs view
@@ -16,7 +16,6 @@ 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@@ -28,6 +27,7 @@ { iconName :: String , iconPath :: String , iconDBusName :: String+ , iconThemePath :: Maybe String , getOverlayName :: Int -> IO T.Text , runUpdater :: UpdateNotifications -> IO () }@@ -38,6 +38,7 @@ { iconName = name , iconPath = path , iconDBusName = dbusName+ , iconThemePath = maybeThemePath , getOverlayName = getOverlayIconName , runUpdater = startNotifications } = do@@ -63,7 +64,7 @@ context <- GLib.mainLoopGetContext mainLoop let runOnMain action =- GLib.mainContextInvokeFull context 4 $ action >> return False+ GLib.mainContextInvokeFull (Just context) 4 $ action >> return False setRoot newRoot = runOnMain $ do overlayLog DEBUG "Setting new root" modifyMVar_ currentRoot $ const $ return newRoot@@ -79,6 +80,9 @@ (busName_ menuBusString) (objectPath_ menuPathString) (objectPath_ menuPathString)+ themePathProps = case maybeThemePath of+ Just tp -> [readOnlyProperty "IconThemePath" $ return tp]+ Nothing -> [] clientInterface = Interface { interfaceName = "org.kde.StatusNotifierItem" , interfaceMethods = []@@ -87,7 +91,7 @@ , readOnlyProperty "OverlayIconName" $ readMVar notificationCount >>= getOverlayIconName , readOnlyProperty "Menu" $ return $ objectPath_ menuPathString- ]+ ] ++ themePathProps , interfaceSignals = [] }
src/StatusNotifier/Item/Notifications/Util.hs view
@@ -32,13 +32,14 @@ passGet credentialName = right (getPassComponents . lines) <$> runCommandFromPath ["pass", "show", credentialName]- where getPassComponents passLines =+ where getPassComponents [] = ("", [])+ getPassComponents (firstLine:restLines) = let entries = map buildEntry $ catMaybes $- matchRegex fieldRegex <$> tail passLines+ matchRegex fieldRegex <$> restLines buildEntry [fieldName, fieldValue] = (fieldName, fieldValue) buildEntry _ = ("", "")- in (head passLines, entries)+ in (firstLine, entries) passGetMain :: (MonadFail m, MonadIO m) => String -> m String passGetMain name = do