diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/notifications-tray-icon.cabal b/notifications-tray-icon.cabal --- a/notifications-tray-icon.cabal +++ b/notifications-tray-icon.cabal @@ -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 +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 diff --git a/src/StatusNotifier/Item/Notifications/GitHub.hs b/src/StatusNotifier/Item/Notifications/GitHub.hs --- a/src/StatusNotifier/Item/Notifications/GitHub.hs +++ b/src/StatusNotifier/Item/Notifications/GitHub.hs @@ -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 diff --git a/src/StatusNotifier/Item/Notifications/Gitea.hs b/src/StatusNotifier/Item/Notifications/Gitea.hs --- a/src/StatusNotifier/Item/Notifications/Gitea.hs +++ b/src/StatusNotifier/Item/Notifications/Gitea.hs @@ -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 diff --git a/src/StatusNotifier/Item/Notifications/Gmail.hs b/src/StatusNotifier/Item/Notifications/Gmail.hs --- a/src/StatusNotifier/Item/Notifications/Gmail.hs +++ b/src/StatusNotifier/Item/Notifications/Gmail.hs @@ -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) diff --git a/src/StatusNotifier/Item/Notifications/Util.hs b/src/StatusNotifier/Item/Notifications/Util.hs --- a/src/StatusNotifier/Item/Notifications/Util.hs +++ b/src/StatusNotifier/Item/Notifications/Util.hs @@ -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)