REF merge plugin environ

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
 

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 =
+nmActiveInterface = "org.freedesktop.NetworkManager.Connection.Active"
-  interfaceName_ "org.freedesktop.NetworkManager.Connection.Active"
 
 stateChanged :: MemberName
 stateChanged = "StateChanged"
 
-getByIP :: MemberName
+-- semi-random method to test to ensure that NetworkManager is up and on DBus
-getByIP = memberName_ "GetDeviceByIpIface"
-
 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
+type EthIO = PluginIO EthState SysClient
-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 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
+  logMaybe "type" getId typeRes
-    Nothing -> logError "could not get type"
+  where
-    Just contype -> do
+    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
+        logMaybe "ID" insertId idRes
-          Nothing -> logError "could not get ID"
+    insertId i = do
-          Just i -> do
+      s <- asks plugState
-            s <- asks ethState
+      modifyMVar_ s $ return . M.insert path i
-            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)
+readState = M.elems <$> (readMVar =<< asks plugState)
-
-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

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 ()