wlsunset-sni (empty) → 0.1.0.0
raw patch · 9 files changed
+1011/−0 lines, 9 filesdep +basedep +bytestringdep +dbus
Dependencies added: base, bytestring, dbus, gi-dbusmenu, gi-gio, gi-glib, haskell-gi-base, hslogger, optparse-applicative, process, status-notifier-item, stm, text, transformers, unix, wlsunset-sni
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- README.md +22/−0
- app/Main.hs +81/−0
- src/DBus/Proxy.hs +184/−0
- src/Wlsunset/Menu.hs +144/−0
- src/Wlsunset/Process.hs +204/−0
- src/Wlsunset/SNI.hs +279/−0
- wlsunset-sni.cabal +63/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## 0.1.0.0++- Initial release.
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2026, Ivan A. Malison+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,22 @@+# wlsunset-sni++Standalone StatusNotifierItem (SNI) / AppIndicator tray icon for controlling `wlsunset`.++## Features++- Shows a tray icon whose tooltip reflects `wlsunset` state.+- Left click opens a menu:+ - Start/stop+ - Select mode (auto / forced high / forced low)+ - Set temperature presets / reset++## Usage++```sh+wlsunset-sni --command 'wlsunset -l 38.9 -L -77.0'+```++## Notes++This program exports an `org.kde.StatusNotifierItem` and a `com.canonical.dbusmenu` menu.+
+ app/Main.hs view
@@ -0,0 +1,81 @@+module Main where++import Options.Applicative+import System.Log.Logger (Priority (..))+import Wlsunset.SNI++data Opts = Opts+ { optDBusName :: String+ , optCommand :: String+ , optHighTemp :: Int+ , optLowTemp :: Int+ , optPollInterval :: Int+ , optLogLevel :: Priority+ }++optsParser :: Parser Opts+optsParser =+ Opts+ <$> strOption+ ( long "dbus-name"+ <> short 'b'+ <> metavar "BUS-NAME"+ <> value "org.taffybar.WlsunsetSNI"+ )+ <*> strOption+ ( long "command"+ <> short 'c'+ <> metavar "CMD"+ <> value "wlsunset"+ <> help "Full command used to start wlsunset (shell string)."+ )+ <*> option auto+ ( long "high-temp"+ <> metavar "K"+ <> value 6500+ <> help "High (day) temperature used for display and reset preset."+ )+ <*> option auto+ ( long "low-temp"+ <> metavar "K"+ <> value 4000+ <> help "Low (night) temperature used for display and reset preset."+ )+ <*> option auto+ ( long "poll-interval"+ <> metavar "SECONDS"+ <> value 2+ <> help "Polling interval for wlsunset process status."+ )+ <*> option auto+ ( long "log-level"+ <> metavar "LEVEL"+ <> value WARNING+ <> help "hslogger Priority (DEBUG|INFO|NOTICE|WARNING|ERROR|CRITICAL|ALERT|EMERGENCY)."+ )++main :: IO ()+main = do+ Opts { optDBusName = busName+ , optCommand = cmd+ , optHighTemp = highT+ , optLowTemp = lowT+ , optPollInterval = pollSec+ , optLogLevel = level+ } <- execParser $+ info (helper <*> optsParser)+ ( fullDesc+ <> progDesc "Run a StatusNotifierItem tray icon for controlling wlsunset"+ )++ let cfg =+ defaultConfig+ { configDBusName = busName+ , configWlsunsetCommand = cmd+ , configHighTemp = highT+ , configLowTemp = lowT+ , configPollIntervalSec = pollSec+ , configLogLevel = level+ }++ runWlsunsetSNI cfg
+ src/DBus/Proxy.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Proxy all interfaces exported at one (busName, objectPath) onto another+-- object path, on the same 'DBus.Client.Client' connection.+--+-- This is primarily used to host a DBusMenu (via @gi-dbusmenu@) on a separate+-- bus name, then proxy it onto the SNI item bus name, because the SNI 'Menu'+-- property contains only an object path (no bus name).+module DBus.Proxy+ ( proxyAll,+ )+where++import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, catch)+import Control.Monad (forM_, void, when)+import Control.Monad.Trans.Class (lift)+import Data.Maybe (listToMaybe)+import DBus+import DBus.Client+import qualified DBus.Introspection as I+import System.Log.Logger (Priority (..), logM)++-- | Proxy every interface found by Introspect on (busName, pathToProxy), and+-- export them at registrationPath on this client connection.+proxyAll :: Client -> BusName -> ObjectPath -> ObjectPath -> IO ()+proxyAll client busName pathToProxy registrationPath = do+ -- gi-dbusmenu object registration can race startup; retry for a short time.+ let maxAttempts = 50 :: Int+ delayUs = 100000 -- 100ms+ go n = do+ eObj <- introspectObject client busName pathToProxy+ case eObj of+ Left err+ | n <= 0 ->+ logM "DBus.Proxy" WARNING $ "Proxy setup failed: " <> err+ | otherwise ->+ threadDelay delayUs >> go (n - 1)+ Right obj -> do+ let interfaces = I.objectInterfaces obj+ when (null interfaces) $+ logM "DBus.Proxy" WARNING "No interfaces found when attempting to proxy"+ forM_ interfaces $ \iface ->+ buildAndRegisterInterface client busName pathToProxy registrationPath iface+ go maxAttempts++introspectObject :: Client -> BusName -> ObjectPath -> IO (Either String I.Object)+introspectObject client busName pathToProxy = do+ let callMsg =+ (methodCall+ pathToProxy+ (interfaceName_ "org.freedesktop.DBus.Introspectable")+ (memberName_ "Introspect"))+ { methodCallDestination = Just busName+ }+ reply <- call client callMsg+ pure $ do+ ret <- firstMethodReturn reply+ xmlText <-+ maybeToEither "Introspect returned no body" $+ listToMaybe (methodReturnBody ret) >>= fromVariant+ maybeToEither "Failed to parse introspection XML" $+ I.parseXML "/" xmlText++firstMethodReturn :: Either MethodError MethodReturn -> Either String MethodReturn+firstMethodReturn (Left e) = Left (formatErrorName (methodErrorName e))+firstMethodReturn (Right r) = Right r++maybeToEither :: e -> Maybe a -> Either e a+maybeToEither e = maybe (Left e) Right++buildAndRegisterInterface ::+ Client ->+ BusName ->+ ObjectPath ->+ ObjectPath ->+ I.Interface ->+ IO ()+buildAndRegisterInterface client busName pathToProxy registrationPath iIface = do+ let iface = buildInterface client busName pathToProxy iIface+ export client registrationPath iface+ forwardSignals client busName pathToProxy registrationPath (I.interfaceName iIface)++buildInterface :: Client -> BusName -> ObjectPath -> I.Interface -> Interface+buildInterface client busName pathToProxy I.Interface+ { I.interfaceName = name+ , I.interfaceMethods = methods+ , I.interfaceSignals = signals+ , I.interfaceProperties = properties+ } =+ Interface+ { interfaceName = name+ , interfaceMethods = map (buildMethod client busName pathToProxy name) methods+ , interfaceProperties = map (buildProperty client busName pathToProxy name) properties+ , interfaceSignals = signals+ }++buildMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> I.Method -> Method+buildMethod client busName pathToProxy _ifaceName introspectionMethod =+ Method+ { methodName = I.methodName introspectionMethod+ , inSignature = signature_ inTypes+ , outSignature = signature_ outTypes+ , methodHandler = lift . handler+ }+ where+ args = I.methodArgs introspectionMethod+ inTypes = [I.methodArgType a | a <- args, I.methodArgDirection a == I.In]+ outTypes = [I.methodArgType a | a <- args, I.methodArgDirection a == I.Out]+ handler theMethodCall =+ buildReply+ <$> call+ client+ theMethodCall+ { methodCallPath = pathToProxy+ , methodCallDestination = Just busName+ }++buildReply :: Either MethodError MethodReturn -> Reply+buildReply (Left e) = ReplyError (methodErrorName e) (methodErrorBody e)+buildReply (Right r) = ReplyReturn (methodReturnBody r)++buildProperty :: Client -> BusName -> ObjectPath -> InterfaceName -> I.Property -> Property+buildProperty client busName pathToProxy ifaceName introspectionProperty =+ Property+ { propertyName = memberName_ (I.propertyName introspectionProperty)+ , propertyType = I.propertyType introspectionProperty+ , propertyGetter =+ if I.propertyRead introspectionProperty+ then Just getter+ else Nothing+ , propertySetter =+ if I.propertyWrite introspectionProperty+ then Just setter+ else Nothing+ }+ where+ propName = memberName_ (I.propertyName introspectionProperty)+ baseCall =+ (methodCall pathToProxy ifaceName propName)+ { methodCallDestination = Just busName+ }+ getter =+ either (const $ toVariant ("" :: String)) id <$> getProperty client baseCall+ setter v = void $ setProperty client baseCall v++forwardSignals :: Client -> BusName -> ObjectPath -> ObjectPath -> InterfaceName -> IO ()+forwardSignals client busName pathToProxy registrationPath ifaceName = do+ mOwner <- getNameOwner client busName+ case mOwner of+ Nothing ->+ logM "DBus.Proxy" WARNING $+ "Could not resolve name owner for " <> formatBusName busName+ Just owner -> do+ let forwardSignal sig =+ -- Rewrite the path if the exported proxy lives at a different path.+ emit client $+ if signalPath sig == pathToProxy+ then sig {signalPath = registrationPath}+ else sig+ matchRule =+ matchAny+ { matchPath = Just pathToProxy+ , matchInterface = Just ifaceName+ , matchSender = Just owner+ }+ void $ addMatch client matchRule forwardSignal++getNameOwner :: Client -> BusName -> IO (Maybe BusName)+getNameOwner client name = do+ let callMsg =+ (methodCall dbusPath (interfaceName_ "org.freedesktop.DBus") (memberName_ "GetNameOwner"))+ { methodCallDestination = Just dbusName+ , methodCallBody = [toVariant (formatBusName name)]+ }+ reply <- call client callMsg+ case reply of+ Left _ -> pure Nothing+ Right ret ->+ case listToMaybe (methodReturnBody ret) >>= fromVariant of+ Nothing -> pure Nothing+ Just (ownerStr :: String) ->+ (Just <$> parseBusName ownerStr) `catch` \(_ :: SomeException) -> pure Nothing
+ src/Wlsunset/Menu.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}++module Wlsunset.Menu+ ( MenuActions (..)+ , buildMenu+ )+where++import Control.Concurrent (forkIO)+import Control.Monad (forM_, void)+import Data.Int (Int32)+import Data.Text (Text)+import qualified Data.Text as T+import GI.Dbusmenu+import Wlsunset.Process++-- | Actions invoked by menu items.+data MenuActions = MenuActions+ { onSetMode :: WlsunsetMode -> IO ()+ , onToggle :: IO ()+ , onSetFixedTemp :: Int -> IO ()+ , onResetTemps :: IO ()+ , onQuit :: IO ()+ }++-- | Temperature presets from 2500K to 6500K in 500K increments.+tempPresets :: [Int]+tempPresets = [2500, 3000, 3500, 4000, 4500, 5000, 5500, 6000, 6500]++buildMenu :: WlsunsetConfig -> WlsunsetState -> MenuActions -> IO Menuitem+buildMenu cfg st actions = do+ root <- menuitemNew++ header <- makeLabel (stateLine cfg st)+ setEnabled header False+ void $ menuitemChildAppend root header++ addSeparator root++ -- Mode items (disabled when not running)+ let running = wlsunsetRunning st+ currentMode = wlsunsetMode st+ effectiveHigh = wlsunsetEffectiveHighTemp st+ effectiveLow = wlsunsetEffectiveLowTemp st+ highT = T.pack (show effectiveHigh <> "K")+ lowT = T.pack (show effectiveLow <> "K")+ modes :: [(Text, WlsunsetMode)]+ modes =+ [ ("Automatic", WlsunsetAuto)+ , ("High Temp (" <> highT <> ")", WlsunsetForcedHighTemp)+ , ("Low Temp (" <> lowT <> ")", WlsunsetForcedLowTemp)+ ]++ forM_ modes $ \(labelText, targetMode) -> do+ item <- makeLabel labelText+ setToggleType item "radio"+ setToggleState item (if running && currentMode == targetMode then 1 else 0)+ setEnabled item running+ void $ onMenuitemItemActivated item $ \_ ->+ void $ forkIO $ onSetMode actions targetMode+ void $ menuitemChildAppend root item++ addSeparator root++ -- Temperature presets submenu+ tempParent <- makeLabel "Set Temperature"+ void $ menuitemPropertySet tempParent "children-display" "submenu"++ let isFixedTemp = effectiveLow == effectiveHigh+ forM_ tempPresets $ \temp -> do+ tempItem <- makeLabel (T.pack (show temp <> "K"))+ setToggleType tempItem "radio"+ setToggleState tempItem (if running && isFixedTemp && effectiveLow == temp then 1 else 0)+ setEnabled tempItem running+ void $ onMenuitemItemActivated tempItem $ \_ ->+ void $ forkIO $ onSetFixedTemp actions temp+ void $ menuitemChildAppend tempParent tempItem++ addSeparator tempParent++ let defaultLow = wlsunsetLowTemp cfg+ defaultHigh = wlsunsetHighTemp cfg+ resetLabel =+ T.pack $+ "Reset (" <> show defaultLow <> "K - " <> show defaultHigh <> "K)"+ resetItem <- makeLabel resetLabel+ setEnabled resetItem running+ setToggleType resetItem "radio"+ setToggleState resetItem (if running && effectiveLow == defaultLow && effectiveHigh == defaultHigh then 1 else 0)+ void $ onMenuitemItemActivated resetItem $ \_ ->+ void $ forkIO $ onResetTemps actions+ void $ menuitemChildAppend tempParent resetItem++ void $ menuitemChildAppend root tempParent++ addSeparator root++ toggleItem <- makeLabel (if running then "Stop wlsunset" else "Start wlsunset")+ void $ onMenuitemItemActivated toggleItem $ \_ ->+ void $ forkIO $ onToggle actions+ void $ menuitemChildAppend root toggleItem++ quitItem <- makeLabel "Quit"+ void $ onMenuitemItemActivated quitItem $ \_ ->+ void $ forkIO $ onQuit actions+ void $ menuitemChildAppend root quitItem++ pure root++stateLine :: WlsunsetConfig -> WlsunsetState -> Text+stateLine _cfg st =+ let highT = T.pack (show (wlsunsetEffectiveHighTemp st) <> "K")+ lowT = T.pack (show (wlsunsetEffectiveLowTemp st) <> "K")+ in case (wlsunsetRunning st, wlsunsetMode st) of+ (False, _) -> "wlsunset: stopped"+ (True, WlsunsetAuto) -> "wlsunset: automatic (" <> lowT <> " - " <> highT <> ")"+ (True, WlsunsetForcedHighTemp) -> "wlsunset: high temp (" <> highT <> ")"+ (True, WlsunsetForcedLowTemp) -> "wlsunset: low temp (" <> lowT <> ")"++-- Helpers++makeLabel :: Text -> IO Menuitem+makeLabel text = do+ item <- menuitemNew+ void $ menuitemPropertySet item "label" text+ pure item++addSeparator :: Menuitem -> IO ()+addSeparator parent = do+ sep <- menuitemNew+ void $ menuitemPropertySet sep "type" ("separator" :: Text)+ void $ menuitemChildAppend parent sep++setEnabled :: Menuitem -> Bool -> IO ()+setEnabled item enabled =+ void $ menuitemPropertySetBool item "enabled" enabled++setToggleType :: Menuitem -> Text -> IO ()+setToggleType item toggleType =+ void $ menuitemPropertySet item "toggle-type" toggleType++setToggleState :: Menuitem -> Int32 -> IO ()+setToggleState item toggleState =+ void $ menuitemPropertySetInt item "toggle-state" toggleState
+ src/Wlsunset/Process.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Wlsunset.Process+ ( WlsunsetMode (..)+ , WlsunsetState (..)+ , WlsunsetConfig (..)+ , Wlsunset+ , newWlsunset+ , getWlsunsetState+ , dupWlsunsetChan+ , cycleWlsunsetMode+ , cycleWlsunsetToMode+ , startWlsunset+ , stopWlsunset+ , toggleWlsunset+ , restartWlsunsetWithTemps+ )+where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Exception (SomeException, catch)+import Control.Monad (forever, replicateM_, void, when)+import Data.List (isPrefixOf)+import System.Posix.Signals (sigUSR1, signalProcess)+import System.Posix.Types (CPid (..))+import System.Process (readProcess, spawnCommand)+import Text.Read (readMaybe)++-- | The three operating modes that wlsunset cycles through when it receives+-- SIGUSR1.+data WlsunsetMode+ = WlsunsetAuto+ | WlsunsetForcedHighTemp+ | WlsunsetForcedLowTemp+ deriving (Eq, Show, Ord, Enum, Bounded)++-- | Observable state of the wlsunset process.+data WlsunsetState = WlsunsetState+ { wlsunsetRunning :: Bool+ , wlsunsetMode :: WlsunsetMode+ , wlsunsetEffectiveHighTemp :: Int+ , wlsunsetEffectiveLowTemp :: Int+ }+ deriving (Eq, Show)++-- | Configuration for monitoring and starting wlsunset.+data WlsunsetConfig = WlsunsetConfig+ { wlsunsetCommand :: String+ , wlsunsetHighTemp :: Int+ , wlsunsetLowTemp :: Int+ , wlsunsetPollIntervalSec :: Int+ }+ deriving (Eq, Show)++-- | A running wlsunset monitor.+data Wlsunset = Wlsunset+ { wsCfg :: WlsunsetConfig+ , wsStateVar :: MVar WlsunsetState+ , wsChan :: TChan WlsunsetState+ }++newWlsunset :: WlsunsetConfig -> IO Wlsunset+newWlsunset wsCfg@WlsunsetConfig {..} = do+ let initial =+ WlsunsetState+ { wlsunsetRunning = False+ , wlsunsetMode = WlsunsetAuto+ , wlsunsetEffectiveHighTemp = wlsunsetHighTemp+ , wlsunsetEffectiveLowTemp = wlsunsetLowTemp+ }+ wsStateVar <- newMVar initial+ wsChan <- newBroadcastTChanIO+ let ws = Wlsunset {..}+ void $ forkIO $ forever $ do+ pollWlsunset ws+ threadDelay (wlsunsetPollIntervalSec * 1000000)+ pure ws++getWlsunsetState :: Wlsunset -> IO WlsunsetState+getWlsunsetState = readMVar . wsStateVar++-- | Create a private read-end of the broadcast channel.+dupWlsunsetChan :: Wlsunset -> IO (TChan WlsunsetState)+dupWlsunsetChan = atomically . dupTChan . wsChan++broadcastUpdate :: Wlsunset -> (WlsunsetState -> WlsunsetState) -> IO ()+broadcastUpdate ws f =+ modifyMVar_ (wsStateVar ws) $ \old -> do+ let new = f old+ when (new /= old) $ atomically $ writeTChan (wsChan ws) new+ pure new++-- ---------------------------------------------------------------------------+-- Process helpers+-- ---------------------------------------------------------------------------++pgrepWlsunset :: IO [CPid]+pgrepWlsunset =+ (parsePids <$> readProcess "pgrep" ["-x", "wlsunset"] "")+ `catch` (\(_ :: SomeException) -> pure [])+ where+ parsePids = map (CPid . fromIntegral) . concatMap toList . lines+ toList s = maybe [] pure (readMaybe s :: Maybe Int)++sendUSR1 :: CPid -> IO ()+sendUSR1 = signalProcess sigUSR1++pollWlsunset :: Wlsunset -> IO ()+pollWlsunset ws = do+ pids <- pgrepWlsunset+ let isRunning = not (null pids)+ broadcastUpdate ws $ \old ->+ let wasRunning = wlsunsetRunning old+ newMode+ | not wasRunning && isRunning = WlsunsetAuto+ | not isRunning = WlsunsetAuto+ | otherwise = wlsunsetMode old+ in old {wlsunsetRunning = isRunning, wlsunsetMode = newMode}++-- ---------------------------------------------------------------------------+-- Actions+-- ---------------------------------------------------------------------------++cycleWlsunsetMode :: Wlsunset -> IO ()+cycleWlsunsetMode ws = do+ pids <- pgrepWlsunset+ case pids of+ [] -> pure ()+ _ -> do+ mapM_ sendUSR1 pids+ broadcastUpdate ws $ \old ->+ let newMode = case wlsunsetMode old of+ WlsunsetAuto -> WlsunsetForcedHighTemp+ WlsunsetForcedHighTemp -> WlsunsetForcedLowTemp+ WlsunsetForcedLowTemp -> WlsunsetAuto+ in old {wlsunsetMode = newMode, wlsunsetRunning = True}++cyclesToReach :: WlsunsetMode -> WlsunsetMode -> Int+cyclesToReach from to+ | from == to = 0+ | otherwise = (toOrd to - toOrd from) `mod` 3+ where+ toOrd WlsunsetAuto = 0+ toOrd WlsunsetForcedHighTemp = 1+ toOrd WlsunsetForcedLowTemp = 2++cycleWlsunsetToMode :: Wlsunset -> WlsunsetMode -> IO ()+cycleWlsunsetToMode ws target = do+ st <- getWlsunsetState ws+ replicateM_ (cyclesToReach (wlsunsetMode st) target) (cycleWlsunsetMode ws)++startWlsunset :: Wlsunset -> IO ()+startWlsunset ws = do+ void $ spawnCommand (wlsunsetCommand (wsCfg ws))+ broadcastUpdate ws $ \old -> old {wlsunsetRunning = True, wlsunsetMode = WlsunsetAuto}++stopWlsunset :: Wlsunset -> IO ()+stopWlsunset ws = do+ pids <- pgrepWlsunset+ mapM_ (signalProcess 15) pids+ broadcastUpdate ws $ \old -> old {wlsunsetRunning = False, wlsunsetMode = WlsunsetAuto}++toggleWlsunset :: Wlsunset -> IO ()+toggleWlsunset ws = do+ st <- getWlsunsetState ws+ if wlsunsetRunning st then stopWlsunset ws else startWlsunset ws++restartWlsunsetWithTemps :: Wlsunset -> Int -> Int -> IO ()+restartWlsunsetWithTemps ws lowTemp highTemp = do+ pids <- pgrepWlsunset+ mapM_ (signalProcess 15) pids+ let cmd = buildCommandWithTemps (wlsunsetCommand (wsCfg ws)) lowTemp highTemp+ void $ spawnCommand cmd+ broadcastUpdate ws $ \old ->+ old+ { wlsunsetRunning = True+ , wlsunsetMode = WlsunsetAuto+ , wlsunsetEffectiveHighTemp = highTemp+ , wlsunsetEffectiveLowTemp = lowTemp+ }++-- ---------------------------------------------------------------------------+-- Command building+-- ---------------------------------------------------------------------------++buildCommandWithTemps :: String -> Int -> Int -> String+buildCommandWithTemps baseCmd lowTemp highTemp =+ unwords (stripTempArgs (words baseCmd))+ ++ " -t "+ ++ show lowTemp+ ++ " -T "+ ++ show highTemp++stripTempArgs :: [String] -> [String]+stripTempArgs [] = []+stripTempArgs ("-t" : _ : rest) = stripTempArgs rest+stripTempArgs ("-T" : _ : rest) = stripTempArgs rest+stripTempArgs (x : rest)+ | "-t" `isPrefixOf` x && length x > 2 = stripTempArgs rest+ | "-T" `isPrefixOf` x && length x > 2 = stripTempArgs rest+ | otherwise = x : stripTempArgs rest
+ src/Wlsunset/SNI.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Wlsunset.SNI+ ( Config (..)+ , defaultConfig+ , runWlsunsetSNI+ )+where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM+import Control.Exception (SomeException, catch)+import Control.Monad (forever, void, when)+import Data.Int (Int32)+import Data.String (fromString)+import qualified Data.Text as T+import DBus+import DBus.Client+ ( Client+ , Interface (..)+ , autoMethod+ , connectSession+ , defaultInterface+ , export+ , readOnlyProperty+ , requestName+ )+import DBus.Proxy (proxyAll)+import qualified Data.ByteString as BS+import qualified Data.GI.Base as GI+import Foreign.C.Types (CInt (..))+import Foreign.Ptr (FunPtr, Ptr)+import Foreign.StablePtr+ ( StablePtr+ , castPtrToStablePtr+ , castStablePtrToPtr+ , deRefStablePtr+ , freeStablePtr+ , newStablePtr+ )+import qualified GI.Dbusmenu as Dbusmenu+import qualified GI.GLib as GLib+import qualified GI.Gio as Gio+import qualified GI.Gio.Objects.Cancellable as Gio+import System.Exit (exitSuccess)+import System.IO.Unsafe (unsafePerformIO)+import System.Log.Logger+ ( Priority (..)+ , getRootLogger+ , saveGlobalLogger+ , setLevel+ )++import qualified StatusNotifier.Item.Client as I+import qualified StatusNotifier.Watcher.Client as W++import Wlsunset.Menu+import Wlsunset.Process++-- | Runtime configuration.+data Config = Config+ { configDBusName :: String+ , configWlsunsetCommand :: String+ , configHighTemp :: Int+ , configLowTemp :: Int+ , configPollIntervalSec :: Int+ , configIconAuto :: String+ , configIconHigh :: String+ , configIconLow :: String+ , configIconOff :: String+ , configTitle :: String+ , configLogLevel :: Priority+ }++defaultConfig :: Config+defaultConfig =+ Config+ { configDBusName = "org.taffybar.WlsunsetSNI"+ , configWlsunsetCommand = "wlsunset"+ , configHighTemp = 6500+ , configLowTemp = 4000+ , configPollIntervalSec = 2+ , configIconAuto = "video-display"+ , configIconHigh = "video-display"+ , configIconLow = "weather-clear-night"+ , configIconOff = "process-stop"+ , configTitle = "wlsunset"+ , configLogLevel = WARNING+ }++runWlsunsetSNI :: Config -> IO ()+runWlsunsetSNI cfg@Config {..} = do+ setupLogging configLogLevel++ let busName = configDBusName+ path = "/StatusNotifierItem"+ menuPath = path <> "/Menu"+ menuBusName = busName <> ".Menu"+ iconObjectPath = objectPath_ path++ client <- connectSession++ -- Menu is hosted via gi-dbusmenu on a separate bus name, then proxied onto+ -- the item bus name (see DBus.Proxy).+ menuConnection <- Just <$> Gio.cancellableNew >>= Gio.busGetSync Gio.BusTypeSession+ void $ Gio.busOwnNameOnConnection menuConnection (T.pack menuBusName) [] Nothing Nothing+ menuServer <- Dbusmenu.serverNew (T.pack menuPath)++ -- GLib main loop needed by gi-dbusmenu.+ mainLoop <- GLib.mainLoopNew Nothing False >>= GLib.mainLoopRef+ glibContext <- GLib.mainLoopGetContext mainLoop+ void $ forkIO $ GLib.mainLoopRun mainLoop++ let wsCfg =+ WlsunsetConfig+ { wlsunsetCommand = configWlsunsetCommand+ , wlsunsetHighTemp = configHighTemp+ , wlsunsetLowTemp = configLowTemp+ , wlsunsetPollIntervalSec = configPollIntervalSec+ }+ wlsunset <- newWlsunset wsCfg++ let rebuildMenu :: IO ()+ rebuildMenu = do+ st <- getWlsunsetState wlsunset+ let actions =+ MenuActions+ { onSetMode = \mode -> do+ st0 <- getWlsunsetState wlsunset+ when (not (wlsunsetRunning st0)) (startWlsunset wlsunset)+ cycleWlsunsetToMode wlsunset mode+ , onToggle = toggleWlsunset wlsunset+ , onSetFixedTemp = \t -> restartWlsunsetWithTemps wlsunset t t+ , onResetTemps = restartWlsunsetWithTemps wlsunset configLowTemp configHighTemp+ , onQuit = exitSuccess+ }+ newRoot <- buildMenu wsCfg st actions+ runOnGLibMain glibContext $+ Dbusmenu.serverSetRoot menuServer newRoot++ -- Initial menu+ rebuildMenu++ exportSNI cfg client path menuPath wlsunset+ _ <- requestName client (busName_ busName) []++ -- Proxy the menu from menuBusName onto busName at the same object path, so+ -- hosts can find com.canonical.dbusmenu at busName:/StatusNotifierItem/Menu.+ proxyAll client (busName_ menuBusName) (objectPath_ menuPath) (objectPath_ menuPath)++ -- Register with the watcher (must be done from the same DBus connection that+ -- owns the SNI bus name).+ void $ W.registerStatusNotifierItem client busName++ -- React to state changes.+ chan <- dupWlsunsetChan wlsunset+ void $ forkIO $ forever $ do+ _st <- atomically $ readTChan chan+ rebuildMenu+ emitSafe $ I.emitNewIcon client iconObjectPath+ emitSafe $ I.emitNewToolTip client iconObjectPath++ forever $ threadDelay maxBound++exportSNI :: Config -> Client -> String -> String -> Wlsunset -> IO ()+exportSNI cfg client path menuPath wlsunset = do+ let iface =+ defaultInterface+ { interfaceName = interfaceName_ "org.kde.StatusNotifierItem"+ , interfaceMethods =+ [ autoMethod "SecondaryActivate" (\(_x :: Int32) (_y :: Int32) -> toggleWlsunset wlsunset)+ , autoMethod "Activate" (\(_x :: Int32) (_y :: Int32) -> (return () :: IO ()))+ , autoMethod "ContextMenu" (\(_x :: Int32) (_y :: Int32) -> (return () :: IO ()))+ , autoMethod "Scroll" (\(_delta :: Int32) (_orientation :: String) -> (return () :: IO ()))+ ]+ , interfaceProperties =+ [ readOnlyProperty "Category" (pure ("ApplicationStatus" :: String))+ , readOnlyProperty "Id" (pure ("wlsunset-sni" :: String))+ , readOnlyProperty "Title" (pure (configTitle cfg))+ , readOnlyProperty "Status" (pure ("Active" :: String))+ , readOnlyProperty "WindowId" (pure (0 :: Int32))+ , readOnlyProperty "IconThemePath" (pure ("" :: String))+ , readOnlyProperty "IconName" (stateIconName cfg <$> getWlsunsetState wlsunset)+ , readOnlyProperty "OverlayIconName" (pure ("" :: String))+ , readOnlyProperty "ItemIsMenu" (pure True)+ , readOnlyProperty "Menu" (pure (objectPath_ menuPath))+ , readOnlyProperty "ToolTip" (getWlsunsetState wlsunset >>= tooltip cfg)+ ]+ , interfaceSignals = []+ }+ export client (fromString path) iface++stateIconName :: Config -> WlsunsetState -> String+stateIconName Config {..} st+ | not (wlsunsetRunning st) = configIconOff+ | otherwise =+ case wlsunsetMode st of+ WlsunsetAuto -> configIconAuto+ WlsunsetForcedHighTemp -> configIconHigh+ WlsunsetForcedLowTemp -> configIconLow++-- org.kde.StatusNotifierItem.ToolTip is (s a(iiay) s s)+-- We don't provide pixmaps; most hosts are fine with IconName + text.+tooltip :: Config -> WlsunsetState -> IO (String, [(Int32, Int32, BS.ByteString)], String, String)+tooltip cfg st =+ let title = configTitle cfg+ text = T.unpack (tooltipText st)+ in pure ("", [], title, text)++tooltipText :: WlsunsetState -> T.Text+tooltipText st =+ let highT = T.pack (show (wlsunsetEffectiveHighTemp st) <> "K")+ lowT = T.pack (show (wlsunsetEffectiveLowTemp st) <> "K")+ in case (wlsunsetRunning st, wlsunsetMode st) of+ (False, _) -> "wlsunset: stopped"+ (True, WlsunsetAuto) -> "wlsunset: automatic (" <> lowT <> " - " <> highT <> ")"+ (True, WlsunsetForcedHighTemp) -> "wlsunset: high temp (" <> highT <> ")"+ (True, WlsunsetForcedLowTemp) -> "wlsunset: low temp (" <> lowT <> ")"++setupLogging :: Priority -> IO ()+setupLogging level = do+ logger <- getRootLogger+ saveGlobalLogger (setLevel level logger)++emitSafe :: IO () -> IO ()+emitSafe io = io `catch` (\(_ :: SomeException) -> pure ())++-- Schedule work on the GLib main context.+runOnGLibMain :: GLib.MainContext -> IO () -> IO ()+runOnGLibMain context action = do+ sp <- newStablePtr action+ GI.withManagedPtr context $ \ctxPtr ->+ c_g_main_context_invoke_full+ ctxPtr+ 4+ invokeSourceFunc+ (castStablePtrToPtr sp)+ destroyNotifyFunc++type InvokeSourceFunc = Ptr () -> IO CInt++type DestroyNotify = Ptr () -> IO ()++foreign import ccall unsafe "g_main_context_invoke_full"+ c_g_main_context_invoke_full ::+ Ptr GLib.MainContext ->+ CInt ->+ FunPtr InvokeSourceFunc ->+ Ptr () ->+ FunPtr DestroyNotify ->+ IO ()++foreign import ccall "wrapper"+ mkInvokeSourceFunc :: InvokeSourceFunc -> IO (FunPtr InvokeSourceFunc)++foreign import ccall "wrapper"+ mkDestroyNotify :: DestroyNotify -> IO (FunPtr DestroyNotify)++{-# NOINLINE invokeSourceFunc #-}+invokeSourceFunc :: FunPtr InvokeSourceFunc+invokeSourceFunc =+ unsafePerformIO $+ mkInvokeSourceFunc $ \p -> do+ let sp :: StablePtr (IO ())+ sp = castPtrToStablePtr p+ (deRefStablePtr sp >>= id) `catch` (\(_ :: SomeException) -> pure ())+ pure 0++{-# NOINLINE destroyNotifyFunc #-}+destroyNotifyFunc :: FunPtr DestroyNotify+destroyNotifyFunc =+ unsafePerformIO $+ mkDestroyNotify $ \p -> do+ let sp :: StablePtr (IO ())+ sp = castPtrToStablePtr p+ freeStablePtr sp
+ wlsunset-sni.cabal view
@@ -0,0 +1,63 @@+cabal-version: 2.4+name: wlsunset-sni+version: 0.1.0.0+synopsis: StatusNotifierItem tray icon for controlling wlsunset+category: System+license: BSD-3-Clause+license-file: LICENSE+author: Ivan A. Malison+maintainer: Ivan A. Malison+build-type: Simple+tested-with: GHC ==9.10.3++description:+ Standalone StatusNotifierItem (SNI) / AppIndicator tray icon for controlling+ the wlsunset Wayland day/night gamma adjustor.++extra-source-files:+ README.md++extra-doc-files:+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/taffybar/wlsunset-sni++common common+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ , base >=4.14 && <4.21++library+ import: common+ hs-source-dirs: src+ exposed-modules:+ DBus.Proxy+ Wlsunset.Process+ Wlsunset.Menu+ Wlsunset.SNI+ build-depends:+ , bytestring >=0.12.2.0 && <0.13+ , dbus >=1.4.1 && <1.5+ , gi-dbusmenu >=0.4.14 && <0.5+ , gi-gio >=2.0.38 && <2.1+ , gi-glib >=2.0.30 && <2.1+ , haskell-gi-base >=0.26.9 && <0.27+ , hslogger >=1.3.2.0 && <1.4+ , process >=1.6.26.1 && <1.7+ , stm >=2.5.3.1 && <2.6+ , text >=2.1.3 && <2.2+ , transformers >=0.6.1.1 && <0.7+ , unix >=2.8.7.0 && <2.9+ , status-notifier-item >=0.3.2.7 && <0.4++executable wlsunset-sni+ import: common+ hs-source-dirs: app+ main-is: Main.hs+ build-depends:+ , hslogger >=1.3.2.0 && <1.4+ , optparse-applicative >=0.18.1.0 && <0.19+ , wlsunset-sni