diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 44550ba..8b07bb9 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -34,7 +34,6 @@ import Xmobar.Plugins.ClevoKeyboard import Xmobar.Plugins.Common import Xmobar.Plugins.IntelBacklight import Xmobar.Plugins.Screensaver -import Xmobar.Plugins.VPN main :: IO () main = parse >>= xio @@ -236,7 +235,7 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree fmap (Msg LevelError) <$> hasBattery getVPN :: Maybe SysClient -> BarFeature -getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ vpnDep) +getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep) where root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl diff --git a/lib/Xmobar/Plugins/ActiveConnection.hs b/lib/Xmobar/Plugins/ActiveConnection.hs index 7eced94..61c0c10 100644 --- a/lib/Xmobar/Plugins/ActiveConnection.hs +++ b/lib/Xmobar/Plugins/ActiveConnection.hs @@ -33,50 +33,63 @@ newtype ActiveConnection = ActiveConnection (NE.NonEmpty T.Text, T.Text, Colors) deriving (Read, Show) +connAlias :: NE.NonEmpty T.Text -> T.Text +connAlias = T.intercalate "_" . NE.toList + +instance Exec ActiveConnection where + alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes + start (ActiveConnection (contypes, text, colors)) cb = + withDBusClientConnection cb (Just "ethernet.log") $ \c -> do + let dpy = displayMaybe cb formatter . Just =<< readState + i <- withDIO c $ initialState contypes + s <- newMVar i + let mapEnv c' = mapRIO (PluginEnv c' s dpy) + mapEnv c $ addListener mapEnv >> dpy + where + formatter names = return $ case names of + [] -> colorText colors False text + xs -> T.unwords [colorText colors True text, T.intercalate "|" xs] + addListener mapEnv = do + res <- matchSignalFull nmBus Nothing (Just nmActiveInterface) (Just stateChanged) + case res of + Nothing -> logError "could not start listener" + Just rule -> + void $ + addMatchCallbackSignal rule $ \sig -> + withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' -> + mapEnv c' $ + testActiveType contypes sig + +nmBus :: BusName +nmBus = "org.freedesktop.NetworkManager" + nmPath :: ObjectPath -nmPath = objectPath_ "/org/freedesktop/NetworkManager" +nmPath = "/org/freedesktop/NetworkManager" nmInterface :: InterfaceName -nmInterface = interfaceName_ "org.freedesktop.NetworkManager" +nmInterface = "org.freedesktop.NetworkManager" + +nmObjectTreePath :: ObjectPath +nmObjectTreePath = "/org/freedesktop" nmActiveInterface :: InterfaceName -nmActiveInterface = - interfaceName_ "org.freedesktop.NetworkManager.Connection.Active" +nmActiveInterface = "org.freedesktop.NetworkManager.Connection.Active" stateChanged :: MemberName stateChanged = "StateChanged" -getByIP :: MemberName -getByIP = memberName_ "GetDeviceByIpIface" - +-- semi-random method to test to ensure that NetworkManager is up and on DBus devDep :: DBusDependency_ SysClient devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $ - Method_ getByIP + Method_ "GetDeviceByIpIface" --- -- TODO not DRY, make a NM specific section somewhere for this call -ethBus :: BusName -ethBus = busName_ "org.freedesktop.NetworkManager" - -data EthEnv c = EthEnv - { ethClient :: !c - , ethState :: !(MVar EthState) - , ethDisplay :: !(EthIO ()) - , ethEnv :: !SimpleApp - } - -instance HasLogFunc (EthEnv c) where - logFuncL = lens ethEnv (\x y -> x {ethEnv = y}) . logFuncL - -instance HasClient EthEnv where - clientL = lens ethClient (\x y -> x {ethClient = y}) - -type EthIO = RIO (EthEnv SysClient) +type EthIO = PluginIO EthState SysClient type EthState = M.Map ObjectPath T.Text getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant] -getConnectionProp prop path = callPropertyGet ethBus path nmActiveInterface prop +getConnectionProp prop path = callPropertyGet nmBus path nmActiveInterface prop getConnectionId :: ObjectPath -> EthIO (Maybe T.Text) getConnectionId = fmap fromSingletonVariant . getConnectionProp "Id" @@ -87,25 +100,26 @@ getConnectionType = fmap fromSingletonVariant . getConnectionProp "Type" updateConnected :: NE.NonEmpty T.Text -> ObjectPath -> EthIO () updateConnected contypes path = do typeRes <- getConnectionType path - case typeRes of - Nothing -> logError "could not get type" - Just contype -> do + logMaybe "type" getId typeRes + where + path' = displayBytesUtf8 $ T.encodeUtf8 $ T.pack $ formatObjectPath path + logMaybe what = maybe (logError ("could not get " <> what <> " for " <> path')) + getId contype = do when (contype `elem` contypes) $ do idRes <- getConnectionId path - case idRes of - Nothing -> logError "could not get ID" - Just i -> do - s <- asks ethState - modifyMVar_ s $ return . M.insert path i + logMaybe "ID" insertId idRes + insertId i = do + s <- asks plugState + modifyMVar_ s $ return . M.insert path i updateDisconnected :: ObjectPath -> EthIO () updateDisconnected path = do - s <- asks ethState + s <- asks plugState modifyMVar_ s $ return . M.delete path testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO () testActiveType contypes sig = do - dpy <- asks ethDisplay + dpy <- asks plugDisplay case signalBody sig of [state, _] -> case fromVariant state of Just (2 :: Word32) -> updateConnected contypes path >> dpy @@ -125,7 +139,7 @@ initialState => NE.NonEmpty T.Text -> m EthState initialState contypes = - M.mapMaybe go <$> callGetManagedObjects ethBus "/org/freedesktop" + M.mapMaybe go <$> callGetManagedObjects nmBus nmObjectTreePath where go = getId <=< M.lookup nmActiveInterface getId m = @@ -135,31 +149,4 @@ initialState contypes = =<< M.lookup "Type" m readState :: EthIO [T.Text] -readState = M.elems <$> (readMVar =<< asks ethState) - -connAlias :: NE.NonEmpty T.Text -> T.Text -connAlias = T.intercalate "_" . NE.toList - -instance Exec ActiveConnection where - alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes - start (ActiveConnection (contypes, text, colors)) cb = - withDBusClientConnection cb (Just "ethernet.log") $ \c -> do - let dpy = displayMaybe cb formatter . Just =<< readState - i <- withDIO c $ initialState contypes - s <- newMVar i - let mapEnv c' = mapRIO (EthEnv c' s dpy) - mapEnv c $ addListener mapEnv >> dpy - where - formatter names = return $ case names of - [] -> colorText colors False text - xs -> T.unwords [T.intercalate "|" xs, colorText colors True text] - addListener mapEnv = do - res <- matchSignalFull ethBus Nothing (Just nmActiveInterface) (Just stateChanged) - case res of - Nothing -> logError "could not start listener" - Just rule -> - void $ - addMatchCallbackSignal rule $ \sig -> - withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' -> - mapEnv c' $ - testActiveType contypes sig +readState = M.elems <$> (readMVar =<< asks plugState) diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index ff21f21..d6c69f8 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -10,6 +10,8 @@ module Xmobar.Plugins.Common , displayMaybe , displayMaybe' , xmobarFGColor + , PluginEnv (..) + , PluginIO ) where @@ -21,6 +23,21 @@ import RIO import qualified RIO.Text as T import XMonad.Hooks.DynamicLog (xmobarColor) +data PluginEnv s c = PluginEnv + { plugClient :: !c + , plugState :: !(MVar s) + , plugDisplay :: !(PluginIO s c ()) + , plugEnv :: !SimpleApp + } + +type PluginIO s c = RIO (PluginEnv s c) + +instance HasClient (PluginEnv s) where + clientL = lens plugClient (\x y -> x {plugClient = y}) + +instance HasLogFunc (PluginEnv s c) where + logFuncL = lens plugEnv (\x y -> x {plugEnv = y}) . logFuncL + -- use string here since all the callbacks in xmobar use strings :( type Callback = String -> IO ()