notifications-tray-icon 0.2.0.1 → 0.2.1.0
raw patch · 6 files changed
+235/−88 lines, 6 filesdep ~aesondep ~asyncdep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: aeson, async, bytestring, containers, dbus, directory, filepath, gi-dbusmenu, gi-gio, gi-glib, github, gogol, gogol-gmail, haskeline, hslogger, http-client, http-conduit, http-types, mtl, network, optparse-applicative, process, regex-compat, resourcet, status-notifier-item, text, transformers, tuple, vector
API changes (from Hackage documentation)
+ StatusNotifier.Item.Notifications.Util: runDetached :: [String] -> IO (Either String String)
+ StatusNotifier.Item.Notifications.Util: sendDesktopNotification :: Client -> Text -> Text -> Text -> Text -> IO (Either String Word32)
Files
- ChangeLog.md +13/−0
- notifications-tray-icon.cabal +39/−37
- src/StatusNotifier/Item/Notifications/GitHub.hs +15/−10
- src/StatusNotifier/Item/Notifications/Gitea.hs +14/−9
- src/StatusNotifier/Item/Notifications/Gmail.hs +89/−30
- src/StatusNotifier/Item/Notifications/Util.hs +65/−2
ChangeLog.md view
@@ -1,5 +1,18 @@ # Changelog for notifications-tray-icon +## 0.2.1.0++- Send Gmail desktop notifications directly over D-Bus instead of shelling out to `notify-send`+- Add `sendDesktopNotification` to `StatusNotifier.Item.Notifications.Util`+- Add "Mark all as read" menu item to the Gmail tray icon+- Fix Gmail OAuth URL/form encoding and start the redirect listener before opening the browser+- Open URLs through `systemd-run --user` so browsers are not parented to the tray service+- Let dbusmenu assign ids to GitHub notification menu items instead of reusing notification ids++## 0.2.0.2++- Fix polling threads silently dying on transient network errors+ ## 0.2.0.0 - Add Gmail notification tray icon with browser-based OAuth2 loopback flow
notifications-tray-icon.cabal view
@@ -5,8 +5,10 @@ -- see: https://github.com/sol/hpack name: notifications-tray-icon-version: 0.2.0.1+version: 0.2.1.0+synopsis: System tray icons for GitHub, Gitea, and Gmail notifications description: Please see the README on GitHub at <https://github.com/IvanMalison/notifications-tray-icon#readme>+category: Desktop homepage: https://github.com/IvanMalison/notifications-tray-icon#readme bug-reports: https://github.com/IvanMalison/notifications-tray-icon/issues author: Ivan Malison@@ -48,33 +50,33 @@ DataKinds TypeFamilies build-depends:- aeson- , async+ aeson >=2.0 && <2.3+ , async <2.3 , base >=4.7 && <5- , 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- , vector+ , bytestring <0.13+ , containers <0.8+ , dbus >=1.2 && <1.5+ , directory <1.4+ , filepath <1.6+ , gi-dbusmenu <0.5+ , gi-gio <2.1+ , gi-glib <2.1+ , github >=0.24 && <0.31+ , gogol ==1.0.*+ , gogol-gmail ==1.0.*+ , hslogger <1.4+ , http-client <0.8+ , http-conduit <2.4+ , http-types <0.13+ , mtl <2.4+ , network <3.3+ , process <1.7+ , regex-compat <0.96+ , resourcet <1.4+ , status-notifier-item >=0.3.0.0 && <0.4+ , text <2.2+ , transformers >=0.3.0.0 && <0.7+ , vector <0.14 default-language: Haskell2010 executable notifications-tray-icon@@ -90,15 +92,15 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5- , bytestring- , directory- , filepath- , github- , haskeline- , hslogger+ , bytestring <0.13+ , directory <1.4+ , filepath <1.6+ , github >=0.24 && <0.31+ , haskeline <0.9+ , hslogger <1.4 , notifications-tray-icon- , optparse-applicative- , text- , transformers- , tuple+ , optparse-applicative <0.19+ , text <2.2+ , transformers >=0.3.0.0 && <0.7+ , tuple <0.4 default-language: Haskell2010
src/StatusNotifier/Item/Notifications/GitHub.hs view
@@ -4,6 +4,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.MVar as MV+import Control.Exception (SomeException, try) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class@@ -121,15 +122,19 @@ 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+ result <- try $ 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+ case (result :: Either SomeException ()) of+ Right () -> return ()+ Left err -> ghLog ERROR $ printf "Exception in polling loop: %s" (show err) makeNotificationItem :: GitHubConfig -> Notification -> IO Menuitem makeNotificationItem GitHubConfig { ghAuth = auth }@@ -142,7 +147,7 @@ openHTML = openNotificationHTML auth notification markAsRead = executeRequest auth $ markNotificationAsReadR thisNotificationId - menuItem <- menuitemNewWithId $ fromIntegral $ untagId thisNotificationId+ menuItem <- menuitemNew textVariant <- liftIO $ toGVariant notificationText menuitemPropertySetVariant menuItem "label" textVariant
src/StatusNotifier/Item/Notifications/Gitea.hs view
@@ -3,6 +3,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.MVar as MV+import Control.Exception (SomeException, try) import Control.Monad import Data.Either import Data.List@@ -92,15 +93,19 @@ 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+ result <- try $ 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+ case (result :: Either SomeException ()) of+ Right () -> return ()+ Left err -> giteaLog ERROR $ printf "Exception in polling loop: %s" (show err) makeGiteaNotificationItem :: GiteaConfig -> GiteaNotification -> IO Menuitem makeGiteaNotificationItem config notification = do
src/StatusNotifier/Item/Notifications/Gmail.hs view
@@ -12,7 +12,7 @@ ) where import Control.Concurrent-import Control.Concurrent.Async (race)+import Control.Concurrent.Async (race, wait, withAsync) import Control.Concurrent.MVar as MV import Control.Exception (SomeException, bracket, try) import Control.Monad@@ -24,6 +24,7 @@ import Data.Proxy (Proxy(..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T+import DBus.Client (connectSession) import GI.Dbusmenu import Gogol ( Env@@ -56,6 +57,8 @@ ( GmailUsersMessagesList(..) , GmailUsersMessagesGet(..) , GmailUsersMessagesModify(..)+ , GmailUsersMessagesBatchModify(..)+ , BatchModifyMessagesRequest(..) , ListMessagesResponse(..) , Message(..) , MessagePart(..)@@ -66,17 +69,21 @@ , newGmailUsersMessagesList , newGmailUsersMessagesGet , newGmailUsersMessagesModify+ , newGmailUsersMessagesBatchModify+ , newBatchModifyMessagesRequest , newModifyMessageRequest ) import Network.HTTP.Conduit (newManager, tlsManagerSettings) import qualified Network.HTTP.Client as Client import Network.Socket import Network.Socket.ByteString (recv, sendAll)+import Network.HTTP.Types.URI (urlDecode, urlEncode) 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 qualified System.Process as P import Text.Printf -- | Configuration for the Gmail notifier.@@ -126,14 +133,23 @@ loopbackAuthURL client port = accountsURL <> "?response_type=code"- <> "&client_id=" <> toQueryParam (_clientId client)- <> "&redirect_uri=" <> loopbackRedirectURI port+ <> "&client_id=" <> urlEncodeText (toQueryParam (_clientId client))+ <> "&redirect_uri=" <> urlEncodeText (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) +urlEncodeText :: T.Text -> T.Text+urlEncodeText = T.decodeUtf8 . urlEncode True . T.encodeUtf8++urlDecodeText :: BS8.ByteString -> T.Text+urlDecodeText = T.decodeUtf8 . urlDecode True++formParam :: T.Text -> T.Text -> T.Text+formParam key value = key <> "=" <> urlEncodeText value+ -- | Exchange an authorization code for a token using the loopback redirect URI. exchangeCodeLoopback :: OAuthClient -> OAuthCode s -> Int@@ -142,14 +158,31 @@ 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+ { Client.requestBody = textBody $ T.intercalate "&"+ [ formParam "grant_type" "authorization_code"+ , formParam "client_id" (toQueryParam (_clientId client))+ , formParam "client_secret" (toQueryParam (_clientSecret client))+ , formParam "code" (toQueryParam code)+ , formParam "redirect_uri" (loopbackRedirectURI port)+ ] } +-- | Open the authorization URL without waiting for the browser process.+--+-- xdg-open can remain parented to the browser on some desktop sessions. If we+-- wait for it, the OAuth redirect listener never starts and Google redirects to+-- a closed localhost port.+openBrowserDetached :: T.Text -> IO ()+openBrowserDetached url = do+ let process =+ (P.proc "/usr/bin/env" ["xdg-open", T.unpack url])+ { P.std_in = P.NoStream+ , P.std_out = P.NoStream+ , P.std_err = P.NoStream+ , P.close_fds = True+ }+ void $ P.createProcess process+ -- | Start a temporary HTTP server, wait for the OAuth redirect, extract the code. waitForOAuthRedirect :: Int -> IO T.Text waitForOAuthRedirect port = do@@ -195,7 +228,7 @@ -- | 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)+ [ (key, urlDecodeText val) | part <- BS8.split '&' qs , let (key, rest) = BS8.break (== '=') part val = BS8.drop 1 rest -- drop the '='@@ -229,9 +262,11 @@ 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+ code <- withAsync (waitForOAuthRedirect port) $ \redirectWaiter -> do+ threadDelay 100000+ openBrowserDetached authUrl+ wait redirectWaiter gmailLog INFO "Authorization code received" -- Exchange the code ourselves (with matching loopback redirect_uri)@@ -303,8 +338,9 @@ -- 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"]+ let modReq = ModifyMessageRequest+ { addLabelIds = Nothing+ , removeLabelIds = Just ["UNREAD"] } result <- try $ runResourceT $ send env (newGmailUsersMessagesModify msId modReq) case (result :: Either SomeException Message) of@@ -331,6 +367,7 @@ -> IO () gmailUpdaterNew config update = do env <- setupGmailEnv config+ notificationClient <- connectSession summariesVar <- MV.newMVar [] errorVar <- MV.newMVar (Nothing :: Maybe String)@@ -372,6 +409,22 @@ menuitemPropertySet separatorItem MENUITEM_PROP_TYPE CLIENT_TYPES_SEPARATOR menuitemChildAppend root separatorItem + markAllReadItem <- makeMenuItemWithLabel "Mark all as read"+ onMenuitemItemActivated markAllReadItem $ const $ void $ forkIO $ do+ ids <- map msId <$> getCurrentSummaries+ unless (null ids) $ do+ let batchReq = newBatchModifyMessagesRequest+ { ids = Just ids+ , removeLabelIds = Just ["UNREAD"]+ }+ result <- try $ runResourceT $ send env (newGmailUsersMessagesBatchModify batchReq)+ case (result :: Either SomeException ()) of+ Right () -> do+ gmailLog DEBUG "Marked all messages as read"+ delayedRefresh+ Left err -> gmailLog ERROR $ printf "Failed to mark all as read: %s" (show err)+ menuitemChildAppend root markAllReadItem+ openInboxItem <- makeMenuItemWithLabel "Open Gmail" onMenuitemItemActivated openInboxItem $ const $ void $ openURL "https://mail.google.com"@@ -414,13 +467,15 @@ (s:_) -> sendNotification s [] -> return () - sendNotification summary =- void $ runCommandFromPath- [ "notify-send"- , "--icon=mail-unread"- , T.unpack $ shortenSender $ msSender summary- , T.unpack $ msSubject summary- ]+ sendNotification summary = do+ result <- sendDesktopNotification notificationClient+ "Gmail"+ "mail-unread"+ (shortenSender $ msSender summary)+ (msSubject summary)+ either (gmailLog WARNING . printf "Failed to send notification: %s")+ (const $ return ())+ result -- Initial fetch and menu build void updateVariables@@ -428,12 +483,16 @@ -- 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+ result <- try $ 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+ case (result :: Either SomeException ()) of+ Right () -> return ()+ Left err -> gmailLog ERROR $ printf "Exception in polling loop: %s" (show err)
src/StatusNotifier/Item/Notifications/Util.hs view
@@ -3,9 +3,14 @@ import Control.Arrow import Control.Monad.Fail import Control.Monad.IO.Class+import DBus+import DBus.Client (Client, call)+import Data.Int (Int32)+import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T-import GI.Dbusmenu+import Data.Word (Word32)+import GI.Dbusmenu hiding (Client) import System.Exit (ExitCode (..)) import System.Log.Logger import qualified System.Process as P@@ -46,8 +51,36 @@ Right (value, _) <- passGet name return value +runDetached :: [String] -> IO (Either String String)+runDetached args = do+ logM "System.Taffybar.Util" INFO $+ printf "Starting detached command with args %s" (show args)+ (_, _, _, _) <-+ P.createProcess+ (P.proc "/usr/bin/env" args)+ { P.std_in = P.NoStream+ , P.std_out = P.NoStream+ , P.std_err = P.NoStream+ , P.close_fds = True+ }+ return $ Right ""+ xdgOpen :: MonadIO m => [String] -> m (Either String String)-xdgOpen args = runCommandFromPath ("xdg-open":args)+xdgOpen args = liftIO $ do+ -- Route URL handlers through systemd so browsers are not parented to the+ -- long-running tray icon service. Otherwise xdg-open can pull Chrome/Electron+ -- into this service's cgroup and make restarts kill unrelated GUI apps.+ result <- runCommandFromPath+ ( [ "systemd-run"+ , "--user"+ , "--collect"+ , "--quiet"+ , "/usr/bin/env"+ , "xdg-open"+ ]+ ++ args+ )+ either (const $ runDetached ("xdg-open":args)) (const $ return result) result openURL :: MonadIO m => String -> m (Either String String) openURL = xdgOpen . return@@ -61,3 +94,33 @@ makeSeparatorMenuItem :: IO Menuitem makeSeparatorMenuItem = undefined++-- | Send a notification through org.freedesktop.Notifications.+sendDesktopNotification+ :: Client+ -> T.Text -- ^ Application name+ -> T.Text -- ^ Icon name+ -> T.Text -- ^ Summary+ -> T.Text -- ^ Body+ -> IO (Either String Word32)+sendDesktopNotification client appName icon summary body = do+ result <- call client+ (methodCall "/org/freedesktop/Notifications"+ "org.freedesktop.Notifications" "Notify")+ { methodCallDestination = Just "org.freedesktop.Notifications"+ , methodCallBody =+ [ toVariant appName+ , toVariant (0 :: Word32)+ , toVariant icon+ , toVariant summary+ , toVariant body+ , toVariant ([] :: [T.Text])+ , toVariant (M.empty :: M.Map T.Text Variant)+ , toVariant (-1 :: Int32)+ ]+ }+ return $ case result of+ Left err -> Left $ methodErrorMessage err+ Right reply -> case methodReturnBody reply of+ [v] | Just notificationId <- fromVariant v -> Right notificationId+ other -> Left $ printf "Unexpected Notify reply: %s" (show other)