module StatusNotifier.Item.Notifications.GitHub where import Control.Arrow import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.Aeson import Data.Aeson.Types import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import Data.Either import Data.Int import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import qualified Data.Vector as V import GI.Dbusmenu import qualified GitHub.Auth as Auth import GitHub.Data import GitHub.Endpoints.Activity.Notifications import GitHub.Request import Network.HTTP.Simple import Network.HTTP.Types import StatusNotifier.Item.Notifications.Util import System.Log.Logger import Text.Printf githubAuthFromPass passName = do Right (token, _) <- passGet passName return $ Auth.OAuth $ BS.pack token ghLog :: Priority -> String -> IO () ghLog = logM "StatusNotifier.Item.Notifications.GitHub" data GitHubConfig = GitHubConfig { ghAuth :: Auth.Auth , ghRefreshSeconds :: Rational } defaultGitHubConfig :: Auth -> GitHubConfig defaultGitHubConfig auth = GitHubConfig { ghAuth = auth , ghRefreshSeconds = 20 } githubUpdaterNew config@GitHubConfig { ghAuth = auth , ghRefreshSeconds = refreshSeconds } update = do let getNotificationsFromGitHub = executeRequest auth $ getNotificationsR FetchAll logAndShow :: (Show v) => Priority -> String -> v -> IO () logAndShow level message value = ghLog level $ printf message (show value) notificationsVar <- MV.newMVar V.empty errorVar <- MV.newMVar Nothing forceRefreshVar <- MV.newEmptyMVar let forceRefresh = void $ MV.tryPutMVar forceRefreshVar () delayedRefresh = void $ forkIO $ threadDelay 1000000 >> forceRefresh openNotificationsHTML = openURL "https://github.com/notifications" markAllRead = executeRequest auth markAllNotificationsAsReadR getCurrentNotifications = MV.readMVar notificationsVar buildMenu = do notifications <- getCurrentNotifications root <- menuitemNew mapM_ ((>>= menuitemChildAppend root) . makeNotificationItem config) notifications separatorItem <- menuitemNew menuitemPropertySet separatorItem MENUITEM_PROP_TYPE CLIENT_TYPES_SEPARATOR menuitemChildAppend root separatorItem markAllReadItem <- makeMenuItemWithLabel "Mark all as read" onMenuitemItemActivated markAllReadItem $ const $ markAllRead >> delayedRefresh menuitemChildAppend root markAllReadItem viewItem <- makeMenuItemWithLabel "View notifications" onMenuitemItemActivated viewItem $ const $ void openNotificationsHTML menuitemChildAppend root viewItem refreshItem <- makeMenuItemWithLabel "Refresh" onMenuitemItemActivated refreshItem $ const forceRefresh menuitemChildAppend root refreshItem return root updateNotifications newNotifications currentNotifications = let newSortedIds = sort $ map notificationId $ V.toList newNotifications oldSortedIds = sort $ map notificationId $ V.toList currentNotifications in return ( newNotifications , (newSortedIds /= oldSortedIds , newSortedIds \\ oldSortedIds ) ) updateError error = do MV.modifyMVar_ errorVar (const $ return $ Just error) ghLog ERROR $ printf "Error retrieving notifications %s" $ show error return (False, []) updateVariables = getNotificationsFromGitHub >>= either updateError (MV.modifyMVar notificationsVar . updateNotifications) doUpdate = do newRoot <- buildMenu notificationsCount <- V.length <$> getCurrentNotifications update notificationsCount newRoot sendNotifications newIds = do notifications <- getCurrentNotifications let getById id = V.find ((== id) . notificationId) notifications mapM_ (traverse sendNotification . getById) newIds sendNotification notification = runCommandFromPath [ "notify-send" , "--icon=github" , getNotificationSummary notification ] void updateVariables doUpdate void $ forkIO $ forever $ do forced <- isRight <$> race (threadDelay (floor $ refreshSeconds * 1000000)) (takeMVar forceRefreshVar) ghLog DEBUG "Refreshing notifications" (menuNeedsRebuild, newIds) <- updateVariables sendNotifications newIds ghLog DEBUG $ printf "Rebuild needed: %s, force: %s" (show menuNeedsRebuild) (show forced) when (forced || menuNeedsRebuild) doUpdate makeNotificationItem :: GitHubConfig -> Notification -> IO Menuitem makeNotificationItem GitHubConfig { ghAuth = auth } notification@Notification { notificationId = thisNotificationId } = do let notificationText = T.pack $ getNotificationSummary notification openHTML = openNotificationHTML auth notification markAsRead = executeRequest auth $ markNotificationAsReadR thisNotificationId menuItem <- menuitemNewWithId $ fromIntegral $ untagId thisNotificationId textVariant <- liftIO $ toGVariant notificationText menuitemPropertySetVariant menuItem "label" textVariant markAsReadItem <- makeMenuItemWithLabel "Mark as read" onMenuitemItemActivated markAsReadItem $ const $ void markAsRead menuitemChildAppend menuItem markAsReadItem viewItem <- makeMenuItemWithLabel "View on GitHub" onMenuitemItemActivated viewItem $ const openHTML menuitemChildAppend menuItem viewItem return menuItem getNotificationSummary :: Notification -> String getNotificationSummary Notification { notificationRepo = RepoRef { repoRefRepo = repositoryName } , notificationSubject = Subject { subjectTitle = title } } = printf "%s - %s" (untagName repositoryName) title getOAuthHeader :: Auth -> RequestHeaders getOAuthHeader (OAuth token) = [("Authorization", "token " <> token)] getOAuthHeader _ = [] openNotificationHTML :: Auth -> Notification -> IO () openNotificationHTML auth notification = do let myHeaders = getOAuthHeader auth <> [("User-Agent", "TaffyBar-GithubNotifier")] <> [("Accept", "application/json")] request = setRequestHeaders myHeaders $ parseRequest_ $ T.unpack $ getUrl $ subjectURL $ notificationSubject notification response <- httpLBS request ghLog DEBUG $ printf "Got response from subject url: %s" $ show response let maybeUrl = getHTMLURL $ getResponseBody response sequence_ $ openURL . T.unpack <$> maybeUrl getHTMLURL :: LBS.ByteString -> Maybe T.Text getHTMLURL jsonText = decode jsonText >>= parseMaybe (.: "html_url")