diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/data/icons/hicolor/index.theme b/data/icons/hicolor/index.theme new file mode 100644 --- /dev/null +++ b/data/icons/hicolor/index.theme @@ -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 diff --git a/data/icons/hicolor/scalable/apps/gitea.svg b/data/icons/hicolor/scalable/apps/gitea.svg new file mode 100644 --- /dev/null +++ b/data/icons/hicolor/scalable/apps/gitea.svg @@ -0,0 +1,1 @@ + diff --git a/data/icons/hicolor/scalable/apps/github.svg b/data/icons/hicolor/scalable/apps/github.svg new file mode 100644 --- /dev/null +++ b/data/icons/hicolor/scalable/apps/github.svg @@ -0,0 +1,1 @@ + diff --git a/data/icons/hicolor/scalable/apps/gmail.svg b/data/icons/hicolor/scalable/apps/gmail.svg new file mode 100644 --- /dev/null +++ b/data/icons/hicolor/scalable/apps/gmail.svg @@ -0,0 +1,7 @@ + + + + + + + diff --git a/data/icons/hicolor/scalable/apps/notification-indicator.svg b/data/icons/hicolor/scalable/apps/notification-indicator.svg new file mode 100644 --- /dev/null +++ b/data/icons/hicolor/scalable/apps/notification-indicator.svg @@ -0,0 +1,3 @@ + + + diff --git a/notifications-tray-icon.cabal b/notifications-tray-icon.cabal --- a/notifications-tray-icon.cabal +++ b/notifications-tray-icon.cabal @@ -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 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 diff --git a/src/Gitea/API.hs b/src/Gitea/API.hs new file mode 100644 --- /dev/null +++ b/src/Gitea/API.hs @@ -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 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 @@ -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") diff --git a/src/StatusNotifier/Item/Notifications/Gitea.hs b/src/StatusNotifier/Item/Notifications/Gitea.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Item/Notifications/Gitea.hs @@ -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) diff --git a/src/StatusNotifier/Item/Notifications/Gmail.hs b/src/StatusNotifier/Item/Notifications/Gmail.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Item/Notifications/Gmail.hs @@ -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 " 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 diff --git a/src/StatusNotifier/Item/Notifications/OverlayIcon.hs b/src/StatusNotifier/Item/Notifications/OverlayIcon.hs --- a/src/StatusNotifier/Item/Notifications/OverlayIcon.hs +++ b/src/StatusNotifier/Item/Notifications/OverlayIcon.hs @@ -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 = [] } 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 @@ -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