ENH use rio for vpn

lib/Xmobar/Plugins/Bluetooth.hs

@@ -162,6 +162,9 @@ modifyState f = do
   m <- asks btState
   modifyMVar m f
 
+beforeDisplay :: BTIO () -> BTIO ()
+beforeDisplay f = f >> join (asks btDisplay)
+
 --------------------------------------------------------------------------------
 -- Object manager
 
@@ -211,8 +214,7 @@ addDeviceRemovedListener adapter sys =
 
 pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
 pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
-  dpy <- asks btDisplay
+  when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
-  when (adaptorHasDevice adapter d) $ f d >> dpy
 pathCallback _ _ _ = return ()
 
 --------------------------------------------------------------------------------
@@ -261,10 +263,10 @@ withBTPropertyRule cl path update iface prop = do
     matchConnected = matchPropertyChanged iface prop
 
 addAdaptorListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
-addAdaptorListener adaptor sys = do
+addAdaptorListener adaptor sys =
-  dpy <- asks btDisplay
-  let procMatch b = putPowered b >> dpy
   withBTPropertyRule sys adaptor procMatch adapterInterface adaptorPowered
+  where
+    procMatch = beforeDisplay . putPowered
 
 callGetPowered
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
@@ -313,10 +315,10 @@ initDevice sh device sys = do
         }
 
 addDeviceListener :: ObjectPath -> SysClient -> BTIO (Maybe SignalHandler)
-addDeviceListener device sys = do
+addDeviceListener device sys =
-  dpy <- asks btDisplay
-  let procMatch c = updateDevice device c >> dpy
   withBTPropertyRule sys device procMatch devInterface devConnected
+  where
+    procMatch = beforeDisplay . void . updateDevice device
 
 callGetConnected
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)

lib/Xmobar/Plugins/VPN.hs

@@ -33,10 +33,10 @@ instance Exec VPN where
   start (VPN (text, colors)) cb =
     withDBusClientConnection cb "VPN" $ \c -> do
       state <- initState c
-      let dpy = displayMaybe cb iconFormatter . Just =<< readState state
+      let dpy = displayMaybe cb iconFormatter . Just =<< readState
-      let signalCallback' f = f state dpy
+      mapRIO (VEnv state dpy) $ do
-      vpnAddedListener (signalCallback' addedCallback) c
+        vpnAddedListener addedCallback c
-      vpnRemovedListener (signalCallback' removedCallback) c
+        vpnRemovedListener removedCallback c
         dpy
     where
       iconFormatter b = return $ colorText colors b text
@@ -48,6 +48,17 @@ instance Exec VPN where
 -- this will be a null or singleton set, but this setup could handle the edge
 -- case of multiple VPNs being active at once without puking.
 
+data VEnv = VEnv
+  { vState :: !MutableVPNState
+  , vDisplay :: !(VIO ())
+  , vEnv :: !SimpleApp
+  }
+
+instance HasLogFunc VEnv where
+  logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
+
+type VIO = RIO VEnv
+
 type VPNState = S.Set ObjectPath
 
 type MutableVPNState = MVar VPNState
@@ -60,16 +71,16 @@ initState client = do
   ot <- getVPNObjectTree client
   newMVar $ findTunnels ot
 
-readState :: MonadUnliftIO m => MutableVPNState -> m Bool
+readState :: VIO Bool
-readState = fmap (not . null) . readMVar
+readState = fmap (not . null) . readMVar =<< asks vState
 
-updateState
+updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
-  :: MonadUnliftIO m
+updateState f op = do
-  => (ObjectPath -> VPNState -> VPNState)
+  s <- asks vState
-  -> MutableVPNState
+  modifyMVar_ s $ return . f op
-  -> ObjectPath
+
-  -> m ()
+beforeDisplay :: VIO () -> VIO ()
-updateState f state op = modifyMVar_ state $ return . f op
+beforeDisplay f = f >> join (asks vDisplay)
 
 --------------------------------------------------------------------------------
 -- Tunnel Device Detection
@@ -97,32 +108,33 @@ vpnRemovedListener
   -> m ()
 vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
 
-addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
+addedCallback :: SignalCallback VIO
-addedCallback state dpy [device, added] = update >> dpy
+addedCallback [device, added] =
+  beforeDisplay $
+    updateDevice S.insert device $
+      M.keys $
+        fromMaybe M.empty added'
   where
     added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
-    is = M.keys $ fromMaybe M.empty added'
+addedCallback _ = return ()
-    update = updateDevice S.insert state device is
-addedCallback _ _ _ = return ()
 
-removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
+removedCallback :: SignalCallback VIO
-removedCallback state dpy [device, interfaces] = update >> dpy
+removedCallback [device, interfaces] =
-  where
+  beforeDisplay $
-    is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
+    updateDevice S.delete device $
-    update = updateDevice S.delete state device is
+      fromMaybe [] $
-removedCallback _ _ _ = return ()
+        fromVariant interfaces
+removedCallback _ = return ()
 
 updateDevice
-  :: MonadUnliftIO m
+  :: (ObjectPath -> VPNState -> VPNState)
-  => (ObjectPath -> VPNState -> VPNState)
-  -> MutableVPNState
   -> Variant
   -> [T.Text]
-  -> m ()
+  -> VIO ()
-updateDevice f state device interfaces =
+updateDevice f device interfaces =
   when (vpnDeviceTun `elem` interfaces) $
     forM_ d $
-      updateState f state
+      updateState f
   where
     d = fromVariant device :: Maybe ObjectPath