diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,15 @@ -# Unreleased +# 7.2.6 + +## Features + +* Add NVIDIA GPU temperature information and a configurable polling widget + backed by `nvidia-smi`. + +## Fixes + +* Require `status-notifier-item >= 0.3.2.16` and `gtk-sni-tray >= 0.2.1.4`, + which collapse duplicate Ayatana tray items even when an application uses a + freshly generated item identity for every instance. # 7.2.5 diff --git a/src/System/Taffybar/Information/AnthropicUsage.hs b/src/System/Taffybar/Information/AnthropicUsage.hs --- a/src/System/Taffybar/Information/AnthropicUsage.hs +++ b/src/System/Taffybar/Information/AnthropicUsage.hs @@ -27,7 +27,7 @@ import Control.Concurrent.MVar import Control.Concurrent.STM (atomically, orElse) import Control.Concurrent.STM.TChan -import Control.Exception (SomeException, try) +import Control.Exception (SomeException, evaluate, try) import Control.Monad (forever, void) import Control.Monad.IO.Class (liftIO) import Data.Aeson @@ -37,6 +37,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (sortOn) import qualified Data.List as List +import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Set as Set import qualified Data.Text as T @@ -46,6 +47,7 @@ import System.Directory ( doesDirectoryExist, doesFileExist, + getFileSize, getHomeDirectory, getModificationTime, listDirectory, @@ -109,7 +111,12 @@ anthropicUsageExtraUsageDisabledReason :: Maybe T.Text, anthropicUsageOrganizationName :: Maybe T.Text, anthropicUsageFiveHourWindow :: AnthropicUsageWindow, - anthropicUsageWeeklyWindow :: AnthropicUsageWindow + anthropicUsageWeeklyWindow :: AnthropicUsageWindow, + -- | Weekly limit scoped to a single model (currently \"Fable\"), reported + -- separately by the OAuth usage endpoint. 'Nothing' when the plan has no + -- such per-model weekly bucket. The window's name carries the model's + -- display name so the label reads e.g. @Fable 22%@. + anthropicUsageScopedWeeklyWindow :: Maybe AnthropicUsageWindow } deriving (Eq, Show) @@ -207,9 +214,42 @@ <$> o .:? "utilization" <*> o .:? "resets_at" +-- | A single entry from the OAuth usage endpoint's @limits@ array. Used to +-- surface the per-model @weekly_scoped@ limit (e.g. Fable), which has no +-- dedicated top-level field. +data AnthropicOAuthLimit = AnthropicOAuthLimit + { anthropicOAuthLimitKind :: Maybe T.Text, + anthropicOAuthLimitPercent :: Maybe Double, + anthropicOAuthLimitResetsAt :: Maybe UTCTime, + -- | @scope.model.display_name@, when the limit is scoped to a model. + anthropicOAuthLimitScopeModel :: Maybe T.Text + } + deriving (Eq, Show) + +instance FromJSON AnthropicOAuthLimit where + parseJSON = withObject "AnthropicOAuthLimit" $ \o -> do + scope <- o .:? "scope" + scopeModel <- + maybe + (return Nothing) + ( withObject "Scope" $ \s -> do + model <- s .:? "model" + maybe + (return Nothing) + (withObject "Model" (.:? "display_name")) + model + ) + scope + AnthropicOAuthLimit + <$> o .:? "kind" + <*> o .:? "percent" + <*> o .:? "resets_at" + <*> pure scopeModel + data AnthropicOAuthUsage = AnthropicOAuthUsage { anthropicOAuthFiveHour :: Maybe AnthropicOAuthWindow, - anthropicOAuthSevenDay :: Maybe AnthropicOAuthWindow + anthropicOAuthSevenDay :: Maybe AnthropicOAuthWindow, + anthropicOAuthLimits :: [AnthropicOAuthLimit] } deriving (Eq, Show) @@ -218,6 +258,7 @@ AnthropicOAuthUsage <$> o .:? "five_hour" <*> o .:? "seven_day" + <*> o .:? "limits" .!= [] -- | Persistent state for OAuth endpoint polling, carried across poll -- iterations so we can space out and back off endpoint requests independently @@ -276,6 +317,23 @@ } deriving (Eq, Show) +-- | Cached extraction result for a single transcript file, keyed by the +-- file's modification time and size. Only the extracted usage entries are +-- retained, never file contents, so the cache stays small even though the +-- underlying transcripts can be large. +data TranscriptFileCacheEntry = TranscriptFileCacheEntry + { transcriptCacheModified :: UTCTime, + transcriptCacheSize :: Integer, + transcriptCacheEntries :: [TranscriptUsageEntry] + } + +-- | Per-file cache of transcript extractions, carried across poll iterations +-- so unchanged files are not re-read and re-parsed on every poll. +type TranscriptFileCache = Map.Map FilePath TranscriptFileCacheEntry + +emptyTranscriptFileCache :: TranscriptFileCache +emptyTranscriptFileCache = Map.empty + data TranscriptJSON = TranscriptJSON { transcriptJSONTimestamp :: Maybe UTCTime, transcriptJSONRequestId :: Maybe T.Text, @@ -319,20 +377,23 @@ anthropicUsageEstimatedCostUSD = Nothing } --- | One-shot snapshot with no persistent backoff state. Convenience for --- callers and tests; the poll loop uses 'getAnthropicUsageInfoWith' so backoff --- and last-good caching survive across iterations. +-- | One-shot snapshot with no persistent backoff or transcript cache state. +-- Convenience for callers and tests; the poll loop uses +-- 'getAnthropicUsageInfoWith' so backoff, last-good caching, and the per-file +-- transcript cache survive across iterations. getAnthropicUsageInfo :: AnthropicUsageConfig -> IO AnthropicUsageInfo -getAnthropicUsageInfo config = - newIORef emptyOAuthFetchState >>= getAnthropicUsageInfoWith config +getAnthropicUsageInfo config = do + oauthStateRef <- newIORef emptyOAuthFetchState + transcriptCacheRef <- newIORef emptyTranscriptFileCache + getAnthropicUsageInfoWith config oauthStateRef transcriptCacheRef -getAnthropicUsageInfoWith :: AnthropicUsageConfig -> IORef OAuthFetchState -> IO AnthropicUsageInfo -getAnthropicUsageInfoWith config oauthStateRef = do +getAnthropicUsageInfoWith :: AnthropicUsageConfig -> IORef OAuthFetchState -> IORef TranscriptFileCache -> IO AnthropicUsageInfo +getAnthropicUsageInfoWith config oauthStateRef transcriptCacheRef = do now <- getCurrentTime credentials <- decodeFileIfExists =<< maybe defaultClaudeCredentialsPath return (anthropicUsageCredentialsPath config) metadata <- readAnthropicUsageMetadata config credentials oauthUsage <- fetchAnthropicOAuthUsageWithBackoff config oauthStateRef now (credentials >>= anthropicCredentialsAccessToken) - entries <- readAnthropicTranscriptEntries config now + entries <- readAnthropicTranscriptEntries config transcriptCacheRef now let fiveHourWindow = applyOAuthWindow (oauthUsage >>= anthropicOAuthFiveHour) $ buildActiveBlockWindow @@ -349,6 +410,9 @@ (7 * 24 * 60 * 60) (anthropicUsageWeeklyBudgetTokens config) entries + scopedWeeklyWindow = + buildScopedWeeklyWindow now + <$> (oauthUsage >>= findScopedWeeklyLimit) return $ AnthropicUsageInfo { anthropicUsageGeneratedAt = now, @@ -358,16 +422,19 @@ anthropicUsageExtraUsageDisabledReason = anthropicMetadataExtraUsageDisabledReason metadata, anthropicUsageOrganizationName = anthropicMetadataOrganizationName metadata, anthropicUsageFiveHourWindow = fiveHourWindow, - anthropicUsageWeeklyWindow = weeklyWindow + anthropicUsageWeeklyWindow = weeklyWindow, + anthropicUsageScopedWeeklyWindow = scopedWeeklyWindow } updateAnthropicUsage :: AnthropicUsageConfig -> IO AnthropicUsageSnapshot -updateAnthropicUsage config = - newIORef emptyOAuthFetchState >>= updateAnthropicUsageWith config +updateAnthropicUsage config = do + oauthStateRef <- newIORef emptyOAuthFetchState + transcriptCacheRef <- newIORef emptyTranscriptFileCache + updateAnthropicUsageWith config oauthStateRef transcriptCacheRef -updateAnthropicUsageWith :: AnthropicUsageConfig -> IORef OAuthFetchState -> IO AnthropicUsageSnapshot -updateAnthropicUsageWith config oauthStateRef = do - result <- try $ getAnthropicUsageInfoWith config oauthStateRef +updateAnthropicUsageWith :: AnthropicUsageConfig -> IORef OAuthFetchState -> IORef TranscriptFileCache -> IO AnthropicUsageSnapshot +updateAnthropicUsageWith config oauthStateRef transcriptCacheRef = do + result <- try $ getAnthropicUsageInfoWith config oauthStateRef transcriptCacheRef case result of Right info -> return $ AnthropicUsageAvailable info Left (err :: SomeException) -> do @@ -502,6 +569,38 @@ seconds <- readMaybe (BS8.unpack raw) :: Maybe Integer if seconds >= 0 then Just (fromInteger seconds) else Nothing +-- | The first @weekly_scoped@ limit from the endpoint's @limits@ array, i.e. +-- the per-model weekly bucket (currently Fable). Only limits carrying a model +-- scope are considered, so an unscoped @weekly_scoped@ entry is ignored. +findScopedWeeklyLimit :: AnthropicOAuthUsage -> Maybe AnthropicOAuthLimit +findScopedWeeklyLimit usage = + listToMaybe + [ limit + | limit <- anthropicOAuthLimits usage, + anthropicOAuthLimitKind limit == Just "weekly_scoped", + Just _ <- [anthropicOAuthLimitScopeModel limit] + ] + +-- | Build a display window for a per-model weekly limit. There is no +-- transcript-derived fallback for these, so the window is populated purely +-- from the endpoint: the model display name becomes the window name and the +-- reported percent becomes the utilization. The start is derived by walking +-- back a week from the reset time so menu durations read sensibly. +buildScopedWeeklyWindow :: UTCTime -> AnthropicOAuthLimit -> AnthropicUsageWindow +buildScopedWeeklyWindow now limit = + AnthropicUsageWindow + { anthropicUsageWindowName = fromMaybe "scoped" (anthropicOAuthLimitScopeModel limit), + anthropicUsageWindowStart = + maybe now (addUTCTime (negate weekSeconds)) resetsAt, + anthropicUsageWindowEnd = fromMaybe (addUTCTime weekSeconds now) resetsAt, + anthropicUsageWindowBudgetTokens = Nothing, + anthropicUsageWindowUtilizationPercent = anthropicOAuthLimitPercent limit, + anthropicUsageWindowTotals = mempty + } + where + resetsAt = anthropicOAuthLimitResetsAt limit + weekSeconds = 7 * 24 * 60 * 60 + applyOAuthWindow :: Maybe AnthropicOAuthWindow -> AnthropicUsageWindow -> AnthropicUsageWindow applyOAuthWindow Nothing window = window applyOAuthWindow (Just oauthWindow) window = @@ -537,17 +636,24 @@ home <- getHomeDirectory return $ home ".claude" "projects" -readAnthropicTranscriptEntries :: AnthropicUsageConfig -> UTCTime -> IO [TranscriptUsageEntry] -readAnthropicTranscriptEntries config now = do +readAnthropicTranscriptEntries :: AnthropicUsageConfig -> IORef TranscriptFileCache -> UTCTime -> IO [TranscriptUsageEntry] +readAnthropicTranscriptEntries config transcriptCacheRef now = do projectsPath <- maybe defaultClaudeProjectsPath return (anthropicUsageProjectsPath config) exists <- doesDirectoryExist projectsPath if not exists - then return [] + then do + writeIORef transcriptCacheRef emptyTranscriptFileCache + return [] else do files <- jsonlFilesModifiedSince (addUTCTime (negate $ anthropicUsageFileLookbackSeconds config) now) projectsPath - dedupeTranscriptEntries . concat <$> mapM readTranscriptFile files + cache <- readIORef transcriptCacheRef + cachedFiles <- mapM (readTranscriptFileCached cache) files + -- Rebuilding the map from this poll's scan evicts entries for files + -- that disappeared or aged out of the lookback window. + writeIORef transcriptCacheRef $ Map.fromList cachedFiles + return $ dedupeTranscriptEntries $ concatMap (transcriptCacheEntries . snd) cachedFiles -jsonlFilesModifiedSince :: UTCTime -> FilePath -> IO [FilePath] +jsonlFilesModifiedSince :: UTCTime -> FilePath -> IO [(FilePath, UTCTime)] jsonlFilesModifiedSince cutoff path = do entries <- listDirectory path concat @@ -562,11 +668,49 @@ if isFile && takeExtension child == ".jsonl" then do modified <- getModificationTime child - return [child | modified >= cutoff] + return [(child, modified) | modified >= cutoff] else return [] ) entries +-- | Return the cached extraction for a file when its modification time and +-- size are both unchanged, re-reading and re-parsing it otherwise. Freshly +-- parsed entries are forced before caching so no lingering thunks retain the +-- file's parsed contents. +readTranscriptFileCached :: + TranscriptFileCache -> + (FilePath, UTCTime) -> + IO (FilePath, TranscriptFileCacheEntry) +readTranscriptFileCached cache (path, modified) = do + size <- getFileSize path + case Map.lookup path cache of + Just cached + | transcriptCacheModified cached == modified, + transcriptCacheSize cached == size -> + return (path, cached) + _ -> do + entries <- readTranscriptFile path + mapM_ (evaluate . forceUsageEntry) entries + return (path, TranscriptFileCacheEntry modified size entries) + +-- | Fully evaluate an extracted entry so values held in the cache do not +-- retain thunks referencing the transcript file's parsed JSON. +forceUsageEntry :: TranscriptUsageEntry -> () +forceUsageEntry + ( TranscriptUsageEntry + timestamp + requestId + (AnthropicUsageTotals requests input cacheCreation cacheRead output cost) + ) = + timestamp `seq` + requestId `seq` + requests `seq` + input `seq` + cacheCreation `seq` + cacheRead `seq` + output `seq` + maybe () (`seq` ()) cost + readTranscriptFile :: FilePath -> IO [TranscriptUsageEntry] readTranscriptFile path = do bytes <- LBS.readFile path @@ -707,7 +851,10 @@ -- Persistent OAuth backoff/last-good state, shared by the initial fetch and -- every poll iteration so spacing and backoff survive across wakeups. oauthStateRef <- liftIO $ newIORef emptyOAuthFetchState - initial <- liftIO $ updateAnthropicUsageWith config oauthStateRef + -- Per-file transcript extraction cache, shared across poll iterations so + -- unchanged transcript files are not re-read and re-parsed on every poll. + transcriptCacheRef <- liftIO $ newIORef emptyTranscriptFileCache + initial <- liftIO $ updateAnthropicUsageWith config oauthStateRef transcriptCacheRef var <- liftIO $ newMVar initial wakeupChan <- getWakeupChannelForDelay (anthropicUsagePollInterval config) ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan @@ -718,17 +865,18 @@ atomically $ void (readTChan refreshChan) `orElse` void (readTChan ourWakeupChan) - refreshAnthropicUsageState config oauthStateRef chan var + refreshAnthropicUsageState config oauthStateRef transcriptCacheRef chan var return $ AnthropicUsageChanVar (chan, var, refreshChan) refreshAnthropicUsageState :: AnthropicUsageConfig -> IORef OAuthFetchState -> + IORef TranscriptFileCache -> TChan AnthropicUsageSnapshot -> MVar AnthropicUsageSnapshot -> IO () -refreshAnthropicUsageState config oauthStateRef chan var = do - snapshot <- updateAnthropicUsageWith config oauthStateRef +refreshAnthropicUsageState config oauthStateRef transcriptCacheRef chan var = do + snapshot <- updateAnthropicUsageWith config oauthStateRef transcriptCacheRef void $ swapMVar var snapshot atomically $ writeTChan chan snapshot diff --git a/src/System/Taffybar/Information/Nvidia.hs b/src/System/Taffybar/Information/Nvidia.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Information/Nvidia.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : System.Taffybar.Information.Nvidia +-- Copyright : (c) Ivan Malison +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Ivan Malison +-- Stability : unstable +-- Portability : unportable +-- +-- NVIDIA GPU information obtained from @nvidia-smi@. +module System.Taffybar.Information.Nvidia + ( NvidiaGpuTemperature (..), + parseNvidiaGpuTemperatures, + readNvidiaGpuTemperatures, + readNvidiaGpuTemperaturesWith, + ) +where + +import Control.Exception (IOException, try) +import Data.List (sortOn) +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import System.Exit (ExitCode (ExitSuccess)) +import System.Process (readProcessWithExitCode) +import Text.Read (readMaybe) + +-- | A temperature reported for one NVIDIA GPU. +data NvidiaGpuTemperature = NvidiaGpuTemperature + { nvidiaGpuIndex :: Int, + nvidiaGpuTemperatureCelsius :: Double + } + deriving (Eq, Show) + +-- | Parse @index, temperature.gpu@ rows emitted by @nvidia-smi@. +-- Invalid rows, including unavailable temperature values, are ignored. +parseNvidiaGpuTemperatures :: T.Text -> [NvidiaGpuTemperature] +parseNvidiaGpuTemperatures = + sortOn nvidiaGpuIndex . mapMaybe parseLine . T.lines + where + parseLine line = + case map T.strip $ T.splitOn "," line of + [indexText, temperatureText] -> + NvidiaGpuTemperature + <$> readMaybe (T.unpack indexText) + <*> readMaybe (T.unpack temperatureText) + _ -> Nothing + +-- | Read temperatures using @nvidia-smi@ from @PATH@. +-- Returns an empty list when the command is missing or exits unsuccessfully. +readNvidiaGpuTemperatures :: IO [NvidiaGpuTemperature] +readNvidiaGpuTemperatures = readNvidiaGpuTemperaturesWith "nvidia-smi" + +-- | Read temperatures using the supplied @nvidia-smi@ executable. +readNvidiaGpuTemperaturesWith :: FilePath -> IO [NvidiaGpuTemperature] +readNvidiaGpuTemperaturesWith command = do + result <- + try + ( readProcessWithExitCode + command + [ "--query-gpu=index,temperature.gpu", + "--format=csv,noheader,nounits" + ] + "" + ) :: + IO (Either IOException (ExitCode, String, String)) + pure $ case result of + Right (ExitSuccess, output, _) -> parseNvidiaGpuTemperatures $ T.pack output + _ -> [] diff --git a/src/System/Taffybar/Information/WirePlumber.hs b/src/System/Taffybar/Information/WirePlumber.hs --- a/src/System/Taffybar/Information/WirePlumber.hs +++ b/src/System/Taffybar/Information/WirePlumber.hs @@ -460,6 +460,10 @@ wirePlumberNodeName = nodeName } +-- | Read the "Props" params of a node as key/value pairs. +-- +-- The returned pods are deep copies (see 'spaPodGetPropertyNoFree'), so they +-- stay valid after the params iterators and their pods are garbage collected. readNodeProps :: Node.Node -> IO [(Text, SpaPod.SpaPod)] readNodeProps node = do maybeParams <- PipewireObject.pipewireObjectEnumParamsSync node "Props" Nothing @@ -467,14 +471,26 @@ Nothing -> pure [] Just params -> do pods <- catMaybes <$> iteratorValues @(Maybe SpaPod.SpaPod) params - fmap concat $ - forM pods $ \pod -> do - iterator <- SpaPod.spaPodNewIterator pod - props <- catMaybes <$> iteratorValues @(Maybe SpaPod.SpaPod) iterator - fmap catMaybes $ - forM props $ \propPod -> do - (ok, key, value) <- spaPodGetPropertyNoFree propPod - pure $ if ok then Just (key, value) else Nothing + keyValues <- + fmap concat $ + forM pods $ \pod -> do + iterator <- SpaPod.spaPodNewIterator pod + props <- catMaybes <$> iteratorValues @(Maybe SpaPod.SpaPod) iterator + propKeyValues <- + fmap catMaybes $ + forM props $ \propPod -> do + (ok, key, value) <- spaPodGetPropertyNoFree propPod + pure $ if ok then Just (key, value) else Nothing + -- The property pods yielded by the iterator wrap data owned by + -- the parent pod, so keep the parent (and the iterator, which + -- holds a reference to it) alive until all of them were read. + mapM_ ManagedPtr.touchManagedPtr props + ManagedPtr.touchManagedPtr iterator + ManagedPtr.touchManagedPtr pod + pure propKeyValues + mapM_ ManagedPtr.touchManagedPtr pods + ManagedPtr.touchManagedPtr params + pure keyValues spaPodGetPropertyNoFree :: SpaPod.SpaPod -> IO (Bool, Text, SpaPod.SpaPod) spaPodGetPropertyNoFree pod = @@ -488,7 +504,10 @@ if keyPtrValue == nullPtr then pure "" else T.pack <$> peekCString keyPtrValue - value <- ManagedPtr.wrapBoxed SpaPod.SpaPod valuePtrValue + wrapped <- ManagedPtr.wrapBoxed SpaPod.SpaPod valuePtrValue + -- wp_spa_pod_get_property returns a wrap pod whose data borrows from + -- the property pod, so deep copy it before it can outlive its parent. + value <- SpaPod.spaPodCopy wrapped pure (result /= 0, key, value) metadataFindNoFree :: Metadata.Metadata -> Word32 -> Text -> IO (Maybe (Text, Text)) @@ -509,12 +528,16 @@ pure $ Just (value, type_) podArrayChildNumber :: SpaPod.SpaPod -> IO (Maybe Double) -podArrayChildNumber pod = - do - isArray <- SpaPod.spaPodIsArray pod +podArrayChildNumber pod = do + isArray <- SpaPod.spaPodIsArray pod + result <- if isArray then SpaPod.spaPodGetArrayChild pod >>= podNumber else podNumber pod + -- wp_spa_pod_get_array_child returns a wrap pod whose data borrows from + -- the array pod, so keep the array pod alive while the child is read. + ManagedPtr.touchManagedPtr pod + pure result podNumber :: SpaPod.SpaPod -> IO (Maybe Double) podNumber pod = do diff --git a/src/System/Taffybar/Widget/AnthropicUsage.hs b/src/System/Taffybar/Widget/AnthropicUsage.hs --- a/src/System/Taffybar/Widget/AnthropicUsage.hs +++ b/src/System/Taffybar/Widget/AnthropicUsage.hs @@ -72,6 +72,9 @@ data AnthropicUsageWindowSelector = AnthropicUsageFiveHourWindow | AnthropicUsageWeeklyWindow + | -- | Per-model weekly limit (currently Fable). Absent for plans without one, + -- in which case the label renders empty. + AnthropicUsageScopedWeeklyWindow deriving (Eq, Show) data AnthropicUsageStackConfig = AnthropicUsageStackConfig @@ -185,10 +188,22 @@ label <- Gtk.labelNew (Just (anthropicUsageLabelFallbackText config)) snapshotVar <- newMVar initialSnapshot let refreshNow = runReaderT (forceAnthropicUsageRefresh infoConfig) ctx + -- Visibility is driven by 'updateLabelFromState': a formatter returning + -- empty text (e.g. the scoped per-model window when the plan has none) + -- hides the label entirely instead of leaving an empty row, and + -- no-show-all keeps ancestor 'widgetShowAll' calls from re-showing it. + Gtk.widgetSetNoShowAll label True _ <- widgetSetClassGI label (anthropicUsageLabelClass config) updateLabelFromState config label displayState initialSnapshot void $ Gtk.onWidgetRealize label $ do + -- The usage listener only runs while the label is realized (e.g. the + -- visible page of a GtkStack), so broadcasts that arrived while the + -- widget was hidden were missed. Re-sync from the shared state before + -- listening so the label does not show a stale snapshot. + currentSnapshot <- runReaderT (getAnthropicUsageState infoConfig) ctx + void $ swapMVar snapshotVar currentSnapshot + updateLabelFromState config label displayState currentSnapshot usageThread <- forkUsageListener config label displayState snapshotVar usageChan modeThread <- forkDisplayModeListener config label displayState snapshotVar void $ Gtk.onWidgetUnrealize label $ do @@ -280,6 +295,7 @@ postGUIASync $ do Gtk.labelSetText label labelText Gtk.widgetSetTooltipText label tooltipText + Gtk.widgetSetVisible label (not (T.null labelText)) formatSnapshotLabel :: AnthropicUsageLabelConfig -> AnthropicUsageDisplayMode -> AnthropicUsageSnapshot -> T.Text formatSnapshotLabel config mode snapshot = @@ -305,15 +321,32 @@ T.intercalate " " [ formatWindowLabel displayMode (anthropicUsageFiveHourWindow info), - formatWindowLabel displayMode (anthropicUsageWeeklyWindow info) + formatWeeklyWithScopedLabel displayMode info ] unavailable = anthropicUsageHasAvailableSubscription info == Just False in (if unavailable then "Claude ! " else "Claude ") <> windows formatAnthropicUsageWindowLabel :: AnthropicUsageWindowSelector -> AnthropicUsageDisplayMode -> AnthropicUsageInfo -> T.Text +formatAnthropicUsageWindowLabel AnthropicUsageWeeklyWindow displayMode info = + formatWeeklyWithScopedLabel displayMode info formatAnthropicUsageWindowLabel selector displayMode info = - formatWindowLabel displayMode (selectedWindow selector info) + maybe "" (formatWindowLabel displayMode) (selectedWindow selector info) +-- | The weekly label with the per-model weekly limit folded in when present, +-- e.g. @7d 65%·F45%r@, so the scoped window does not need its own row. +formatWeeklyWithScopedLabel :: AnthropicUsageDisplayMode -> AnthropicUsageInfo -> T.Text +formatWeeklyWithScopedLabel displayMode info = + let weekly = anthropicUsageWeeklyWindow info + scopedPart window = + "·" + <> T.toUpper (T.take 1 (anthropicUsageWindowName window)) + <> formatWindowValue displayMode window + in anthropicUsageWindowName weekly + <> " " + <> formatWindowValue displayMode weekly + <> maybe "" scopedPart (anthropicUsageScopedWeeklyWindow info) + <> displayModeIndicator displayMode + formatAnthropicUsageTooltip :: AnthropicUsageDisplayMode -> AnthropicUsageSnapshot -> Maybe T.Text formatAnthropicUsageTooltip displayMode snapshot = Just $ @@ -328,6 +361,12 @@ Just $ "Display: " <> displayModeText displayMode, Just $ "5h: " <> formatWindow displayMode (anthropicUsageGeneratedAt info) (anthropicUsageFiveHourWindow info), Just $ "7d: " <> formatWindow displayMode (anthropicUsageGeneratedAt info) (anthropicUsageWeeklyWindow info), + ( \window -> + anthropicUsageWindowName window + <> ": " + <> formatWindow displayMode (anthropicUsageGeneratedAt info) window + ) + <$> anthropicUsageScopedWeeklyWindow info, formatSubscriptionStatus info, ("Extra usage disabled: " <>) <$> anthropicUsageExtraUsageDisabledReason info ] @@ -438,6 +477,11 @@ menu "7d Window" (formatWindowMenuLines displayMode (anthropicUsageGeneratedAt info) (anthropicUsageWeeklyWindow info)) + forM_ (anthropicUsageScopedWeeklyWindow info) $ \window -> + appendMenuSection + menu + (anthropicUsageWindowName window <> " Window") + (formatWindowMenuLines displayMode (anthropicUsageGeneratedAt info) window) appendMenuSection menu "Extra Usage" @@ -551,9 +595,10 @@ displayModeIndicator AnthropicUsageDisplayUsed = "u" displayModeIndicator AnthropicUsageDisplayRemaining = "r" -selectedWindow :: AnthropicUsageWindowSelector -> AnthropicUsageInfo -> AnthropicUsageWindow -selectedWindow AnthropicUsageFiveHourWindow = anthropicUsageFiveHourWindow -selectedWindow AnthropicUsageWeeklyWindow = anthropicUsageWeeklyWindow +selectedWindow :: AnthropicUsageWindowSelector -> AnthropicUsageInfo -> Maybe AnthropicUsageWindow +selectedWindow AnthropicUsageFiveHourWindow = Just . anthropicUsageFiveHourWindow +selectedWindow AnthropicUsageWeeklyWindow = Just . anthropicUsageWeeklyWindow +selectedWindow AnthropicUsageScopedWeeklyWindow = anthropicUsageScopedWeeklyWindow formatDuration :: Int -> T.Text formatDuration seconds diff --git a/src/System/Taffybar/Widget/NvidiaTemperature.hs b/src/System/Taffybar/Widget/NvidiaTemperature.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Widget/NvidiaTemperature.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : System.Taffybar.Widget.NvidiaTemperature +-- Copyright : (c) Ivan Malison +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Ivan Malison +-- Stability : unstable +-- Portability : unportable +-- +-- A widget for displaying NVIDIA GPU temperatures from @nvidia-smi@. +module System.Taffybar.Widget.NvidiaTemperature + ( -- * Combined icon+label widget + nvidiaTemperatureNew, + nvidiaTemperatureNewWith, + + -- * Icon-only widget + nvidiaTemperatureIconNew, + nvidiaTemperatureIconNewWith, + + -- * Label-only widget + nvidiaTemperatureLabelNew, + nvidiaTemperatureLabelNewWith, + + -- * Configuration + NvidiaTemperatureConfig (..), + defaultNvidiaTemperatureConfig, + ) +where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Default (Default (..)) +import Data.List (find, intercalate, maximumBy) +import Data.Ord (comparing) +import qualified Data.Text as T +import qualified GI.Gtk as Gtk +import System.Taffybar.Information.Nvidia +import System.Taffybar.Widget.Generic.PollingLabel (pollingLabelNewWithTooltip) +import System.Taffybar.Widget.Util (buildIconLabelBox, widgetSetClassGI) +import qualified Text.StringTemplate as ST + +-- | Configuration for the NVIDIA temperature widget. +data NvidiaTemperatureConfig = NvidiaTemperatureConfig + { -- | Path or command name for @nvidia-smi@. + nvidiaTemperatureCommand :: FilePath, + -- | GPU index to display. 'Nothing' displays the hottest available GPU. + nvidiaTemperatureGpuIndex :: Maybe Int, + -- | Label template. Available variables are @gpu@ and @tempC@. + nvidiaTemperatureFormat :: String, + -- | Text displayed when no temperature is available. + nvidiaTemperatureFallback :: T.Text, + -- | Polling period in seconds. + nvidiaTemperaturePollInterval :: Double, + -- | Icon used by the combined icon and label widget. + nvidiaTemperatureIcon :: T.Text + } + +instance Default NvidiaTemperatureConfig where + def = defaultNvidiaTemperatureConfig + +-- | Default to GPU 0, refreshed every ten seconds. +defaultNvidiaTemperatureConfig :: NvidiaTemperatureConfig +defaultNvidiaTemperatureConfig = + NvidiaTemperatureConfig + { nvidiaTemperatureCommand = "nvidia-smi", + nvidiaTemperatureGpuIndex = Just 0, + nvidiaTemperatureFormat = "GPU $tempC$\176C", + nvidiaTemperatureFallback = "GPU N/A", + nvidiaTemperaturePollInterval = 10, + nvidiaTemperatureIcon = "\xF2C9" + } + +-- | Create a combined icon and label widget with the default configuration. +nvidiaTemperatureNew :: (MonadIO m) => m Gtk.Widget +nvidiaTemperatureNew = nvidiaTemperatureNewWith defaultNvidiaTemperatureConfig + +-- | Create a combined icon and label widget. +nvidiaTemperatureNewWith :: (MonadIO m) => NvidiaTemperatureConfig -> m Gtk.Widget +nvidiaTemperatureNewWith config = liftIO $ do + iconWidget <- nvidiaTemperatureIconNewWith config + labelWidget <- nvidiaTemperatureLabelNewWith config + buildIconLabelBox iconWidget labelWidget + >>= (`widgetSetClassGI` "nvidia-temperature") + +-- | Create an icon widget with the default configuration. +nvidiaTemperatureIconNew :: (MonadIO m) => m Gtk.Widget +nvidiaTemperatureIconNew = nvidiaTemperatureIconNewWith defaultNvidiaTemperatureConfig + +-- | Create an icon widget with the provided configuration. +nvidiaTemperatureIconNewWith :: (MonadIO m) => NvidiaTemperatureConfig -> m Gtk.Widget +nvidiaTemperatureIconNewWith config = liftIO $ do + label <- Gtk.labelNew $ Just $ nvidiaTemperatureIcon config + _ <- widgetSetClassGI label "nvidia-temperature-icon" + Gtk.widgetShowAll label + Gtk.toWidget label + +-- | Create a label widget with the default configuration. +nvidiaTemperatureLabelNew :: (MonadIO m) => m Gtk.Widget +nvidiaTemperatureLabelNew = nvidiaTemperatureLabelNewWith defaultNvidiaTemperatureConfig + +-- | Create a label widget that polls @nvidia-smi@. +nvidiaTemperatureLabelNewWith :: (MonadIO m) => NvidiaTemperatureConfig -> m Gtk.Widget +nvidiaTemperatureLabelNewWith config = do + widget <- pollingLabelNewWithTooltip (nvidiaTemperaturePollInterval config) $ do + temperatures <- readNvidiaGpuTemperaturesWith $ nvidiaTemperatureCommand config + pure $ case selectTemperature config temperatures of + Nothing -> (nvidiaTemperatureFallback config, formatTooltip temperatures) + Just temperature -> + (formatLabel config temperature, formatTooltip temperatures) + widgetSetClassGI widget "nvidia-temperature-label" + +selectTemperature :: NvidiaTemperatureConfig -> [NvidiaGpuTemperature] -> Maybe NvidiaGpuTemperature +selectTemperature _ [] = Nothing +selectTemperature config temperatures = + case nvidiaTemperatureGpuIndex config of + Just index -> find ((== index) . nvidiaGpuIndex) temperatures + Nothing -> Just $ maximumBy (comparing nvidiaGpuTemperatureCelsius) temperatures + +formatLabel :: NvidiaTemperatureConfig -> NvidiaGpuTemperature -> T.Text +formatLabel config temperature = + T.pack $ ST.render template + where + template = + ST.setManyAttrib + [ ("gpu", show $ nvidiaGpuIndex temperature), + ("tempC", show (round (nvidiaGpuTemperatureCelsius temperature) :: Int)) + ] + $ ST.newSTMP + $ nvidiaTemperatureFormat config + +formatTooltip :: [NvidiaGpuTemperature] -> Maybe T.Text +formatTooltip [] = Nothing +formatTooltip temperatures = + Just $ T.pack $ intercalate "\n" $ map formatOne temperatures + where + formatOne temperature = + "NVIDIA GPU " + ++ show (nvidiaGpuIndex temperature) + ++ ": " + ++ show (round (nvidiaGpuTemperatureCelsius temperature) :: Int) + ++ "\176C" diff --git a/src/System/Taffybar/Widget/OpenAIUsage.hs b/src/System/Taffybar/Widget/OpenAIUsage.hs --- a/src/System/Taffybar/Widget/OpenAIUsage.hs +++ b/src/System/Taffybar/Widget/OpenAIUsage.hs @@ -25,7 +25,7 @@ import Control.Concurrent (ThreadId, forkIO, killThread) import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) -import Control.Concurrent.STM (atomically, newTVarIO, readTVarIO, writeTVar) +import Control.Concurrent.STM (atomically, newTVarIO, readTVarIO, swapTVar) import Control.Concurrent.STM.TChan (TChan, dupTChan, newBroadcastTChanIO, readTChan, writeTChan) import Control.Monad (forM_, forever, void) import Control.Monad.IO.Class (liftIO) @@ -228,16 +228,21 @@ initialSnapshot menuVar <- newTVarIO menu - let rebuildMenu snapshot = - buildUsageMenu - ebox - config - (openAIUsageLabel parts) - (openAIUsageLabelDisplayState parts) - (openAIUsageLabelSnapshotVar parts) - (openAIUsageLabelRefreshNow parts) - snapshot - >>= atomically . writeTVar menuVar + let rebuildMenu snapshot = do + newMenu <- + buildUsageMenu + ebox + config + (openAIUsageLabel parts) + (openAIUsageLabelDisplayState parts) + (openAIUsageLabelSnapshotVar parts) + (openAIUsageLabelRefreshNow parts) + snapshot + oldMenu <- atomically $ swapTVar menuVar newMenu + -- Attached menus hold a GObject reference, so the replaced menu + -- must be destroyed explicitly or it (and its item tree) leaks on + -- every usage snapshot. + Gtk.widgetDestroy oldMenu void $ Gtk.onWidgetRealize ebox $ do menuThread <- diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: taffybar -version: 7.2.5 +version: 7.2.6 synopsis: A desktop bar similar to xmobar, but with more GUI description: Taffybar is a desktop status bar with GTK widgets for window manager state, system information, tray icons, and custom user modules. @@ -96,7 +96,7 @@ , gi-gtk-hs >= 0.3.17 && < 0.4 , gi-pango >= 1.0 && < 1.1 , gtk-scaling-image >= 0.1.0.1 && < 0.2 - , gtk-sni-tray >= 0.2.1.3 && < 0.3 + , gtk-sni-tray >= 0.2.1.4 && < 0.3 , gtk-strut >= 0.1.4.1 && < 0.2 , haskell-gi-base >= 0.24 && < 0.27 , hslogger >= 1.2 && < 1.4 @@ -112,7 +112,7 @@ , regex-compat >= 0.95 && < 0.96 , safe >= 0.3 && < 1 , split >= 0.1.4.2 && < 0.3 - , status-notifier-item >= 0.3.2.15 && < 0.4 + , status-notifier-item >= 0.3.2.16 && < 0.4 , stm >= 2.5 && < 2.6 , template-haskell >= 2.17 && < 2.24 , text >= 1.2 && < 2.2 @@ -165,6 +165,7 @@ , System.Taffybar.Information.MPRIS2 , System.Taffybar.Information.Memory , System.Taffybar.Information.Network + , System.Taffybar.Information.Nvidia , System.Taffybar.Information.Temperature , System.Taffybar.Information.NetworkManager , System.Taffybar.Information.OpenAIUsage @@ -225,6 +226,7 @@ , System.Taffybar.Widget.MPRIS2 , System.Taffybar.Widget.NetworkGraph , System.Taffybar.Widget.NetworkManager + , System.Taffybar.Widget.NvidiaTemperature , System.Taffybar.Widget.OmniMenu , System.Taffybar.Widget.OpenAIUsage , System.Taffybar.Widget.PowerProfiles @@ -397,6 +399,7 @@ , System.Taffybar.ContextSpec , System.Taffybar.Information.CryptoSpec , System.Taffybar.Information.LayoutSpec + , System.Taffybar.Information.NvidiaSpec , System.Taffybar.Information.Workspaces.EWMHSpec , System.Taffybar.Information.Workspaces.HyprlandSpec , System.Taffybar.Information.X11DesktopInfoSpec diff --git a/test/unit/System/Taffybar/Information/NvidiaSpec.hs b/test/unit/System/Taffybar/Information/NvidiaSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/System/Taffybar/Information/NvidiaSpec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Taffybar.Information.NvidiaSpec (spec) where + +import System.Taffybar.Information.Nvidia +import Test.Hspec + +spec :: Spec +spec = describe "NVIDIA temperature parsing" $ do + it "parses and sorts nvidia-smi temperature rows" $ + parseNvidiaGpuTemperatures "2, 73\n0, 56\n" + `shouldBe` [ NvidiaGpuTemperature 0 56, + NvidiaGpuTemperature 2 73 + ] + + it "ignores malformed and unavailable rows" $ + parseNvidiaGpuTemperatures "0, N/A\nbad row\n1, 64\n" + `shouldBe` [NvidiaGpuTemperature 1 64]