ENH use firefox

bin/vbox-start.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 -- | Start a VirtualBox instance with a sentinel wrapper process.
 --
 -- The only reason why this is needed is because I want to manage virtualboxes
@@ -43,7 +40,7 @@ runAndWait [n] = do
       p <- vmPID i
       liftIO $ mapM_ waitUntilExit p
     err = logError "Could not get machine ID"
-runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
+runAndWait _ = logInfo "Usage: vbox-start VBOXNAME"
 
 vmLaunch :: T.Text -> RIO SimpleApp ()
 vmLaunch i = do

bin/xmobar.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- | Xmobar binary
 --
 -- Features:
@@ -12,16 +10,15 @@
 module Main (main) where
 
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
+import GHC.Enum (enumFrom)
+import Options.Applicative
 import RIO hiding (hFlush)
-import qualified RIO.ByteString.Lazy as BL
+import RIO.FilePath
 import RIO.List
-import RIO.Process
+import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
-import System.IO
-import UnliftIO.Environment
 import XMonad.Core hiding (config)
-import XMonad.Internal.Command.Desktop
 import XMonad.Internal.Command.Power
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import XMonad.Internal.DBus.Brightness.IntelBacklight
@@ -32,33 +29,58 @@ import Xmobar hiding
   ( iconOffset
   , run
   )
+import Xmobar.Plugins.ActiveConnection
 import Xmobar.Plugins.Bluetooth
 import Xmobar.Plugins.ClevoKeyboard
 import Xmobar.Plugins.Common
-import Xmobar.Plugins.Device
 import Xmobar.Plugins.IntelBacklight
 import Xmobar.Plugins.Screensaver
-import Xmobar.Plugins.VPN
 
 main :: IO ()
-main = getArgs >>= parse
+main = parse >>= xio
 
-parse :: [String] -> IO ()
-parse [] = run
-parse ["--deps"] = withCache printDeps
-parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
-parse _ = usage
+parse :: IO XOpts
+parse = execParser opts
+  where
+    parseOpts = parseDeps <|> parseTest <|> pure XRun
+    opts =
+      info (parseOpts <**> helper) $
+        fullDesc <> header "xmobar: the best taskbar ever"
 
-run :: IO ()
+data XOpts = XDeps | XTest | XRun
+
+parseDeps :: Parser XOpts
+parseDeps =
+  flag'
+    XDeps
+    (long "deps" <> short 'd' <> help "print dependencies")
+
+parseTest :: Parser XOpts
+parseTest =
+  flag'
+    XTest
+    (long "test" <> short 't' <> help "test dependencies without running")
+
+xio :: XOpts -> IO ()
+xio o = case o of
+  XDeps -> hRunXIO False stderr printDeps
+  XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
+  XRun -> runXIO "xmobar.log" run
+
+run :: XIO ()
 run = do
-  db <- connectDBus
-  c <- withCache $ evalConfig db
-  disconnectDBus db
-  -- this is needed to see any printed messages
-  hFlush stdout
-  xmobar c
+  -- IDK why this is needed, I thought this was default
+  liftIO $ hSetBuffering stdout LineBuffering
+  -- this isn't totally necessary except for the fact that killing xmobar
+  -- will make it print something about catching SIGTERM, and without
+  -- linebuffering it usually only prints the first few characters (even then
+  -- it only prints 10-20% of the time)
+  liftIO $ hSetBuffering stderr LineBuffering
+  -- TODO do these dbus things really need to remain connected?
+  c <- withDBus Nothing Nothing evalConfig
+  liftIO $ xmobar c
 
-evalConfig :: DBusState -> FIO Config
+evalConfig :: DBusState -> XIO Config
 evalConfig db = do
   cs <- getAllCommands <$> rightPlugins db
   bf <- getTextFont
@@ -66,21 +88,14 @@ evalConfig db = do
   d <- io $ cfgDir <$> getDirectories
   return $ config bf ifs ios cs d
 
-printDeps :: FIO ()
-printDeps = do
-  db <- io connectDBus
-  let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
-  io $ mapM_ (putStrLn . T.unpack) ps
-  io $ disconnectDBus db
-
-usage :: IO ()
-usage =
-  putStrLn $
-    intercalate
-      "\n"
-      [ "xmobar: run greatest taskbar"
-      , "xmobar --deps: print dependencies"
-      ]
+printDeps :: XIO ()
+printDeps = withDBus_ Nothing Nothing $ \db ->
+  mapM_ logInfo $
+    fmap showFulfillment $
+      sort $
+        nub $
+          concatMap dumpFeature $
+            allFeatures db
 
 --------------------------------------------------------------------------------
 -- toplevel configuration
@@ -103,7 +118,7 @@ iconFont =
   fontSometimes
     "XMobar Icon Font"
     "Symbols Nerd Font"
-    [Package Official "ttf-nerd-fonts-symbols-2048-em"]
+    [Package Official "ttf-nerd-fonts-symbols"]
 
 -- | Offsets for the icons in the bar (relative to the text offset)
 iconOffset :: BarFont -> Int
@@ -149,7 +164,7 @@ config bf ifs ios br confDir =
     , pickBroadest = False
     , persistent = True
     , -- store the icons with the xmonad/xmobar stack project
-      iconRoot = confDir ++ "/icons"
+      iconRoot = confDir </> "assets" </> "icons"
     , commands = csRunnable <$> concatRegions br
     }
 
@@ -172,7 +187,7 @@ getAllCommands right =
     , brRight = catMaybes right
     }
 
-rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
+rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
 rightPlugins db =
   mapM evalFeature $
     allFeatures db
@@ -204,11 +219,11 @@ getWireless =
     xpfWireless
     [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 
-getEthernet :: Maybe SysClient -> BarFeature
-getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
+getEthernet :: Maybe NamedSysConnection -> BarFeature
+getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
   where
-    root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
-    tree = And1 (Only readEthernet) (Only_ devDep)
+    root useIcon tree' =
+      DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
 
 getBattery :: BarFeature
 getBattery = iconIO_ "battery level indicator" xpfBattery root tree
@@ -220,18 +235,12 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
           io $
             fmap (Msg LevelError) <$> hasBattery
 
-getVPN :: Maybe SysClient -> BarFeature
-getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
+getVPN :: Maybe NamedSysConnection -> BarFeature
+getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
   where
     root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
-    test =
-      DBusIO $
-        IOTest_
-          "Use nmcli to test if VPN is present"
-          networkManagerPkgs
-          vpnPresent
 
-getBt :: Maybe SysClient -> BarFeature
+getBt :: Maybe NamedSysConnection -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
 
 getAlsa :: BarFeature
@@ -242,7 +251,7 @@ getAlsa =
   where
     root useIcon = IORoot_ (alsaCmd useIcon)
 
-getBl :: Maybe SesClient -> BarFeature
+getBl :: Maybe NamedSesConnection -> BarFeature
 getBl =
   xmobarDBus
     "Intel backlight indicator"
@@ -250,7 +259,7 @@ getBl =
     intelBacklightSignalDep
     blCmd
 
-getCk :: Maybe SesClient -> BarFeature
+getCk :: Maybe NamedSesConnection -> BarFeature
 getCk =
   xmobarDBus
     "Clevo keyboard indicator"
@@ -258,7 +267,7 @@ getCk =
     clevoKeyboardSignalDep
     ckCmd
 
-getSs :: Maybe SesClient -> BarFeature
+getSs :: Maybe NamedSesConnection -> BarFeature
 getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
 
 getLock :: Always CmdSpec
@@ -275,7 +284,7 @@ xmobarDBus
   -> XPQuery
   -> DBusDependency_ c
   -> (Fontifier -> CmdSpec)
-  -> Maybe c
+  -> Maybe (NamedConnection c)
   -> BarFeature
 xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
   where
@@ -289,18 +298,16 @@ iconIO_
   -> BarFeature
 iconIO_ = iconSometimes' And_ Only_
 
-iconDBus
-  :: SafeClient c
-  => T.Text
-  -> XPQuery
-  -> (Fontifier -> DBusTree c p -> Root CmdSpec)
-  -> DBusTree c p
-  -> BarFeature
-iconDBus = iconSometimes' And1 $ Only_ . DBusIO
+-- iconDBus
+--   :: T.Text
+--   -> XPQuery
+--   -> (Fontifier -> DBusTree c p -> Root CmdSpec)
+--   -> DBusTree c p
+--   -> BarFeature
+-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
 
 iconDBus_
-  :: SafeClient c
-  => T.Text
+  :: T.Text
   -> XPQuery
   -> (Fontifier -> DBusTree_ c -> Root CmdSpec)
   -> DBusTree_ c
@@ -362,13 +369,19 @@ wirelessCmd iface =
         , "<icon=wifi_%%.xpm/>"
         ]
 
-ethernetCmd :: Fontifier -> T.Text -> CmdSpec
-ethernetCmd fontify iface =
+ethernetCmd :: Fontifier -> CmdSpec
+ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
+
+vpnCmd :: Fontifier -> CmdSpec
+vpnCmd = connCmd "\xf023" "VPN" ("tun" :| [])
+
+connCmd :: T.Text -> T.Text -> NE.NonEmpty T.Text -> Fontifier -> CmdSpec
+connCmd icon abbr contypes fontify =
   CmdSpec
-    { csAlias = iface
+    { csAlias = connAlias contypes
     , csRunnable =
         Run $
-          Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
+          ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
     }
 
 batteryCmd :: Fontifier -> CmdSpec
@@ -404,20 +417,13 @@ batteryCmd fontify =
         , fontify' "\xf1e6" "AC"
         ]
 
-vpnCmd :: Fontifier -> CmdSpec
-vpnCmd fontify =
-  CmdSpec
-    { csAlias = vpnAlias
-    , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
-    }
-
 btCmd :: Fontifier -> CmdSpec
 btCmd fontify =
   CmdSpec
     { csAlias = btAlias
     , csRunnable =
         Run $
-          Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
+          Bluetooth (fontify' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
     }
   where
     fontify' i = fontify IconLarge i . T.append "BT"
@@ -458,7 +464,7 @@ ckCmd :: Fontifier -> CmdSpec
 ckCmd fontify =
   CmdSpec
     { csAlias = ckAlias
-    , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
+    , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
     }
 
 ssCmd :: Fontifier -> CmdSpec
@@ -494,8 +500,8 @@ lockCmd fontify =
               ]
     }
   where
-    numIcon = fontify' "\xf8a5" "N"
-    capIcon = fontify' "\xf657" "C"
+    numIcon = fontify' "\x0f03a6" "N"
+    capIcon = fontify' "\x0f0bf1" "C"
     fontify' = fontify IconXLarge
     disabledColor = xmobarFGColor XT.backdropFgColor
 
@@ -506,36 +512,13 @@ dateCmd =
     , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
     }
 
---------------------------------------------------------------------------------
--- low-level testing functions
-
-vpnPresent :: FIO (Maybe Msg)
-vpnPresent = do
-  res <- proc "nmcli" args readProcess
-  return $ case res of
-    (ExitSuccess, out, _)
-      | "vpn" `elem` BL.split 10 out -> Nothing
-      | otherwise -> Just $ Msg LevelError "vpn not found"
-    (ExitFailure c, _, err) ->
-      Just $
-        Msg LevelError $
-          T.concat
-            [ "vpn search exited with code "
-            , T.pack $ show c
-            , ": "
-            , T.decodeUtf8With T.lenientDecode $
-                BL.toStrict err
-            ]
-  where
-    args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
-
 --------------------------------------------------------------------------------
 -- text font
 --
 -- ASSUME there is only one text font for this entire configuration. This
 -- will correspond to the first font/offset parameters in the config record.
 
-getTextFont :: FIO T.Text
+getTextFont :: XIO T.Text
 getTextFont = do
   fb <- evalAlways textFont
   return $ fb textFontData
@@ -543,7 +526,7 @@ getTextFont = do
 --------------------------------------------------------------------------------
 -- icon fonts
 
-getIconFonts :: FIO ([T.Text], [Int])
+getIconFonts :: XIO ([T.Text], [Int])
 getIconFonts = do
   fb <- evalSometimes iconFont
   return $ maybe ([], []) apply fb

bin/xmonad.hs

@@ -1,20 +1,16 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 --  XMonad binary
 
 module Main (main) where
 
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import Data.Monoid
 import Data.Text.IO (hPutStrLn)
 import Graphics.X11.Types
 import Graphics.X11.Xlib.Atom
 import Graphics.X11.Xlib.Extras
+import Options.Applicative hiding (action)
 import RIO
 import RIO.Directory
 import RIO.List
@@ -25,8 +21,7 @@ import System.Process
   ( getPid
   , getProcessExitCode
   )
-import UnliftIO.Environment
-import XMonad
+import XMonad hiding (display)
 import XMonad.Actions.CopyWindow
 import XMonad.Actions.CycleWS
 import XMonad.Actions.PhysicalScreens
@@ -50,6 +45,7 @@ import XMonad.Internal.DBus.Removable
 import XMonad.Internal.DBus.Screensaver
 import XMonad.Internal.Shell hiding (proc)
 import qualified XMonad.Internal.Theme as XT
+import XMonad.Layout.Decoration
 import XMonad.Layout.MultiToggle
 import XMonad.Layout.NoBorders
 import XMonad.Layout.NoFrillsDecoration
@@ -65,15 +61,37 @@ import XMonad.Util.NamedActions
 import XMonad.Util.WorkspaceCompare
 
 main :: IO ()
-main = getArgs >>= parse
+main = parse >>= xio
 
-parse :: [String] -> IO ()
-parse [] = run
-parse ["--deps"] = withCache printDeps
--- parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
-parse _ = usage
+parse :: IO XOpts
+parse = execParser opts
+  where
+    parseOpts = parseDeps <|> parseTest <|> pure XRun
+    opts =
+      info (parseOpts <**> helper) $
+        fullDesc <> header "xmonad: the best window manager ever"
 
-run :: IO ()
+data XOpts = XDeps | XTest | XRun
+
+parseDeps :: Parser XOpts
+parseDeps =
+  flag'
+    XDeps
+    (long "deps" <> short 'd' <> help "print dependencies")
+
+parseTest :: Parser XOpts
+parseTest =
+  flag'
+    XTest
+    (long "test" <> short 't' <> help "test dependencies without running")
+
+xio :: XOpts -> IO ()
+xio o = case o of
+  XDeps -> hRunXIO False stderr printDeps
+  XTest -> undefined
+  XRun -> runXIO "xmonad.log" run
+
+run :: XIO ()
 run = do
   -- These first two commands are only significant when xmonad is restarted.
   -- The 'launch' function below this will turn off buffering (so flushes are
@@ -88,31 +106,31 @@ run = do
   -- signal handlers to carry over to the top.
   uninstallSignalHandlers
   hSetBuffering stdout LineBuffering
-  withCache $ do
-    withDBusX $ \db -> do
-      let sys = dbSysClient db
-      let fs = features sys
-      startDBusInterfaces db fs
+  withDBusX_ $ \db -> do
+    let fs = features $ dbSysClient db
+    withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do
       withXmobar $ \xmobarP -> do
         withChildDaemons fs $ \ds -> do
-          let ts = ThreadState ds (Just xmobarP)
-          startRemovableMon db fs
-          startPowerMon fs
+          let toClean = Cleanup ds (Just xmobarP) unexporters
+          void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
+          void $ async $ void $ executeSometimes $ fsPowerMon fs
           dws <- startDynWorkspaces fs
-          kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
+          runIO <- askRunInIO
+          let cleanup = runCleanup runIO toClean db
+          kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
           sk <- evalAlways $ fsShowKeys fs
           ha <- evalAlways $ fsACPIHandler fs
           tt <- evalAlways $ fsTabbedTheme fs
           let conf =
                 ewmh $
-                  addKeymap dws sk kbs $
+                  addKeymap dws (liftIO . runIO . sk) kbs $
                     docks $
                       def
                         { terminal = myTerm
                         , modMask = myModMask
                         , layoutHook = myLayouts tt
                         , manageHook = myManageHook dws
-                        , handleEventHook = myEventHook ha
+                        , handleEventHook = myEventHook runIO ha
                         , startupHook = myStartupHook
                         , workspaces = myWorkspaces
                         , logHook = myLoghook xmobarP
@@ -121,32 +139,21 @@ run = do
                         , normalBorderColor = T.unpack XT.bordersColor
                         , focusedBorderColor = T.unpack XT.selectedBordersColor
                         }
-          io $ runXMonad conf
+          runXMonad conf
   where
-    startRemovableMon db fs =
-      void $
-        executeSometimes $
-          fsRemovableMon fs $
-            dbSysClient db
-    startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
     startDynWorkspaces fs = do
       dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
-      void $ io $ async $ runWorkspaceMon dws
+      void $ async $ runWorkspaceMon dws
       return dws
 
-runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
+runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> XIO ()
 runXMonad conf = do
   dirs <- getCreateDirectories
-  launch conf dirs
+  liftIO $ launch conf dirs
 
-startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
-startDBusInterfaces db fs =
-  mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
-    fsDBusExporters fs
-
-getCreateDirectories :: IO Directories
+getCreateDirectories :: XIO Directories
 getCreateDirectories = do
-  ds <- getDirectories
+  ds <- liftIO getDirectories
   mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
   return ds
   where
@@ -154,19 +161,19 @@ getCreateDirectories = do
       let d = f ds
       r <- tryIO $ createDirectoryIfMissing True d
       case r of
-        (Left e) -> print e
+        (Left e) -> logError $ display e
         _ -> return ()
 
 data FeatureSet = FeatureSet
-  { fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe SesClient -> SometimesIO]
+  { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
+  , fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
   , fsPowerMon :: SometimesIO
-  , fsRemovableMon :: Maybe SysClient -> SometimesIO
-  , fsDaemons :: [Sometimes (FIO (Process () () ()))]
+  , fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
+  , fsDaemons :: [Sometimes (XIO (Process () () ()))]
   , fsACPIHandler :: Always (String -> X ())
   , fsTabbedTheme :: Always Theme
   , fsDynWorkspaces :: [Sometimes DynWorkspace]
-  , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
+  , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ())
   }
 
 tabbedFeature :: Always Theme
@@ -176,7 +183,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
     niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
     fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
 
-features :: Maybe SysClient -> FeatureSet
+features :: Maybe NamedSysConnection -> FeatureSet
 features cl =
   FeatureSet
     { fsKeys = externalBindings
@@ -190,8 +197,12 @@ features cl =
     , fsDaemons = [runNetAppDaemon cl, runAutolock]
     }
 
-startXmobar :: FIO (Process Handle () ())
+withXmobar :: (Process Handle () () -> XIO a) -> XIO a
+withXmobar = bracket startXmobar stopXmobar
+
+startXmobar :: XIO (Process Handle () ())
 startXmobar = do
+  logInfo "starting xmobar child process"
   p <- proc "xmobar" [] start
   io $ hSetBuffering (getStdin p) LineBuffering
   return p
@@ -201,76 +212,87 @@ startXmobar = do
         . setStdin createPipe
         . setCreateGroup True
 
-startChildDaemons :: FeatureSet -> FIO [Process () () ()]
-startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
-
-withDBusX :: (DBusState -> FIO a) -> FIO a
-withDBusX = bracket (io connectDBusX) cleanup
-  where
-    cleanup db = do
-      logInfo "unregistering xmonad from DBus"
-      io $ disconnectDBus db
-
-withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a
-withChildDaemons fs = bracket (startChildDaemons fs) cleanup
-  where
-    cleanup ps = do
-      logInfo "stopping child processes"
-      mapM_ (io . killNoWait) ps
-
-withXmobar :: (Process Handle () () -> FIO a) -> FIO a
-withXmobar = bracket startXmobar cleanup
-  where
-    cleanup p = do
+stopXmobar
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Process Handle () ()
+  -> m ()
+stopXmobar p = do
   logInfo "stopping xmobar child process"
   io $ killNoWait p
 
-printDeps :: FIO ()
-printDeps = do
-  db <- io connectDBus
-  (i, f, d) <- allFeatures db
-  io $
-    mapM_ (putStrLn . T.unpack) $
+withChildDaemons
+  :: FeatureSet
+  -> ([(Utf8Builder, Process () () ())] -> XIO a)
+  -> XIO a
+withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
+
+startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())]
+startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs)
+  where
+    start s@(Sometimes sname _ _) = do
+      let sname_ = Utf8Builder $ encodeUtf8Builder sname
+      res <- executeSometimes s
+      case res of
+        Just p -> do
+          logInfo $ "starting child process: " <> sname_
+          return $ Just (sname_, p)
+        -- don't log anything here since presumably the feature itself will log
+        -- an error if it fails during execution
+        _ -> return Nothing
+
+stopChildDaemons
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => [(Utf8Builder, Process () () ())]
+  -> m ()
+stopChildDaemons = mapM_ stop
+  where
+    stop (n, p) = do
+      logInfo $ "stopping child process: " <> n
+      liftIO $ killNoWait p
+
+printDeps :: XIO ()
+printDeps = withDBus_ Nothing Nothing $ \db -> do
+  runIO <- askRunInIO
+  let mockCleanup = runCleanup runIO mockClean db
+  let bfs =
+        concatMap (fmap kbMaybeAction . kgBindings) $
+          externalBindings runIO mockCleanup db
+  let dbus =
+        fmap (\f -> f $ dbSesClient db) dbusExporters
+          :: [Sometimes (XIO (), XIO ())]
+  let others = [runRemovableMon $ dbSysClient db, runPowermon]
+  -- TODO might be better to use glog for this?
+  mapM_ logInfo $
     fmap showFulfillment $
       sort $
         nub $
           concat $
-              fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
-  io $ disconnectDBus db
-
-allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
-allFeatures db = do
-  let bfs =
-        concatMap (fmap kbMaybeAction . kgBindings) $
-          externalBindings ts db
-  let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
-  let others = [runRemovableMon $ dbSysClient db, runPowermon]
-  return (dbus ++ others, Left runScreenLock : bfs, allDWs')
+            fmap dumpSometimes dbus
+              ++ fmap dumpSometimes others
+              ++ fmap dumpSometimes allDWs'
+              ++ fmap dumpFeature bfs
   where
-    ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
-
-usage :: IO ()
-usage =
-  putStrLn $
-    intercalate
-      "\n"
-      [ "xmonad: run greatest window manager"
-      , "xmonad --deps: print dependencies"
-      ]
+    mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
 
 --------------------------------------------------------------------------------
 -- Concurrency configuration
 
-data ThreadState = ThreadState
-  { tsChildPIDs :: [Process () () ()]
-  , tsXmobar :: Maybe (Process Handle () ())
+data Cleanup = Cleanup
+  { clChildren :: [(Utf8Builder, Process () () ())]
+  , clXmobar :: Maybe (Process Handle () ())
+  , clDBusUnexporters :: [XIO ()]
   }
 
-runCleanup :: ThreadState -> DBusState -> X ()
-runCleanup ts db = io $ do
-  mapM_ killNoWait $ tsXmobar ts
-  mapM_ killNoWait $ tsChildPIDs ts
-  disconnectDBusX db
+runCleanup
+  :: (XIO () -> IO ())
+  -> Cleanup
+  -> DBusState
+  -> X ()
+runCleanup runIO ts db = liftIO $ runIO $ do
+  mapM_ stopXmobar $ clXmobar ts
+  stopChildDaemons $ clChildren ts
+  sequence_ $ clDBusUnexporters ts
+  disconnectDBus db
 
 -- | Kill a process (group) after xmonad has already started
 -- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
@@ -323,9 +345,6 @@ vmTag = "VM"
 xsaneTag :: String
 xsaneTag = "XSANE"
 
-f5Tag :: String
-f5Tag = "F5VPN"
-
 gimpDynamicWorkspace :: Sometimes DynWorkspace
 gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
   where
@@ -398,31 +417,11 @@ xsaneDynamicWorkspace =
         }
     c = "Xsane"
 
-f5vpnDynamicWorkspace :: Sometimes DynWorkspace
-f5vpnDynamicWorkspace =
-  Sometimes
-    "F5 VPN workspace"
-    xpfF5VPN
-    [Subfeature (IORoot_ dw tree) "f5vpn"]
-  where
-    tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
-    dw =
-      DynWorkspace
-        { dwName = "F5Vpn"
-        , dwTag = f5Tag
-        , dwClass = c
-        , dwHook = [className =? c -?> appendShift f5Tag]
-        , dwKey = 'i'
-        , dwCmd = Just skip
-        }
-    c = "F5 VPN"
-
 allDWs' :: [Sometimes DynWorkspace]
 allDWs' =
   [ xsaneDynamicWorkspace
   , vmDynamicWorkspace
   , gimpDynamicWorkspace
-  , f5vpnDynamicWorkspace
   ]
 
 --------------------------------------------------------------------------------
@@ -437,6 +436,10 @@ myLayouts tt =
       mkToggle (single HIDE) $
         tall ||| fulltab ||| full
   where
+    addTopBar
+      :: (Eq a)
+      => l a
+      -> ModifiedLayout (Decoration NoFrillsDecoration DefaultShrinker) l a
     addTopBar = noFrillsDeco shrinkText tt
     tall =
       renamed [Replace "Tall"] $
@@ -619,20 +622,30 @@ manageApps dws =
 --------------------------------------------------------------------------------
 -- Eventhook configuration
 
-myEventHook :: (String -> X ()) -> Event -> X All
-myEventHook handler = xMsgEventHook handler <+> handleEventHook def
+myEventHook
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => (m () -> IO ())
+  -> (String -> X ())
+  -> Event
+  -> X All
+myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def
 
 -- | React to ClientMessage events from concurrent threads
-xMsgEventHook :: (String -> X ()) -> Event -> X All
-xMsgEventHook handler ClientMessageEvent {ev_message_type = t, ev_data = d}
+xMsgEventHook
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => (m () -> IO ())
+  -> (String -> X ())
+  -> Event
+  -> X All
+xMsgEventHook runIO handler ClientMessageEvent {ev_message_type = t, ev_data = d}
   | t == bITMAP = do
       let (xtype, tag) = splitXMsg d
       case xtype of
         Workspace -> removeDynamicWorkspace tag
         ACPI -> handler tag
-        Unknown -> io $ putStrLn "WARNING: unknown concurrent message"
+        Unknown -> liftIO $ runIO $ logWarn "unknown concurrent message"
       return (All True)
-xMsgEventHook _ _ = return (All True)
+xMsgEventHook _ _ _ = return (All True)
 
 --------------------------------------------------------------------------------
 -- Keymap configuration
@@ -735,13 +748,13 @@ data KeyGroup a = KeyGroup
   , kgBindings :: [KeyBinding a]
   }
 
-evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
+evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
 evalExternal = mapM go
   where
     go k@KeyGroup {kgBindings = bs} =
       (\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
 
-evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
+evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
 evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
   (\f -> k {kbMaybeAction = f}) <$> evalFeature a
 
@@ -756,52 +769,52 @@ filterExternal = fmap go
             ]
         }
 
-externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
-externalBindings ts db =
+externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
+externalBindings runIO cleanup db =
   [ KeyGroup
       "Launchers"
-      [ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
-      , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
-      , KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
-      , KeyBinding "M-w" "launch window selector" $ Left runWinMenu
-      , KeyBinding "M-u" "launch device selector" $ Left runDevMenu
-      , KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses
-      , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
-      , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
-      , KeyBinding "M-C-e" "launch editor" $ Left runEditor
-      , KeyBinding "M-C-w" "launch browser" $ Left runBrowser
-      , KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux
-      , KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm
-      , KeyBinding "M-C-q" "launch calc" $ Left runCalc
-      , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
+      [ KeyBinding "<XF86Search>" "select/launch app" $ Left $ toX runAppMenu
+      , KeyBinding "M-g" "launch clipboard manager" $ Left $ toX runClipMenu
+      , KeyBinding "M-a" "launch network selector" $ Left $ toX $ runNetMenu sys
+      , KeyBinding "M-w" "launch window selector" $ Left $ toX runWinMenu
+      , KeyBinding "M-u" "launch device selector" $ Left $ toX runDevMenu
+      , KeyBinding "M-b" "launch bitwarden selector" $ Left $ toX $ runBwMenu ses
+      , KeyBinding "M-v" "launch ExpressVPN selector" $ Left $ toX runVPNMenu
+      , KeyBinding "M-e" "launch bluetooth selector" $ Left $ toX runBTMenu
+      , KeyBinding "M-C-e" "launch editor" $ Left $ toX runEditor
+      , KeyBinding "M-C-w" "launch browser" $ Left $ toX runBrowser
+      , KeyBinding "M-C-t" "launch terminal with tmux" $ Left $ toX runTMux
+      , KeyBinding "M-C-S-t" "launch terminal" $ Left $ toX runTerm
+      , KeyBinding "M-C-q" "launch calc" $ Left $ toX runCalc
+      , KeyBinding "M-C-f" "launch file manager" $ Left $ toX runFileManager
       ]
   , KeyGroup
       "Actions"
       [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
-      , KeyBinding "M-r" "run program" $ Left runCmdMenu
+      , KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu
       , KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
-      , KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses
-      , KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses
-      , KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses
-      , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
+      , KeyBinding "M-C-s" "capture area" $ Left $ toX $ runAreaCapture ses
+      , KeyBinding "M-C-S-s" "capture screen" $ Left $ toX $ runScreenCapture ses
+      , KeyBinding "M-C-d" "capture desktop" $ Left $ toX $ runDesktopCapture ses
+      , KeyBinding "M-C-b" "browse captures" $ Left $ toX runCaptureBrowser
       -- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
       ]
   , KeyGroup
       "Multimedia"
-      [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
-      , KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
-      , KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
-      , KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay
-      , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown
-      , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
-      , KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
+      [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left $ toX runTogglePlay
+      , KeyBinding "<XF86AudioPrev>" "previous track" $ Left $ toX runPrevTrack
+      , KeyBinding "<XF86AudioNext>" "next track" $ Left $ toX runNextTrack
+      , KeyBinding "<XF86AudioStop>" "stop" $ Left $ toX runStopPlay
+      , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left $ toX runVolumeDown
+      , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left $ toX runVolumeUp
+      , KeyBinding "<XF86AudioMute>" "volume mute" $ Left $ toX runVolumeMute
       ]
   , KeyGroup
       "Dunst"
-      [ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
-      , KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
-      , KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
-      , KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
+      [ KeyBinding "M-`" "dunst history" $ Left $ toX $ runNotificationHistory ses
+      , KeyBinding "M-S-`" "dunst close" $ Left $ toX $ runNotificationClose ses
+      , KeyBinding "M-M1-`" "dunst context menu" $ Left $ toX $ runNotificationContext ses
+      , KeyBinding "M-C-`" "dunst close all" $ Left $ toX $ runNotificationCloseAll ses
       ]
   , KeyGroup
       "System"
@@ -819,22 +832,25 @@ externalBindings ts db =
       , -- M-<F1> reserved for showing the keymap
         KeyBinding "M-<F2>" "restart xmonad" restartf
       , KeyBinding "M-<F3>" "recompile xmonad" recompilef
-      , KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
-      , KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
-      , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
-      , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ callToggle ses
+      , KeyBinding "M-<F7>" "select autorandr profile" $ Left $ toX runAutorandrMenu
+      , KeyBinding "M-<F8>" "toggle wifi" $ Left $ toX runToggleWifi
+      , KeyBinding "M-<F9>" "toggle network" $ Left $ toX runToggleNetworking
+      , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys
+      , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ toX $ callToggle ses
       , KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
       ]
   ]
   where
     ses = dbSesClient db
     sys = dbSysClient db
-    brightessControls ctl getter = (getter . ctl) ses
+    brightessControls ctl getter = (toX . getter . ctl) ses
     ib = Left . brightessControls intelBacklightControls
     ck = Left . brightessControls clevoKeyboardControls
     ftrAlways n = Right . Always n . Always_ . FallbackAlone
-    restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
+    restartf = ftrAlways "restart function" (cleanup >> runRestart)
     recompilef = ftrAlways "recompile function" runRecompile
+    toX_ = liftIO . runIO
+    toX = fmap toX_
 
 type MaybeX = Maybe (X ())
 

lib/Data/Internal/DBus.hs

@@ -5,7 +5,17 @@ module Data.Internal.DBus
   ( SafeClient (..)
   , SysClient (..)
   , SesClient (..)
+  , NamedConnection (..)
+  , NamedSesConnection
+  , NamedSysConnection
+  , DBusEnv (..)
+  , DIO
+  , HasClient (..)
+  , releaseBusName
+  , withDIO
   , addMatchCallback
+  , addMatchCallbackSignal
+  , matchSignalFull
   , matchProperty
   , matchPropertyFull
   , matchPropertyChanged
@@ -25,77 +35,218 @@ module Data.Internal.DBus
   , addInterfaceRemovedListener
   , fromSingletonVariant
   , bodyToMaybe
+  , exportPair
+  , displayBusName
+  , displayObjectPath
+  , displayMemberName
+  , displayInterfaceName
+  , displayWrapQuote
+  , busNameT
+  , interfaceNameT
+  , memberNameT
+  , objectPathT
   )
 where
 
 import DBus
 import DBus.Client
+import qualified Data.ByteString.Char8 as BC
 import RIO
+import RIO.List
 import qualified RIO.Map as M
 import qualified RIO.Text as T
 
 --------------------------------------------------------------------------------
 -- Type-safe client
 
+data NamedConnection c = NamedConnection
+  { ncClient :: !Client
+  , ncHumanName :: !(Maybe BusName)
+  --, ncUniqueName :: !BusName
+  , ncType :: !c
+  }
+
+type NamedSesConnection = NamedConnection SesClient
+
+type NamedSysConnection = NamedConnection SysClient
+
 class SafeClient c where
-  toClient :: c -> Client
+  getDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => Maybe BusName
+    -> m (Maybe (NamedConnection c))
 
-  getDBusClient :: MonadUnliftIO m => m (Maybe c)
+  disconnectDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => NamedConnection c
+    -> m ()
+  disconnectDBusClient c = do
+    releaseBusName c
+    liftIO $ disconnect $ ncClient c
 
-  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
-  disconnectDBusClient = liftIO . disconnect . toClient
+  withDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => Maybe BusName
+    -> (NamedConnection c -> m a)
+    -> m (Maybe a)
+  withDBusClient n f =
+    bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
 
-  withDBusClient :: MonadUnliftIO m => (c -> m a) -> m (Maybe a)
-  withDBusClient f =
-    bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
+  withDBusClient_
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => Maybe BusName
+    -> (NamedConnection c -> m ())
+    -> m ()
+  withDBusClient_ n = void . withDBusClient n
 
-  withDBusClient_ :: MonadUnliftIO m => (c -> m ()) -> m ()
-  withDBusClient_ = void . withDBusClient
+  fromDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => Maybe BusName
+    -> (NamedConnection c -> a)
+    -> m (Maybe a)
+  fromDBusClient n f = withDBusClient n (return . f)
 
-  fromDBusClient :: MonadUnliftIO m => (c -> a) -> m (Maybe a)
-  fromDBusClient f = withDBusClient (return . f)
-
-newtype SysClient = SysClient Client
+data SysClient = SysClient
 
 instance SafeClient SysClient where
-  toClient (SysClient cl) = cl
+  getDBusClient = connectToDBusWithName True SysClient
 
-  getDBusClient = fmap SysClient <$> getDBusClient' True
-
-newtype SesClient = SesClient Client
+data SesClient = SesClient
 
 instance SafeClient SesClient where
-  toClient (SesClient cl) = cl
+  -- TODO wet
+  getDBusClient = connectToDBusWithName False SesClient
 
-  getDBusClient = fmap SesClient <$> getDBusClient' False
+connectToDBusWithName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Bool
+  -> c
+  -> Maybe BusName
+  -> m (Maybe (NamedConnection c))
+connectToDBusWithName sys t n = do
+  clRes <- getDBusClient' sys
+  case clRes of
+    Nothing -> do
+      logError "could not get client"
+      return Nothing
+    Just cl -> do
+      --helloRes <- liftIO $ callHello cl
+      --case helloRes of
+      --  Nothing -> do
+      --    logError "count not get unique name"
+      --    return Nothing
+      --  Just unique -> do
+          n' <- maybe (return Nothing) (`requestBusName` cl) n
+          return $
+            Just $
+              NamedConnection
+                { ncClient = cl
+                , ncHumanName = n'
+      --          , ncUniqueName = unique
+                , ncType = t
+                }
 
-getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client)
+releaseBusName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => NamedConnection c
+  -> m ()
+releaseBusName NamedConnection {ncClient, ncHumanName} = do
+  -- TODO this might error?
+  case ncHumanName of
+    Just n -> do
+      liftIO $ void $ releaseName ncClient n
+      logInfo $ "released bus name: " <> displayBusName n
+    Nothing -> return ()
+
+requestBusName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => BusName
+  -> Client
+  -> m (Maybe BusName)
+requestBusName n cl = do
+  res <- try $ liftIO $ requestName cl n []
+  case res of
+    Left e -> do
+      logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+      return Nothing
+    Right r -> do
+      let msg
+            | r == NamePrimaryOwner = "registering name"
+            | r == NameAlreadyOwner = "this process already owns name"
+            | r == NameInQueue
+                || r == NameExists =
+                "another process owns name"
+            -- this should never happen
+            | otherwise = "unknown error when requesting name"
+      logInfo $ msg <> ": " <> displayBusName n
+      case r of
+        NamePrimaryOwner -> return $ Just n
+        _ -> return Nothing
+
+getDBusClient'
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Bool
+  -> m (Maybe Client)
 getDBusClient' sys = do
   res <- try $ liftIO $ if sys then connectSystem else connectSession
   case res of
-    Left e -> liftIO $ putStrLn (clientErrorMessage e) >> return Nothing
+    Left e -> do
+      logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+      return Nothing
     Right c -> return $ Just c
 
+--callHello :: Client -> IO (Maybe BusName)
+--callHello cl = do
+--  reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
+--  case methodReturnBody reply of
+--    [name] | Just nameStr <- fromVariant name -> do
+--      busName <- parseBusName nameStr
+--      return $ Just busName
+--    _ -> return Nothing
+--
+data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
+
+type DIO env c = RIO (DBusEnv env c)
+
+instance HasClient (DBusEnv SimpleApp) where
+  clientL = lens dClient (\x y -> x {dClient = y})
+
+instance HasLogFunc (DBusEnv SimpleApp c) where
+  logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
+
+withDIO
+  :: (MonadUnliftIO m, MonadReader env m)
+  => NamedConnection c
+  -> DIO env c a
+  -> m a
+withDIO cl x = do
+  env <- ask
+  runRIO (DBusEnv cl env) x
+
+class HasClient env where
+  clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
+
 --------------------------------------------------------------------------------
 -- Methods
 
 type MethodBody = Either T.Text [Variant]
 
-callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
-callMethod' cl =
-  liftIO
-    . fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
-    . call (toClient cl)
+callMethod'
+  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
+  => MethodCall
+  -> m MethodBody
+callMethod' mc = do
+  cl <- ncClient <$> view clientL
+  liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
 
 callMethod
-  :: (MonadUnliftIO m, SafeClient c)
-  => c
-  -> BusName
+  :: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
+  => BusName
   -> ObjectPath
   -> InterfaceName
   -> MemberName
   -> m MethodBody
-callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
+callMethod bus path iface = callMethod' . methodCallBus bus path iface
 
 methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
 methodCallBus b p i m =
@@ -109,8 +260,22 @@ methodCallBus b p i m =
 dbusInterface :: InterfaceName
 dbusInterface = interfaceName_ "org.freedesktop.DBus"
 
-callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
-callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
+callGetNameOwner
+  :: ( SafeClient c
+     , MonadUnliftIO m
+     , MonadReader (env c) m
+     , HasClient env
+     , HasLogFunc (env c)
+     )
+  => BusName
+  -> m (Maybe BusName)
+callGetNameOwner name = do
+  res <- callMethod' mc
+  case res of
+    Left err -> do
+      logError $ Utf8Builder $ encodeUtf8Builder err
+      return Nothing
+    Right body -> return $ fromSingletonVariant body
   where
     mc =
       (methodCallBus dbusName dbusPath dbusInterface mem)
@@ -121,6 +286,7 @@ callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
 --------------------------------------------------------------------------------
 -- Variant parsing
 
+-- TODO log failures here?
 fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
 fromSingletonVariant = fromVariant <=< listToMaybe
 
@@ -132,14 +298,29 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
 
 type SignalCallback m = [Variant] -> m ()
 
+addMatchCallbackSignal
+  :: ( MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => MatchRule
+  -> (Signal -> m ())
+  -> m SignalHandler
+addMatchCallbackSignal rule cb = do
+  cl <- ncClient <$> view clientL
+  withRunInIO $ \run -> addMatch cl rule $ run . cb
+
 addMatchCallback
-  :: (MonadUnliftIO m, SafeClient c)
+  :: ( MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
   => MatchRule
   -> SignalCallback m
-  -> c
   -> m SignalHandler
-addMatchCallback rule cb cl = withRunInIO $ \run -> do
-  addMatch (toClient cl) rule $ run . cb . signalBody
+addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
 
 matchSignal
   :: Maybe BusName
@@ -156,15 +337,35 @@ matchSignal b p i m =
     }
 
 matchSignalFull
-  :: (MonadUnliftIO m, SafeClient c)
-  => c
-  -> BusName
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => BusName
   -> Maybe ObjectPath
   -> Maybe InterfaceName
   -> Maybe MemberName
   -> m (Maybe MatchRule)
-matchSignalFull client b p i m =
-  fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
+matchSignalFull b p i m = do
+  res <- callGetNameOwner b
+  case res of
+    Just o -> return $ Just $ matchSignal (Just o) p i m
+    Nothing -> do
+      logError msg
+      return Nothing
+  where
+    bus_ = displayWrapQuote $ displayBusName b
+    iface_ = displayWrapQuote . displayInterfaceName <$> i
+    path_ = displayWrapQuote . displayObjectPath <$> p
+    mem_ = displayWrapQuote . displayMemberName <$> m
+    match =
+      intersperse ", " $
+        mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $
+          zip ["interface", "path", "member"] [iface_, path_, mem_]
+    stem = "could not get match rule for bus " <> bus_
+    msg = if null match then stem else stem <> " where " <> mconcat match
 
 --------------------------------------------------------------------------------
 -- Properties
@@ -176,31 +377,42 @@ propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"
 
 callPropertyGet
-  :: (MonadUnliftIO m, SafeClient c)
+  :: ( HasClient env
+     , MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     )
   => BusName
   -> ObjectPath
   -> InterfaceName
   -> MemberName
-  -> c
   -> m [Variant]
-callPropertyGet bus path iface property cl =
-  liftIO $
-    fmap (either (const []) (: [])) $
-      getProperty (toClient cl) $
-        methodCallBus bus path iface property
+callPropertyGet bus path iface property = do
+  cl <- ncClient <$> view clientL
+  res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
+  case res of
+    Left err -> do
+      logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
+      return []
+    Right v -> return [v]
 
 matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
 matchProperty b p =
   matchSignal b p (Just propertyInterface) (Just propertySignal)
 
 matchPropertyFull
-  :: (MonadUnliftIO m, SafeClient c)
-  => c
-  -> BusName
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => BusName
   -> Maybe ObjectPath
   -> m (Maybe MatchRule)
-matchPropertyFull cl b p =
-  matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
+matchPropertyFull b p =
+  matchSignalFull b p (Just propertyInterface) (Just propertySignal)
 
 data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
 
@@ -212,26 +424,26 @@ withSignalMatch _ NoMatch = return ()
 matchPropertyChanged
   :: IsVariant a
   => InterfaceName
-  -> T.Text
+  -> MemberName
   -> [Variant]
   -> SignalMatch a
-matchPropertyChanged iface property [i, body, _] =
-  let i' = (fromVariant i :: Maybe T.Text)
-      b = toMap body
-   in case (i', b) of
-        (Just i'', Just b') ->
-          if i'' == T.pack (formatInterfaceName iface)
-            then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
+matchPropertyChanged iface property [sigIface, sigValues, _] =
+  let i = fromVariant sigIface :: Maybe T.Text
+      v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
+   in case (i, v) of
+        (Just i', Just v') ->
+          if i' == interfaceNameT iface
+            then
+              maybe NoMatch Match $
+                fromVariant =<< M.lookup (memberNameT property) v'
             else NoMatch
         _ -> Failure
-  where
-    toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
 matchPropertyChanged _ _ _ = Failure
 
 --------------------------------------------------------------------------------
 -- Object Manager
 
-type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
+type ObjectTree = M.Map ObjectPath (M.Map InterfaceName (M.Map T.Text Variant))
 
 omInterface :: InterfaceName
 omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
@@ -246,43 +458,132 @@ omInterfacesRemoved :: MemberName
 omInterfacesRemoved = memberName_ "InterfacesRemoved"
 
 callGetManagedObjects
-  :: (MonadUnliftIO m, SafeClient c)
-  => c
-  -> BusName
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
+  => BusName
   -> ObjectPath
   -> m ObjectTree
-callGetManagedObjects cl bus path =
-  either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
-    <$> callMethod cl bus path omInterface getManagedObjects
+callGetManagedObjects bus path = do
+  res <- callMethod bus path omInterface getManagedObjects
+  case res of
+    Left err -> do
+      logError $ Utf8Builder $ encodeUtf8Builder err
+      return M.empty
+    Right v ->
+      return $
+        fmap (M.mapKeys interfaceName_) $
+          fromMaybe M.empty $
+            fromSingletonVariant v
 
 addInterfaceChangedListener
-  :: (MonadUnliftIO m, SafeClient c)
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
   => BusName
   -> MemberName
   -> ObjectPath
   -> SignalCallback m
-  -> c
   -> m (Maybe SignalHandler)
-addInterfaceChangedListener bus prop path sc cl = do
-  rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
-  forM rule $ \r -> addMatchCallback r sc cl
+addInterfaceChangedListener bus prop path sc = do
+  res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop)
+  case res of
+    Nothing -> do
+      logError $
+        "could not add listener for property"
+          <> prop_
+          <> " at path "
+          <> path_
+          <> " on bus "
+          <> bus_
+      return Nothing
+    Just rule -> Just <$> addMatchCallback rule sc
+  where
+    bus_ = "'" <> displayBusName bus <> "'"
+    path_ = "'" <> displayObjectPath path <> "'"
+    prop_ = "'" <> displayMemberName prop <> "'"
 
 addInterfaceAddedListener
-  :: (MonadUnliftIO m, SafeClient c)
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
   => BusName
   -> ObjectPath
   -> SignalCallback m
-  -> c
   -> m (Maybe SignalHandler)
 addInterfaceAddedListener bus =
   addInterfaceChangedListener bus omInterfacesAdded
 
 addInterfaceRemovedListener
-  :: (MonadUnliftIO m, SafeClient c)
+  :: ( MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     , SafeClient c
+     , HasClient env
+     )
   => BusName
   -> ObjectPath
   -> SignalCallback m
-  -> c
   -> m (Maybe SignalHandler)
 addInterfaceRemovedListener bus =
   addInterfaceChangedListener bus omInterfacesRemoved
+
+--------------------------------------------------------------------------------
+-- Interface export/unexport
+
+exportPair
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => ObjectPath
+  -> (Client -> m Interface)
+  -> NamedConnection c
+  -> (m (), m ())
+exportPair path toIface cl = (up, down)
+  where
+    cl_ = ncClient cl
+    up = do
+      logInfo $ "adding interface: " <> path_
+      i <- toIface cl_
+      liftIO $ export cl_ path i
+    down = do
+      logInfo $ "removing interface: " <> path_
+      liftIO $ unexport cl_ path
+    path_ = displayObjectPath path
+
+--------------------------------------------------------------------------------
+-- logging helpers
+
+busNameT :: BusName -> T.Text
+busNameT = T.pack . formatBusName
+
+objectPathT :: ObjectPath -> T.Text
+objectPathT = T.pack . formatObjectPath
+
+interfaceNameT :: InterfaceName -> T.Text
+interfaceNameT = T.pack . formatInterfaceName
+
+memberNameT :: MemberName -> T.Text
+memberNameT = T.pack . formatMemberName
+
+displayBusName :: BusName -> Utf8Builder
+displayBusName = displayBytesUtf8 . BC.pack . formatBusName
+
+displayObjectPath :: ObjectPath -> Utf8Builder
+displayObjectPath = displayBytesUtf8 . BC.pack . formatObjectPath
+
+displayMemberName :: MemberName -> Utf8Builder
+displayMemberName = displayBytesUtf8 . BC.pack . formatMemberName
+
+displayInterfaceName :: InterfaceName -> Utf8Builder
+displayInterfaceName = displayBytesUtf8 . BC.pack . formatInterfaceName
+
+displayWrapQuote :: Utf8Builder -> Utf8Builder
+displayWrapQuote x = "'" <> x <> "'"

lib/Data/Internal/XIO.hs

@@ -1,14 +1,7 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 --------------------------------------------------------------------------------
 -- Functions for handling dependencies
 
-module Data.Internal.Dependency
+module Data.Internal.XIO
 -- feature types
   ( Feature
   , Always (..)
@@ -26,6 +19,7 @@ module Data.Internal.Dependency
   , SubfeatureRoot
   , Msg (..)
   -- configuration
+  , XEnv (..)
   , XParams (..)
   , XPFeatures (..)
   , XPQuery
@@ -53,8 +47,9 @@ module Data.Internal.Dependency
   , dumpSometimes
   , showFulfillment
   -- testing
-  , FIO
-  , withCache
+  , XIO
+  , runXIO
+  , hRunXIO
   , evalFeature
   , executeSometimes
   , executeAlways
@@ -96,6 +91,7 @@ module Data.Internal.Dependency
   , process
   -- misc
   , shellTest
+  , withLogFile
   )
 where
 
@@ -104,6 +100,7 @@ import qualified DBus.Introspection as I
 import Data.Aeson hiding (Error, Result)
 import Data.Aeson.Key
 import Data.Internal.DBus
+import qualified Data.Text.IO as TI
 import Data.Yaml
 import GHC.IO.Exception (ioe_description)
 import RIO hiding (bracket, fromString)
@@ -115,7 +112,7 @@ import qualified RIO.Text as T
 import System.Posix.Files
 import System.Process.Typed (nullStream)
 import UnliftIO.Environment
-import XMonad.Core (X, io)
+import XMonad.Core (X, dataDir, getDirectories, io)
 import XMonad.Internal.IO
 import XMonad.Internal.Shell hiding (proc, runProcess)
 import XMonad.Internal.Theme
@@ -128,30 +125,47 @@ import XMonad.Internal.Theme
 
 -- | Run feature evaluation(s) with the cache
 -- Currently there is no easy way to not use this (oh well)
-withCache :: FIO a -> IO a
-withCache x = do
-  logOpts <- logOptionsHandle stderr False
+runXIO :: FilePath -> XIO a -> IO a
+runXIO logfile x = withLogFile logfile $ \h -> hRunXIO True h x
+
+-- TODO use dhall to encode config file and log here to control the loglevel
+withLogFile :: MonadUnliftIO m => FilePath -> (Handle -> m a) -> m a
+withLogFile logfile f = do
+  p <- (</> logfile) . dataDir <$> liftIO getDirectories
+  catchIO (withBinaryFile p AppendMode f) $ \e -> do
+    liftIO $ TI.putStrLn $ T.pack $ show e
+    liftIO $ TI.putStrLn "could not open log file, falling back to stderr"
+    f stderr
+
+hRunXIO :: Bool -> Handle -> XIO a -> IO a
+hRunXIO verbose h x = do
+  hSetBuffering h LineBuffering
+  logOpts <- logOptionsHandle_ verbose h
   pc <- mkDefaultProcessContext
   withLogFunc logOpts $ \f -> do
     p <- getParams
-    let s = DepStage f pc p
+    let s = XEnv f pc p
     runRIO s x
 
+logOptionsHandle_ :: MonadUnliftIO m => Bool -> Handle -> m LogOptions
+logOptionsHandle_ v h =
+  setLogVerboseFormat v . setLogUseTime v <$> logOptionsHandle h False
+
 -- | Execute an Always immediately
-executeAlways :: Always (IO a) -> FIO a
+executeAlways :: Always (IO a) -> XIO a
 executeAlways = io <=< evalAlways
 
 -- | Execute a Sometimes immediately (or do nothing if failure)
-executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a)
+executeSometimes :: Sometimes (XIO a) -> XIO (Maybe a)
 executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
 
 -- | Possibly return the action of an Always/Sometimes
-evalFeature :: Feature a -> FIO (Maybe a)
+evalFeature :: Feature a -> XIO (Maybe a)
 evalFeature (Right a) = Just <$> evalAlways a
 evalFeature (Left s) = evalSometimes s
 
 -- | Possibly return the action of a Sometimes
-evalSometimes :: Sometimes a -> FIO (Maybe a)
+evalSometimes :: Sometimes a -> XIO (Maybe a)
 evalSometimes x = either goFail goPass =<< evalSometimesMsg x
   where
     goPass (a, ws) = putErrors ws >> return (Just a)
@@ -159,13 +173,13 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
     putErrors = mapM_ logMsg
 
 -- | Return the action of an Always
-evalAlways :: Always a -> FIO a
+evalAlways :: Always a -> XIO a
 evalAlways a = do
   (x, ws) <- evalAlwaysMsg a
   mapM_ logMsg ws
   return x
 
-logMsg :: FMsg -> FIO ()
+logMsg :: FMsg -> XIO ()
 logMsg (FMsg fn n (Msg ll m)) = do
   p <- io getProgName
   f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
@@ -186,8 +200,9 @@ logMsg (FMsg fn n (Msg ll m)) = do
 --------------------------------------------------------------------------------
 -- Package status
 
-showFulfillment :: Fulfillment -> T.Text
-showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
+showFulfillment :: Fulfillment -> Utf8Builder
+showFulfillment (Package t n) =
+  displayShow t <> "\t" <> Utf8Builder (encodeUtf8Builder n)
 
 dumpFeature :: Feature a -> [Fulfillment]
 dumpFeature = either dumpSometimes dumpAlways
@@ -209,7 +224,7 @@ type AlwaysIO = Always (IO ())
 
 type SometimesX = Sometimes (X ())
 
-type SometimesIO = Sometimes (FIO ())
+type SometimesIO = Sometimes (XIO ())
 
 type Feature a = Either (Sometimes a) (Always a)
 
@@ -219,12 +234,13 @@ type Feature a = Either (Sometimes a) (Always a)
 -- | Feature that is guaranteed to work
 -- This is composed of sub-features that are tested in order, and if all fail
 -- the fallback is a monadic action (eg a plain haskell function)
-data Always a = Always T.Text (Always_ a)
+data Always a = Always T.Text (Always_ a) deriving (Functor)
 
 -- | Feature that is guaranteed to work (inner data)
 data Always_ a
   = Option (SubfeatureRoot a) (Always_ a)
   | Always_ (FallbackRoot a)
+  deriving (Functor)
 
 -- | Root of a fallback action for an always
 -- This may either be a lone action or a function that depends on the results
@@ -233,15 +249,23 @@ data FallbackRoot a
   = FallbackAlone a
   | forall p. FallbackTree (p -> a) (FallbackStack p)
 
+instance Functor FallbackRoot where
+  fmap f (FallbackAlone a) = FallbackAlone (f a)
+  fmap f (FallbackTree g s) = FallbackTree (f . g) s
+
 -- | Always features that are used as a payload for a fallback action
 data FallbackStack p
   = FallbackBottom (Always p)
   | forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
 
+instance Functor FallbackStack where
+  fmap f (FallbackBottom a) = FallbackBottom $ fmap f a
+  fmap f (FallbackStack g a s) = FallbackStack (\x -> f . g x) a s
+
 -- | Feature that might not be present
 -- This is like an Always except it doesn't fall back on a guaranteed monadic
 -- action
-data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a)
+data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) deriving (Functor)
 
 -- | Feature that might not be present (inner data)
 type Sometimes_ a = [SubfeatureRoot a]
@@ -254,6 +278,7 @@ data Subfeature f = Subfeature
   { sfData :: f
   , sfName :: T.Text
   }
+  deriving (Functor)
 
 type SubfeatureRoot a = Subfeature (Root a)
 
@@ -263,8 +288,24 @@ type SubfeatureRoot a = Subfeature (Root a)
 data Root a
   = forall p. IORoot (p -> a) (IOTree p)
   | IORoot_ a IOTree_
-  | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
-  | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
+  | forall c p.
+    SafeClient c =>
+    DBusRoot
+      (p -> NamedConnection c -> a)
+      (DBusTree c p)
+      (Maybe (NamedConnection c))
+  | forall c.
+    SafeClient c =>
+    DBusRoot_
+      (NamedConnection c -> a)
+      (DBusTree_ c)
+      (Maybe (NamedConnection c))
+
+instance Functor Root where
+  fmap f (IORoot a t) = IORoot (f . a) t
+  fmap f (IORoot_ a t) = IORoot_ (f a) t
+  fmap f (DBusRoot a t cl) = DBusRoot (\p c -> f $ a p c) t cl
+  fmap f (DBusRoot_ a t cl) = DBusRoot_ (f . a) t cl
 
 -- | The dependency tree with rule to merge results when needed
 data Tree d d_ p
@@ -289,7 +330,7 @@ type DBusTree_ c = Tree_ (DBusDependency_ c)
 -- | A dependency that only requires IO to evaluate (with payload)
 data IODependency p
   = -- an IO action that yields a payload
-    IORead T.Text [Fulfillment] (FIO (Result p))
+    IORead T.Text [Fulfillment] (XIO (Result p))
   | -- always yields a payload
     IOConst p
   | -- an always that yields a payload
@@ -302,12 +343,11 @@ data DBusDependency_ c
   = Bus [Fulfillment] BusName
   | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
   | DBusIO IODependency_
-  deriving (Generic)
 
 -- | A dependency that only requires IO to evaluate (no payload)
 data IODependency_
   = IOSystem_ [Fulfillment] SystemDependency
-  | IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
+  | IOTest_ T.Text [Fulfillment] (XIO (Maybe Msg))
   | forall a. IOSometimes_ (Sometimes a)
 
 -- | A system component to an IODependency
@@ -317,23 +357,23 @@ data SystemDependency
   | AccessiblePath FilePath Bool Bool
   | Systemd UnitType T.Text
   | Process T.Text
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 -- | The type of a systemd service
-data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
+data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
 
 -- | Wrapper type to describe and endpoint
 data DBusMember
   = Method_ MemberName
   | Signal_ MemberName
   | Property_ T.Text
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show)
 
 -- | A means to fulfill a dependency
 -- For now this is just the name of an Arch Linux package (AUR or official)
 data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)
 
-data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
+data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Ord)
 
 --------------------------------------------------------------------------------
 -- Tested dependency tree
@@ -376,19 +416,25 @@ data PostFail = PostFail [Msg] | PostMissing Msg
 --------------------------------------------------------------------------------
 -- Configuration
 
-type FIO a = RIO DepStage a
+type XIO a = RIO XEnv a
 
-data DepStage = DepStage
-  { dsLogFun :: !LogFunc
-  , dsProcCxt :: !ProcessContext
-  , dsParams :: !XParams
+data XEnv = XEnv
+  { xLogFun :: !LogFunc
+  , xProcCxt :: !ProcessContext
+  , xParams :: !XParams
   }
 
-instance HasLogFunc DepStage where
-  logFuncL = lens dsLogFun (\x y -> x {dsLogFun = y})
+instance HasLogFunc XEnv where
+  logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
 
-instance HasProcessContext DepStage where
-  processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y})
+instance HasLogFunc (DBusEnv XEnv c) where
+  logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
+
+instance HasProcessContext XEnv where
+  processContextL = lens xProcCxt (\x y -> x {xProcCxt = y})
+
+instance HasClient (DBusEnv XEnv) where
+  clientL = lens dClient (\x y -> x {dClient = y})
 
 data XParams = XParams
   { xpLogLevel :: LogLevel
@@ -422,7 +468,8 @@ data XPFeatures = XPFeatures
   , xpfIntelBacklight :: Bool
   , xpfClevoBacklight :: Bool
   , xpfBattery :: Bool
-  , xpfF5VPN :: Bool
+  , xpfEthPrefix :: Maybe Text
+  , xpfWifiPrefix :: Maybe Text
   }
 
 instance FromJSON XPFeatures where
@@ -449,7 +496,9 @@ instance FromJSON XPFeatures where
       <*> o
       .:+ "battery"
       <*> o
-      .:+ "f5vpn"
+      .:? "ethPrefix"
+      <*> o
+      .:? "wifiPrefix"
 
 defParams :: XParams
 defParams =
@@ -472,7 +521,8 @@ defXPFeatures =
     , xpfIntelBacklight = False
     , xpfClevoBacklight = False
     , xpfBattery = False
-    , xpfF5VPN = False
+    , xpfEthPrefix = Nothing
+    , xpfWifiPrefix = Nothing
     }
 
 type XPQuery = XPFeatures -> Bool
@@ -483,7 +533,7 @@ getParams = do
   maybe (return defParams) (liftIO . decodeYaml) p
   where
     decodeYaml p =
-      either (\e -> print e >> return defParams) return
+      either (\e -> TI.putStrLn (T.pack $ show e) >> return defParams) return
         =<< decodeFileEither p
 
 getParamFile :: MonadIO m => m (Maybe FilePath)
@@ -507,9 +557,9 @@ infix 9 .:+
 --------------------------------------------------------------------------------
 -- Testing pipeline
 
-evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
+evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg]))
 evalSometimesMsg (Sometimes n u xs) = do
-  r <- asks (u . xpFeatures . dsParams)
+  r <- asks (u . xpFeatures . xParams)
   if not r
     then return $ Left [dis n]
     else do
@@ -521,7 +571,7 @@ evalSometimesMsg (Sometimes n u xs) = do
   where
     dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
 
-evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
+evalAlwaysMsg :: Always a -> XIO (a, [FMsg])
 evalAlwaysMsg (Always n x) = do
   r <- testAlways x
   return $ case r of
@@ -541,7 +591,7 @@ failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
   where
     f = fmap (FMsg fn (Just n))
 
-testAlways :: Always_ a -> FIO (PostAlways a)
+testAlways :: Always_ a -> XIO (PostAlways a)
 testAlways = go []
   where
     go failed (Option fd next) = do
@@ -551,18 +601,18 @@ testAlways = go []
         (Right pass) -> return $ Primary pass failed next
     go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
 
-evalFallbackRoot :: FallbackRoot a -> FIO a
+evalFallbackRoot :: FallbackRoot a -> XIO a
 evalFallbackRoot (FallbackAlone a) = return a
 evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
 
-evalFallbackStack :: FallbackStack p -> FIO p
+evalFallbackStack :: FallbackStack p -> XIO p
 evalFallbackStack (FallbackBottom a) = evalAlways a
 evalFallbackStack (FallbackStack f a as) = do
   ps <- evalFallbackStack as
   p <- evalAlways a
   return $ f p ps
 
-testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
+testSometimes :: Sometimes_ a -> XIO (PostSometimes a)
 testSometimes = go (PostSometimes Nothing [])
   where
     go ts [] = return ts
@@ -572,13 +622,13 @@ testSometimes = go (PostSometimes Nothing [])
         (Left l) -> go (ts {psFailed = l : psFailed ts}) xs
         (Right pass) -> return $ ts {psSuccess = Just pass}
 
-testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a))
+testSubfeature :: SubfeatureRoot a -> XIO (Either SubfeatureFail (SubfeaturePass a))
 testSubfeature sf@Subfeature {sfData = t} = do
   t' <- testRoot t
   -- monomorphism restriction :(
   return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'
 
-testRoot :: Root a -> FIO (Either PostFail (PostPass a))
+testRoot :: Root a -> XIO (Either PostFail (PostPass a))
 testRoot r = do
   case r of
     (IORoot a t) -> go a testIODep_ testIODep t
@@ -592,7 +642,7 @@ testRoot r = do
             Msg LevelError "client not available"
   where
     -- rank N polymorphism is apparently undecidable...gross
-    go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
+    go a f_ (f :: forall q. d q -> XIO (MResult q)) t =
       bimap PostFail (fmap a) <$> testTree f_ f t
     go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
 
@@ -605,13 +655,13 @@ type MResult p = Memoized (Result p)
 
 testTree
   :: forall d d_ p
-   . (d_ -> FIO MResult_)
-  -> (forall q. d q -> FIO (MResult q))
+   . (d_ -> XIO MResult_)
+  -> (forall q. d q -> XIO (MResult q))
   -> Tree d d_ p
-  -> FIO (Either [Msg] (PostPass p))
+  -> XIO (Either [Msg] (PostPass p))
 testTree test_ test = go
   where
-    go :: forall q. Tree d d_ q -> FIO (Result q)
+    go :: forall q. Tree d d_ q -> XIO (Result q)
     go (And12 f a b) = do
       ra <- go a
       liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
@@ -628,7 +678,7 @@ testTree test_ test = go
     and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
     liftRight = either (return . Left)
 
-testIODep :: IODependency p -> FIO (MResult p)
+testIODep :: IODependency p -> XIO (MResult p)
 testIODep d = memoizeMVar $ case d of
   IORead _ _ t -> t
   IOConst c -> return $ Right $ PostPass c []
@@ -656,7 +706,7 @@ type Result_ = Either [Msg] [Msg]
 
 type MResult_ = Memoized Result_
 
-testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_
+testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_
 testTree_ test = go
   where
     go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@@ -664,10 +714,10 @@ testTree_ test = go
     go (Only_ a) = runMemoized =<< test a
     test2nd ws = fmap ((Right . (ws ++)) =<<) . go
 
-testIODep_ :: IODependency_ -> FIO MResult_
+testIODep_ :: IODependency_ -> XIO MResult_
 testIODep_ d = memoizeMVar $ testIODepNoCache_ d
 
-testIODepNoCache_ :: IODependency_ -> FIO Result_
+testIODepNoCache_ :: IODependency_ -> XIO Result_
 testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
 testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
 testIODepNoCache_ (IOSometimes_ x) =
@@ -762,7 +812,7 @@ fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont
 fontTestName :: T.Text -> T.Text
 fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
 
--- testFont :: T.Text -> FIO (Result FontBuilder)
+-- testFont :: T.Text -> XIO (Result FontBuilder)
 -- testFont = liftIO . testFont'
 
 testFont
@@ -783,16 +833,16 @@ testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg
 -- start with "en" and wireless interfaces always start with "wl"
 
 readEthernet :: IODependency T.Text
-readEthernet = readInterface "get ethernet interface" isEthernet
+readEthernet = readInterface "get ethernet interface" (fromMaybe "en" . xpfEthPrefix)
 
 readWireless :: IODependency T.Text
-readWireless = readInterface "get wireless interface" isWireless
+readWireless = readInterface "get wireless interface" (fromMaybe "wl" . xpfWifiPrefix)
 
-isWireless :: T.Text -> Bool
-isWireless = T.isPrefixOf "wl"
+-- isWireless :: T.Text -> Bool
+-- isWireless = T.isPrefixOf "wl"
 
-isEthernet :: T.Text -> Bool
-isEthernet = T.isPrefixOf "en"
+-- isEthernet :: T.Text -> Bool
+-- isEthernet = T.isPrefixOf "en"
 
 listInterfaces :: MonadUnliftIO m => m [T.Text]
 listInterfaces =
@@ -804,11 +854,12 @@ sysfsNet = "/sys/class/net"
 
 -- ASSUME there are no (non-base) packages required to make these interfaces
 -- work (all at the kernel level)
-readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text
+readInterface :: T.Text -> (XPFeatures -> Text) -> IODependency T.Text
 readInterface n f = IORead n [] go
   where
-    go = io $ do
-      ns <- filter f <$> listInterfaces
+    go = do
+      p <- asks (f . xpFeatures . xParams)
+      ns <- filter (T.isPrefixOf p) <$> listInterfaces
       case ns of
         [] -> return $ Left [Msg LevelError "no interfaces found"]
         (x : xs) -> do
@@ -820,7 +871,7 @@ readInterface n f = IORead n [] go
 --------------------------------------------------------------------------------
 -- Misc testers
 
-socketExists :: T.Text -> [Fulfillment] -> FIO FilePath -> IODependency_
+socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_
 socketExists n ful =
   IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'
 
@@ -844,12 +895,12 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
-testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_
+testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
 testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
 
-testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
-testDBusDepNoCache_ cl (Bus _ bus) = io $ do
-  ret <- callMethod cl queryBus queryPath queryIface queryMem
+testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
+testDBusDepNoCache_ cl (Bus _ bus) = do
+  ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
   return $ case ret of
     Left e -> Left [Msg LevelError e]
     Right b ->
@@ -868,8 +919,10 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
     queryMem = memberName_ "ListNames"
     bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
     bodyGetNames _ = []
-testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
-  ret <- callMethod cl busname objpath introspectInterface introspectMethod
+testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = do
+  ret <-
+    withDIO cl $
+      callMethod busname objpath introspectInterface introspectMethod
   return $ case ret of
     Left e -> Left [Msg LevelError e]
     Right body -> procBody body
@@ -925,12 +978,6 @@ testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
 -- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
 -- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}
 
--- ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
--- ioRoot (IORoot a t) = IORoot (io . a) t
--- ioRoot (IORoot_ a t) = IORoot_ (io a) t
--- ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
--- ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
-
 --------------------------------------------------------------------------------
 -- Feature constructors
 
@@ -982,16 +1029,17 @@ sometimesExeArgs fn n ful sys path args =
 
 sometimesDBus
   :: SafeClient c
-  => Maybe c
+  => Maybe (NamedConnection c)
   -> T.Text
   -> T.Text
   -> Tree_ (DBusDependency_ c)
-  -> (c -> a)
+  -> (NamedConnection c -> a)
   -> Sometimes a
 sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
 
+-- TODO do I need to hardcode XEnv?
 sometimesEndpoint
-  :: (SafeClient c, MonadIO m)
+  :: (HasClient (DBusEnv env), SafeClient c, MonadReader env m, MonadUnliftIO m)
   => T.Text
   -> T.Text
   -> [Fulfillment]
@@ -999,13 +1047,13 @@ sometimesEndpoint
   -> ObjectPath
   -> InterfaceName
   -> MemberName
-  -> Maybe c
+  -> Maybe (NamedConnection c)
   -> Sometimes (m ())
 sometimesEndpoint fn name ful busname path iface mem cl =
   sometimesDBus cl fn name deps cmd
   where
     deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
-    cmd c = io $ void $ callMethod c busname path iface mem
+    cmd c = void $ withDIO c $ callMethod busname path iface mem
 
 --------------------------------------------------------------------------------
 -- Dependency Tree Constructors

lib/XMonad/Internal/Command/DMenu.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Dmenu (Rofi) Commands
 
@@ -19,15 +17,18 @@ module XMonad.Internal.Command.DMenu
 where
 
 import DBus
+import qualified Data.ByteString.Char8 as BC
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import Graphics.X11.Types
+import RIO
+import qualified RIO.ByteString as B
 import RIO.Directory
   ( XdgDirectory (..)
   , getXdgDirectory
   )
 import qualified RIO.Text as T
-import System.IO
+-- import System.IO
 import XMonad.Core hiding (spawn)
 import XMonad.Internal.Command.Desktop
 import XMonad.Internal.DBus.Common
@@ -74,7 +75,7 @@ clipboardPkgs = [Package AUR "rofi-greenclip"]
 --------------------------------------------------------------------------------
 -- Other internal functions
 
-spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
+spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
 spawnDmenuCmd n =
   sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
 
@@ -97,7 +98,7 @@ dmenuDep = sysExe dmenuPkgs myDmenuCmd
 -- Exported Commands
 
 -- TODO test that veracrypt and friends are installed
-runDevMenu :: SometimesX
+runDevMenu :: MonadUnliftIO m => Sometimes (m ())
 runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
   where
     t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
@@ -110,7 +111,7 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
           ++ myDmenuMatchingArgs
 
 -- TODO test that bluetooth interface exists
-runBTMenu :: SometimesX
+runBTMenu :: MonadUnliftIO m => Sometimes (m ())
 runBTMenu =
   Sometimes
     "bluetooth selector"
@@ -120,7 +121,7 @@ runBTMenu =
     cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
     tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
 
-runVPNMenu :: SometimesX
+runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
 runVPNMenu =
   Sometimes
     "VPN selector"
@@ -136,16 +137,16 @@ runVPNMenu =
           socketExists "expressVPN" [] $
             return "/var/lib/expressvpn/expressvpnd.socket"
 
-runCmdMenu :: SometimesX
+runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
 runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
 
-runAppMenu :: SometimesX
+runAppMenu :: MonadUnliftIO m => Sometimes (m ())
 runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 
-runWinMenu :: SometimesX
+runWinMenu :: MonadUnliftIO m => Sometimes (m ())
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
-runNetMenu :: Maybe SysClient -> SometimesX
+runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
 runNetMenu cl =
   Sometimes
     "network control menu"
@@ -161,7 +162,7 @@ runNetMenu cl =
           DBusIO $
             sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
 
-runAutorandrMenu :: SometimesX
+runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
 runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
   where
     cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
@@ -170,7 +171,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
 --------------------------------------------------------------------------------
 -- Password manager
 
-runBwMenu :: Maybe SesClient -> SometimesX
+runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
   where
     cmd _ =
@@ -183,7 +184,7 @@ runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
 --------------------------------------------------------------------------------
 -- Clipboard
 
-runClipMenu :: SometimesX
+runClipMenu :: MonadUnliftIO m => Sometimes (m ())
 runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
   where
     act = spawnCmd myDmenuCmd args
@@ -206,7 +207,9 @@ runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
 --------------------------------------------------------------------------------
 -- Shortcut menu
 
-runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
+runShowKeys
+  :: (MonadReader env m, MonadUnliftIO m)
+  => Always ([((KeyMask, KeySym), NamedAction)] -> m ())
 runShowKeys =
   Always "keyboard menu" $
     Option showKeysDMenu $
@@ -219,18 +222,23 @@ runShowKeys =
         spawnNotify $
           defNoteError {body = Just $ Text "could not display keymap"}
 
-showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
+showKeysDMenu
+  :: (MonadReader env m, MonadUnliftIO m)
+  => SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
 showKeysDMenu =
   Subfeature
     { sfName = "keyboard shortcut menu"
     , sfData = IORoot_ showKeys $ Only_ dmenuDep
     }
 
-showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
+showKeys
+  :: (MonadReader env m, MonadUnliftIO m)
+  => [((KeyMask, KeySym), NamedAction)]
+  -> m ()
 showKeys kbs = do
   h <- spawnPipe cmd
-  io $ hPutStr h $ unlines $ showKm kbs
-  io $ hClose h
+  B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
+  hClose h
   where
     cmd =
       fmtCmd myDmenuCmd $

lib/XMonad/Internal/Command/Desktop.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- General commands
 
@@ -21,7 +19,8 @@ module XMonad.Internal.Command.Desktop
   , runVolumeUp
   , runVolumeMute
   , runToggleBluetooth
-  , runToggleEthernet
+  , runToggleNetworking
+  , runToggleWifi
   , runRestart
   , runRecompile
   , runAreaCapture
@@ -41,7 +40,7 @@ where
 
 import DBus
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import RIO
 import RIO.Directory
 import RIO.FilePath
@@ -60,13 +59,13 @@ import XMonad.Operations
 -- My Executables
 
 myTerm :: FilePath
-myTerm = "urxvt"
+myTerm = "alacritty"
 
 myCalc :: FilePath
 myCalc = "bc"
 
 myBrowser :: FilePath
-myBrowser = "brave"
+myBrowser = "firefox"
 
 myEditor :: FilePath
 myEditor = "emacsclient"
@@ -94,8 +93,7 @@ myNotificationCtrl = "dunstctl"
 
 myTermPkgs :: [Fulfillment]
 myTermPkgs =
-  [ Package Official "rxvt-unicode"
-  , Package Official "urxvt-perls"
+  [ Package Official "alacritty"
   ]
 
 myEditorPkgs :: [Fulfillment]
@@ -110,6 +108,9 @@ bluetoothPkgs = [Package Official "bluez-utils"]
 networkManagerPkgs :: [Fulfillment]
 networkManagerPkgs = [Package Official "networkmanager"]
 
+nmcli :: IODependency_
+nmcli = sysExe networkManagerPkgs "nmcli"
+
 --------------------------------------------------------------------------------
 -- Misc constants
 
@@ -119,10 +120,10 @@ volumeChangeSound = "smb_fireball.wav"
 --------------------------------------------------------------------------------
 -- Some nice apps
 
-runTerm :: SometimesX
-runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
+runTerm :: MonadUnliftIO m => Sometimes (m ())
+runTerm = sometimesExe "terminal" "alacritty" myTermPkgs True myTerm
 
-runTMux :: SometimesX
+runTMux :: MonadUnliftIO m => Sometimes (m ())
 runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
   where
     deps =
@@ -140,13 +141,13 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
       t <- getTemporaryDirectory
       return $ t </> "tmux-" ++ show u </> "default"
 
-runCalc :: SometimesX
+runCalc :: MonadUnliftIO m => Sometimes (m ())
 runCalc = sometimesIO_ "calculator" "bc" deps act
   where
     deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
     act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
 
-runBrowser :: SometimesX
+runBrowser :: MonadUnliftIO m => Sometimes (m ())
 runBrowser =
   sometimesExe
     "web browser"
@@ -155,7 +156,7 @@ runBrowser =
     False
     myBrowser
 
-runEditor :: SometimesX
+runEditor :: MonadUnliftIO m => Sometimes (m ())
 runEditor = sometimesIO_ "text editor" "emacs" tree cmd
   where
     cmd =
@@ -166,7 +167,7 @@ runEditor = sometimesIO_ "text editor" "emacs" tree cmd
     -- before xmonad starts, so just check to see if the process has started
     tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
 
-runFileManager :: SometimesX
+runFileManager :: MonadUnliftIO m => Sometimes (m ())
 runFileManager =
   sometimesExe
     "file browser"
@@ -178,7 +179,11 @@ runFileManager =
 --------------------------------------------------------------------------------
 -- Multimedia Commands
 
-runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
+runMultimediaIfInstalled
+  :: MonadUnliftIO m
+  => T.Text
+  -> T.Text
+  -> Sometimes (m ())
 runMultimediaIfInstalled n cmd =
   sometimesExeArgs
     (T.append n " multimedia control")
@@ -188,23 +193,23 @@ runMultimediaIfInstalled n cmd =
     myMultimediaCtl
     [cmd]
 
-runTogglePlay :: SometimesX
+runTogglePlay :: MonadUnliftIO m => Sometimes (m ())
 runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
 
-runPrevTrack :: SometimesX
+runPrevTrack :: MonadUnliftIO m => Sometimes (m ())
 runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
 
-runNextTrack :: SometimesX
+runNextTrack :: MonadUnliftIO m => Sometimes (m ())
 runNextTrack = runMultimediaIfInstalled "next track" "next"
 
-runStopPlay :: SometimesX
+runStopPlay :: MonadUnliftIO m => Sometimes (m ())
 runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
 
 --------------------------------------------------------------------------------
 -- Volume Commands
 
 soundDir :: FilePath
-soundDir = "sound"
+soundDir = "assets" </> "sound"
 
 playSound :: MonadIO m => FilePath -> m ()
 playSound file = do
@@ -213,7 +218,13 @@ playSound file = do
   -- paplay seems to have less latency than aplay
   spawnCmd "paplay" [T.pack p]
 
-featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
+featureSound
+  :: MonadUnliftIO m
+  => T.Text
+  -> FilePath
+  -> m ()
+  -> m ()
+  -> Sometimes (m ())
 featureSound n file pre post =
   sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
     pre >> playSound file >> post
@@ -222,19 +233,24 @@ featureSound n file pre post =
     -- to play sound (duh) but libpulse is the package with the paplay binary
     tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay"
 
-runVolumeDown :: SometimesX
+runVolumeDown :: MonadUnliftIO m => Sometimes (m ())
 runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
 
-runVolumeUp :: SometimesX
+runVolumeUp :: MonadUnliftIO m => Sometimes (m ())
 runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
 
-runVolumeMute :: SometimesX
+runVolumeMute :: MonadUnliftIO m => Sometimes (m ())
 runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
 
 --------------------------------------------------------------------------------
 -- Notification control
 
-runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
+runNotificationCmd
+  :: MonadUnliftIO m
+  => T.Text
+  -> T.Text
+  -> Maybe NamedSesConnection
+  -> Sometimes (m ())
 runNotificationCmd n arg cl =
   sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
   where
@@ -245,37 +261,37 @@ runNotificationCmd n arg cl =
           Method_ $
             memberName_ "NotificationAction"
 
-runNotificationClose :: Maybe SesClient -> SometimesX
+runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationClose = runNotificationCmd "close notification" "close"
 
-runNotificationCloseAll :: Maybe SesClient -> SometimesX
+runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationCloseAll =
   runNotificationCmd "close all notifications" "close-all"
 
-runNotificationHistory :: Maybe SesClient -> SometimesX
+runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationHistory =
   runNotificationCmd "see notification history" "history-pop"
 
-runNotificationContext :: Maybe SesClient -> SometimesX
+runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationContext =
   runNotificationCmd "open notification context" "context"
 
 --------------------------------------------------------------------------------
 -- System commands
 
--- this is required for some vpn's to work properly with network-manager
-runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
+-- needed to lookup/prompt for passwords/keys for wifi connections and some VPNs
+runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
 runNetAppDaemon cl =
   Sometimes
     "network applet"
-    xpfVPN
+    (\x -> xpfVPN x || xpfWireless x)
     [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
   where
     tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
     app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
     cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
 
-runToggleBluetooth :: Maybe SysClient -> SometimesX
+runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
 runToggleBluetooth cl =
   Sometimes
     "bluetooth toggle"
@@ -292,27 +308,35 @@ runToggleBluetooth cl =
           #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
           #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
 
-runToggleEthernet :: SometimesX
-runToggleEthernet =
+runToggleNetworking :: MonadUnliftIO m => Sometimes (m ())
+runToggleNetworking =
   Sometimes
-    "ethernet toggle"
-    xpfEthernet
+    "network toggle"
+    (\x -> xpfEthernet x || xpfWireless x)
     [Subfeature root "nmcli"]
   where
-    root =
-      IORoot cmd $
-        And1 (Only readEthernet) $
-          Only_ $
-            sysExe networkManagerPkgs "nmcli"
-    -- TODO make this less noisy
-    cmd iface =
+    root = IORoot_ cmd $ Only_ nmcli
+    cmd =
       S.spawn $
-        fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
-          #!| "grep -q disconnected"
-          #!&& "a=connect"
-          #!|| "a=disconnect"
-          #!>> fmtCmd "nmcli" ["device", "$a", iface]
-          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
+        fmtCmd "nmcli" ["networking"]
+          #!| "grep -q enabled"
+          #!&& "a=off"
+          #!|| "a=on"
+          #!>> fmtCmd "nmcli" ["networking", "$a"]
+          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "networking switched $a"}
+
+runToggleWifi :: MonadUnliftIO m => Sometimes (m ())
+runToggleWifi = Sometimes "wifi toggle" xpfWireless [Subfeature root "nmcli"]
+  where
+    root = IORoot_ cmd $ Only_ nmcli
+    cmd =
+      S.spawn $
+        fmtCmd "nmcli" ["radio", "wifi"]
+          #!| "grep -q enabled"
+          #!&& "a=off"
+          #!|| "a=on"
+          #!>> fmtCmd "nmcli" ["radio", "wifi", "$a"]
+          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "wifi switched $a"}
 
 --------------------------------------------------------------------------------
 -- Configuration commands
@@ -320,6 +344,7 @@ runToggleEthernet =
 runRestart :: X ()
 runRestart = restart "xmonad" True
 
+-- TODO use rio in here so I don't have to fill my xinit log with stack poop
 -- TODO only recompile the VM binary if we have virtualbox enabled
 runRecompile :: X ()
 runRecompile = do
@@ -348,7 +373,12 @@ getCaptureDir = do
   where
     fallback = (</> ".local/share") <$> getHomeDirectory
 
-runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
+runFlameshot
+  :: MonadUnliftIO m
+  => T.Text
+  -> T.Text
+  -> Maybe NamedSesConnection
+  -> Sometimes (m ())
 runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
   where
     cmd _ = spawnCmd myCapture [mode]
@@ -359,18 +389,18 @@ runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
 
 -- TODO this will steal focus from the current window (and puts it
 -- in the root window?) ...need to fix
-runAreaCapture :: Maybe SesClient -> SometimesX
+runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: Maybe SesClient -> SometimesX
+runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
-runScreenCapture :: Maybe SesClient -> SometimesX
+runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runScreenCapture = runFlameshot "screen capture" "screen"
 
-runCaptureBrowser :: SometimesX
+runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
 runCaptureBrowser = sometimesIO_
   "screen capture browser"
   "feh"

lib/XMonad/Internal/Command/Power.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Commands for controlling power
 
@@ -26,7 +24,7 @@ module XMonad.Internal.Command.Power
   )
 where
 
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import Graphics.X11.Types
 import RIO
 import RIO.Directory
@@ -69,29 +67,30 @@ runScreenLock =
     False
     myScreenlock
 
-runPowerOff :: X ()
+runPowerOff :: MonadUnliftIO m => m ()
 runPowerOff = spawn "systemctl poweroff"
 
-runSuspend :: X ()
+runSuspend :: MonadUnliftIO m => m ()
 runSuspend = spawn "systemctl suspend"
 
-runHibernate :: X ()
+runHibernate :: MonadUnliftIO m => m ()
 runHibernate = spawn "systemctl hibernate"
 
-runReboot :: X ()
+runReboot :: MonadUnliftIO m => m ()
 runReboot = spawn "systemctl reboot"
 
 --------------------------------------------------------------------------------
 -- Autolock
 
-runAutolock :: Sometimes (FIO (P.Process () () ()))
+runAutolock :: Sometimes (XIO (P.Process () () ()))
 runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
   where
     tree =
       And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
         Only_ $
           IOSometimes_ runScreenLock
-    cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
+    cmd = P.proc "xss-lock" args (P.startProcess . P.setCreateGroup True)
+    args = ["--ignore-sleep", "--", "screenlock", "true"]
 
 --------------------------------------------------------------------------------
 -- Confirmation prompts
@@ -106,7 +105,7 @@ confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
 confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
 
 suspendPrompt :: XT.FontBuilder -> X ()
-suspendPrompt = confirmPrompt' "suspend?" runSuspend
+suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
 
 quitPrompt :: XT.FontBuilder -> X ()
 quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
@@ -180,17 +179,20 @@ data PowerMaybeAction
   | Reboot
   deriving (Eq)
 
-instance Enum PowerMaybeAction where
-  toEnum 0 = Poweroff
-  toEnum 1 = Shutdown
-  toEnum 2 = Hibernate
-  toEnum 3 = Reboot
-  toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
+fromPMA :: PowerMaybeAction -> Int
+fromPMA a = case a of
+  Poweroff -> 0
+  Shutdown -> 1
+  Hibernate -> 2
+  Reboot -> 3
 
-  fromEnum Poweroff = 0
-  fromEnum Shutdown = 1
-  fromEnum Hibernate = 2
-  fromEnum Reboot = 3
+toPMA :: Int -> Maybe PowerMaybeAction
+toPMA x = case x of
+  0 -> Just Poweroff
+  1 -> Just Shutdown
+  2 -> Just Hibernate
+  3 -> Just Reboot
+  _ -> Nothing
 
 data PowerPrompt = PowerPrompt
 
@@ -222,9 +224,11 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
             , (xK_Return, quit)
             , (xK_Escape, quit)
             ]
-    sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
-    executeMaybeAction a = case toEnum $ read a of
-      Poweroff -> runPowerOff
-      Shutdown -> lock >> runSuspend
-      Hibernate -> lock >> runHibernate
-      Reboot -> runReboot
+    sendMaybeAction a = setInput (show $ fromPMA a) >> setSuccess True >> setDone True
+    executeMaybeAction a = case toPMA =<< readMaybe a of
+      Just Poweroff -> liftIO runPowerOff
+      Just Shutdown -> lock >> liftIO runSuspend
+      Just Hibernate -> lock >> liftIO runHibernate
+      Just Reboot -> liftIO runReboot
+      -- TODO log an error here since this should never happen
+      Nothing -> skip

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Concurrent module to handle events from acpid
 
@@ -10,7 +7,7 @@ module XMonad.Internal.Concurrent.ACPIEvent
   )
 where
 
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import Network.Socket
 import Network.Socket.ByteString
 import RIO
@@ -33,15 +30,18 @@ data ACPIEvent
   | LidClose
   deriving (Eq)
 
-instance Enum ACPIEvent where
-  toEnum 0 = Power
-  toEnum 1 = Sleep
-  toEnum 2 = LidClose
-  toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
+fromACPIEvent :: ACPIEvent -> Int
+fromACPIEvent x = case x of
+  Power -> 0
+  Sleep -> 1
+  LidClose -> 2
 
-  fromEnum Power = 0
-  fromEnum Sleep = 1
-  fromEnum LidClose = 2
+toACPIEvent :: Int -> Maybe ACPIEvent
+toACPIEvent x = case x of
+  0 -> Just Power
+  1 -> Just Sleep
+  2 -> Just LidClose
+  _ -> Nothing
 
 --------------------------------------------------------------------------------
 -- Internal functions
@@ -64,7 +64,7 @@ parseLine line =
 
 -- | Send an ACPIEvent to the X server as a ClientMessage
 sendACPIEvent :: ACPIEvent -> IO ()
-sendACPIEvent = sendXMsg ACPI . show . fromEnum
+sendACPIEvent = sendXMsg ACPI . show . fromACPIEvent
 
 isDischarging :: IO (Maybe Bool)
 isDischarging = do
@@ -91,14 +91,14 @@ socketDep = Only_ $ pathR acpiPath [Package Official "acpid"]
 -- Xmonad's event hook)
 handleACPI :: FontBuilder -> X () -> String -> X ()
 handleACPI fb lock tag = do
-  let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
+  let acpiTag = toACPIEvent =<< readMaybe tag :: Maybe ACPIEvent
   forM_ acpiTag $ \case
     Power -> powerPrompt lock fb
     Sleep -> suspendPrompt fb
     LidClose -> do
       status <- io isDischarging
       -- only run suspend if battery exists and is discharging
-      forM_ status $ flip when runSuspend
+      forM_ status $ flip when $ liftIO runSuspend
       lock
 
 --------------------------------------------------------------------------------

lib/XMonad/Internal/Concurrent/ClientMessage.hs

@@ -28,6 +28,7 @@ import Graphics.X11.Xlib.Atom
 import Graphics.X11.Xlib.Display
 import Graphics.X11.Xlib.Event
 import Graphics.X11.Xlib.Extras
+import RIO
 import XMonad.Internal.IO
 
 --------------------------------------------------------------------------------
@@ -42,14 +43,18 @@ data XMsgType
   | Unknown
   deriving (Eq, Show)
 
-instance Enum XMsgType where
-  toEnum 0 = ACPI
-  toEnum 1 = Workspace
-  toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
+fromXMsgType :: XMsgType -> Int
+fromXMsgType x = case x of
+  ACPI -> 0
+  Workspace -> 1
+  Unknown -> 2
 
-  fromEnum ACPI = 0
-  fromEnum Workspace = 1
-  fromEnum Unknown = 2
+toXMsgType :: Int -> Maybe XMsgType
+toXMsgType x = case x of
+  0 -> Just ACPI
+  1 -> Just Workspace
+  2 -> Just Unknown
+  _ -> Nothing
 
 --------------------------------------------------------------------------------
 -- Exported API
@@ -58,9 +63,9 @@ instance Enum XMsgType where
 -- type and payload
 splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
 splitXMsg [] = (Unknown, "")
-splitXMsg (x : xs) = (xtype, tag)
+splitXMsg (x : xs) = (fromMaybe Unknown xtype, tag)
   where
-    xtype = toEnum $ fromIntegral x
+    xtype = toXMsgType $ fromIntegral x
     tag = chr . fromIntegral <$> takeWhile (/= 0) xs
 
 -- | Emit a ClientMessage event to the X server with the given type and payloud
@@ -86,5 +91,5 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
     setClientMessageEvent' e root bITMAP 8 (x : t)
     sendEvent dpy root False substructureNotifyMask e
   where
-    x = fromIntegral $ fromEnum xtype
+    x = fromIntegral $ fromXMsgType xtype
     t = fmap (fromIntegral . fromEnum) tag

lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs

@@ -34,6 +34,8 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
   )
 where
 
+import qualified Data.ByteString.Char8 as BC
+import Data.Internal.XIO
 import Graphics.X11.Types
 import Graphics.X11.Xlib.Atom
 import Graphics.X11.Xlib.Display
@@ -88,38 +90,49 @@ data DynWorkspace = DynWorkspace
 -- the same as that in XMonad itself (eg with Query types)
 -- type MatchTags = M.Map String String
 
-data WConf = WConf
-  { display :: Display
-  , dynWorkspaces :: [DynWorkspace]
-  , curPIDs :: MVar (S.Set Pid)
+data WEnv = WEnv
+  { wDisplay :: !Display
+  , wDynWorkspaces :: ![DynWorkspace]
+  , wCurPIDs :: !(MVar (S.Set Pid))
+  , wXEnv :: !XEnv
   }
 
-type W a = RIO WConf ()
+instance HasLogFunc WEnv where
+  logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
 
-runWorkspaceMon :: [DynWorkspace] -> IO ()
+type WIO a = RIO WEnv a
+
+runWorkspaceMon :: [DynWorkspace] -> XIO ()
 runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
-  root <- rootWindow dpy $ defaultScreen dpy
+  root <- liftIO $ rootWindow dpy $ defaultScreen dpy
   -- listen only for substructure change events (which includes MapNotify)
-  allocaSetWindowAttributes $ \a -> do
+  liftIO $ allocaSetWindowAttributes $ \a -> do
     set_event_mask a substructureNotifyMask
     changeWindowAttributes dpy root cWEventMask a
-  void $ allocaXEvent $ withEvents dpy
+  withRunInIO $ \runIO -> do
+    void $ allocaXEvent $ runIO . withEvents dpy
   where
+    wrapEnv dpy ps x =
+      WEnv
+        { wDisplay = dpy
+        , wDynWorkspaces = dws
+        , wCurPIDs = ps
+        , wXEnv = x
+        }
     withEvents dpy e = do
       ps <- newMVar S.empty
-      let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
-      runRIO c $
+      mapRIO (wrapEnv dpy ps) $ do
         forever $
           handleEvent =<< io (nextEvent dpy e >> getEvent e)
 
-handleEvent :: Event -> W ()
+handleEvent :: Event -> WIO ()
 
 -- | assume this fires at least once when a new window is created (also could
 -- use CreateNotify but that is really noisy)
 handleEvent MapNotifyEvent {ev_window = w} = do
-  dpy <- asks display
+  dpy <- asks wDisplay
   hint <- io $ getClassHint dpy w
-  dws <- asks dynWorkspaces
+  dws <- asks wDynWorkspaces
   let tag =
         M.lookup (resClass hint) $
           M.fromList $
@@ -133,21 +146,28 @@ handleEvent MapNotifyEvent {ev_window = w} = do
       _ -> return ()
 handleEvent _ = return ()
 
-withUniquePid :: Pid -> String -> W ()
+withUniquePid :: Pid -> String -> WIO ()
 withUniquePid pid tag = do
-  ps <- asks curPIDs
+  ps <- asks wCurPIDs
   pids <- readMVar ps
-  io
-    $ unless (pid `elem` pids)
+  unless (pid `elem` pids)
     $ bracket_
       (modifyMVar_ ps (return . S.insert pid))
       (modifyMVar_ ps (return . S.delete pid))
-    $ waitUntilExit pid >> sendXMsg Workspace tag
+    $ do
+      logInfo $ "waiting for pid " <> pid_ <> " to exit on workspace " <> tag_
+      waitUntilExit pid
+      logInfo $ "pid " <> pid_ <> " exited on workspace " <> tag_
+      liftIO $ sendXMsg Workspace tag
+  where
+    pid_ = "'" <> displayShow pid <> "'"
+    tag_ = "'" <> displayBytesUtf8 (BC.pack tag) <> "'"
 
 --------------------------------------------------------------------------------
 -- Launching apps
 -- When launching apps on dymamic workspaces, first check if they are running
 -- and launch if not, then switch to their workspace
+
 wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
 wsOccupied tag ws =
   elem tag $

lib/XMonad/Internal/Concurrent/VirtualBox.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 --------------------------------------------------------------------------------
 -- VirtualBox-specific functions
 
@@ -11,7 +8,7 @@ module XMonad.Internal.Concurrent.VirtualBox
   )
 where
 
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import RIO hiding (try)
 import RIO.Directory
 import RIO.FilePath
@@ -36,7 +33,7 @@ vmInstanceConfig vmName = do
 vmDirectory :: IO (Either String String)
 vmDirectory = do
   p <- vmConfig
-  s <- tryIO $ readFile p
+  s <- tryIO $ readFileUtf8 p
   return $ case s of
     (Left _) -> Left "could not read VirtualBox config file"
     (Right x) ->

lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- DBus module for Clevo Keyboard control
 
@@ -15,7 +13,7 @@ where
 
 import DBus
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import RIO
 import RIO.FilePath
 import XMonad.Internal.DBus.Brightness.Common
@@ -46,34 +44,34 @@ backlightDir = "/sys/devices/platform/tuxedo_keyboard"
 stateFile :: FilePath
 stateFile = backlightDir </> "state"
 
-stateChange :: Bool -> IO ()
+stateChange :: MonadUnliftIO m => Bool -> m ()
 stateChange = writeBool stateFile
 
-stateOn :: IO ()
+stateOn :: MonadUnliftIO m => m ()
 stateOn = stateChange True
 
-stateOff :: IO ()
+stateOff :: MonadUnliftIO m => m ()
 stateOff = stateChange False
 
 brightnessFile :: FilePath
 brightnessFile = backlightDir </> "brightness"
 
-getBrightness :: RawBounds -> IO Brightness
+getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 getBrightness bounds = readPercent bounds brightnessFile
 
-minBrightness :: RawBounds -> IO Brightness
+minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 minBrightness bounds = do
   b <- writePercentMin bounds brightnessFile
   stateOff
   return b
 
-maxBrightness :: RawBounds -> IO Brightness
+maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile
 
-incBrightness :: RawBounds -> IO Brightness
+incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds
 
-decBrightness :: RawBounds -> IO Brightness
+decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 decBrightness bounds = do
   b <- decPercent steps brightnessFile bounds
   when (b == 0) stateOff
@@ -88,7 +86,7 @@ blPath = objectPath_ "/clevo_keyboard"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"
 
-clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
+clevoKeyboardConfig :: MonadUnliftIO m => BrightnessConfig m RawBrightness Brightness
 clevoKeyboardConfig =
   BrightnessConfig
     { bcMin = minBrightness
@@ -113,9 +111,14 @@ brightnessFileDep :: IODependency_
 brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
 
 clevoKeyboardSignalDep :: DBusDependency_ SesClient
-clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
+clevoKeyboardSignalDep =
+  -- TODO do I need to get rid of the IO here?
+  signalDep (clevoKeyboardConfig :: BrightnessConfig IO RawBrightness Brightness)
 
-exportClevoKeyboard :: Maybe SesClient -> SometimesIO
+exportClevoKeyboard
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> Sometimes (m (), m ())
 exportClevoKeyboard =
   brightnessExporter
     xpfClevoBacklight
@@ -123,15 +126,23 @@ exportClevoKeyboard =
     [stateFileDep, brightnessFileDep]
     clevoKeyboardConfig
 
-clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
+clevoKeyboardControls
+  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> BrightnessControls m
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
 
-callGetBrightnessCK :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
+callGetBrightnessCK
+  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
+  => m (Maybe Brightness)
 callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
 
 matchSignalCK
-  :: MonadUnliftIO m
+  :: ( SafeClient c
+     , HasClient env
+     , MonadReader (env c) m
+     , MonadUnliftIO m
+     )
   => (Maybe Brightness -> m ())
-  -> SesClient
   -> m ()
 matchSignalCK = matchSignal clevoKeyboardConfig

lib/XMonad/Internal/DBus/Brightness/Common.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- DBus module for DBus brightness controls
 
@@ -18,10 +16,9 @@ import DBus
 import DBus.Client
 import qualified DBus.Introspection as I
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import RIO
 import qualified RIO.Text as T
-import XMonad.Core (io)
 import XMonad.Internal.DBus.Common
 
 --------------------------------------------------------------------------------
@@ -32,31 +29,32 @@ import XMonad.Internal.DBus.Common
 -- integer and emit a signal with the same brightness value. Additionally, there
 -- is one method to get the current brightness.
 
-data BrightnessConfig a b = BrightnessConfig
-  { bcMin :: (a, a) -> IO b
-  , bcMax :: (a, a) -> IO b
-  , bcDec :: (a, a) -> IO b
-  , bcInc :: (a, a) -> IO b
-  , bcGet :: (a, a) -> IO b
+data BrightnessConfig m a b = BrightnessConfig
+  { bcMin :: (a, a) -> m b
+  , bcMax :: (a, a) -> m b
+  , bcDec :: (a, a) -> m b
+  , bcInc :: (a, a) -> m b
+  , bcGet :: (a, a) -> m b
   , bcMinRaw :: a
-  , bcGetMax :: IO a
+  , bcGetMax :: m a
   , bcPath :: ObjectPath
   , bcInterface :: InterfaceName
   , bcName :: T.Text
   }
 
-data BrightnessControls = BrightnessControls
-  { bctlMax :: SometimesX
-  , bctlMin :: SometimesX
-  , bctlInc :: SometimesX
-  , bctlDec :: SometimesX
+data BrightnessControls m = BrightnessControls
+  { bctlMax :: Sometimes (m ())
+  , bctlMin :: Sometimes (m ())
+  , bctlInc :: Sometimes (m ())
+  , bctlDec :: Sometimes (m ())
   }
 
 brightnessControls
-  :: XPQuery
-  -> BrightnessConfig a b
-  -> Maybe SesClient
-  -> BrightnessControls
+  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
+  => XPQuery
+  -> BrightnessConfig m a b
+  -> Maybe NamedSesConnection
+  -> BrightnessControls m
 brightnessControls q bc cl =
   BrightnessControls
     { bctlMax = cb "max brightness" memMax
@@ -68,26 +66,34 @@ brightnessControls q bc cl =
     cb = callBacklight q cl bc
 
 callGetBrightness
-  :: (MonadUnliftIO m, SafeClient c, Num n)
-  => BrightnessConfig a b
-  -> c
+  :: ( HasClient env
+     , MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , Num n
+     )
+  => BrightnessConfig m a b
   -> m (Maybe n)
-callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
+callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
   either (const Nothing) bodyGetBrightness
-    <$> callMethod client xmonadBusName p i memGet
+    <$> callMethod xmonadSesBusName p i memGet
 
-signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
+signalDep :: BrightnessConfig m a b -> DBusDependency_ c
 signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
-  Endpoint [] xmonadBusName p i $ Signal_ memCur
+  Endpoint [] xmonadSesBusName p i $ Signal_ memCur
 
 matchSignal
-  :: (MonadUnliftIO m, SafeClient c, Num n)
-  => BrightnessConfig a b
+  :: ( HasClient env
+     , MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , Num n
+     )
+  => BrightnessConfig m a b
   -> (Maybe n -> m ())
-  -> c
   -> m ()
 matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
-  void . addMatchCallback brMatcher (cb . bodyGetBrightness)
+  void $ addMatchCallback brMatcher (cb . bodyGetBrightness)
   where
     -- TODO add busname to this
     brMatcher =
@@ -101,33 +107,35 @@ matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
 -- Internal DBus Crap
 
 brightnessExporter
-  :: RealFrac b
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
   => XPQuery
   -> [Fulfillment]
   -> [IODependency_]
-  -> BrightnessConfig a b
-  -> Maybe SesClient
-  -> SometimesIO
+  -> BrightnessConfig m a b
+  -> Maybe NamedSesConnection
+  -> Sometimes (m (), m ())
 brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
   Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
   where
-    root = DBusRoot_ (exportBrightnessControls' bc) tree cl
-    tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
+    root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
+    tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
 
-exportBrightnessControls'
-  :: (MonadUnliftIO m, RealFrac b)
-  => BrightnessConfig a b
-  -> SesClient
-  -> m ()
-exportBrightnessControls' bc cl = io $ do
-  let ses = toClient cl
-  maxval <- bcGetMax bc -- assume the max value will never change
-  let bounds = (bcMinRaw bc, maxval)
-  let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
-  let funget = bcGet bc
-  export
-    ses
-    (bcPath bc)
+exportBrightnessControlsInner
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
+  => BrightnessConfig m a b
+  -> NamedSesConnection
+  -> (m (), m ())
+exportBrightnessControlsInner bc = cmd
+  where
+    cmd = exportPair (bcPath bc) $ \cl_ -> do
+      -- assume the max value will never change
+      bounds <- (bcMinRaw bc,) <$> bcGetMax bc
+      runIO <- askRunInIO
+      let autoMethod' m f = autoMethod m $ runIO $ do
+            val <- f bc bounds
+            emitBrightness bc cl_ val
+      funget <- toIO $ bcGet bc bounds
+      return $
         defaultInterface
           { interfaceName = bcInterface bc
           , interfaceMethods =
@@ -135,11 +143,10 @@ exportBrightnessControls' bc cl = io $ do
               , autoMethod' memMin bcMin
               , autoMethod' memInc bcInc
               , autoMethod' memDec bcDec
-          , autoMethod memGet (round <$> funget bounds :: IO Int32)
+              , autoMethod memGet (round <$> funget :: IO Int32)
               ]
           , interfaceSignals = [sig]
           }
-  where
     sig =
       I.Signal
         { I.signalName = memCur
@@ -153,7 +160,7 @@ exportBrightnessControls' bc cl = io $ do
 
 emitBrightness
   :: (MonadUnliftIO m, RealFrac b)
-  => BrightnessConfig a b
+  => BrightnessConfig m a b
   -> Client
   -> b
   -> m ()
@@ -163,26 +170,18 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
     sig = signal p i memCur
 
 callBacklight
-  :: XPQuery
-  -> Maybe SesClient
-  -> BrightnessConfig a b
+  :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
+  => XPQuery
+  -> Maybe NamedSesConnection
+  -> BrightnessConfig m a b
   -> T.Text
   -> MemberName
-  -> SometimesX
-callBacklight
-  q
-  cl
-  BrightnessConfig
-    { bcPath = p
-    , bcInterface = i
-    , bcName = n
-    }
-  controlName
-  m =
+  -> Sometimes (m ())
+callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
   Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
   where
-      root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
-      cmd c = io $ void $ callMethod c xmonadBusName p i m
+    root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
+    cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
 
 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- DBus module for Intel Backlight control
 
@@ -15,7 +13,7 @@ where
 
 import DBus
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import RIO
 import RIO.FilePath
 import XMonad.Internal.DBus.Brightness.Common
@@ -45,22 +43,22 @@ maxFile = backlightDir </> "max_brightness"
 curFile :: FilePath
 curFile = backlightDir </> "brightness"
 
-getMaxRawBrightness :: IO RawBrightness
+getMaxRawBrightness :: MonadUnliftIO m => m RawBrightness
 getMaxRawBrightness = readInt maxFile
 
-getBrightness :: RawBounds -> IO Brightness
+getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 getBrightness bounds = readPercent bounds curFile
 
-minBrightness :: RawBounds -> IO Brightness
+minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 minBrightness bounds = writePercentMin bounds curFile
 
-maxBrightness :: RawBounds -> IO Brightness
+maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 maxBrightness bounds = writePercentMax bounds curFile
 
-incBrightness :: RawBounds -> IO Brightness
+incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 incBrightness = incPercent steps curFile
 
-decBrightness :: RawBounds -> IO Brightness
+decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
 decBrightness = decPercent steps curFile
 
 --------------------------------------------------------------------------------
@@ -72,7 +70,9 @@ blPath = objectPath_ "/intelbacklight"
 interface :: InterfaceName
 interface = interfaceName_ "org.xmonad.Brightness"
 
-intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
+intelBacklightConfig
+  :: MonadUnliftIO m
+  => BrightnessConfig m RawBrightness Brightness
 intelBacklightConfig =
   BrightnessConfig
     { bcMin = minBrightness
@@ -97,9 +97,14 @@ maxFileDep :: IODependency_
 maxFileDep = pathR maxFile []
 
 intelBacklightSignalDep :: DBusDependency_ SesClient
-intelBacklightSignalDep = signalDep intelBacklightConfig
+intelBacklightSignalDep =
+  -- TODO do I need to get rid of the IO here?
+  signalDep (intelBacklightConfig :: BrightnessConfig IO RawBrightness Brightness)
 
-exportIntelBacklight :: Maybe SesClient -> SometimesIO
+exportIntelBacklight
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> Sometimes (m (), m ())
 exportIntelBacklight =
   brightnessExporter
     xpfIntelBacklight
@@ -107,15 +112,23 @@ exportIntelBacklight =
     [curFileDep, maxFileDep]
     intelBacklightConfig
 
-intelBacklightControls :: Maybe SesClient -> BrightnessControls
+intelBacklightControls
+  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> BrightnessControls m
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 
-callGetBrightnessIB :: MonadUnliftIO m => SesClient -> m (Maybe Brightness)
+callGetBrightnessIB
+  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
+  => m (Maybe Brightness)
 callGetBrightnessIB = callGetBrightness intelBacklightConfig
 
 matchSignalIB
-  :: MonadUnliftIO m
+  :: ( SafeClient c
+     , HasClient env
+     , MonadReader (env c) m
+     , MonadUnliftIO m
+     )
   => (Maybe Brightness -> m ())
-  -> SesClient
   -> m ()
 matchSignalIB = matchSignal intelBacklightConfig

lib/XMonad/Internal/DBus/Common.hs

@@ -2,7 +2,8 @@
 -- High-level interface for managing XMonad's DBus
 
 module XMonad.Internal.DBus.Common
-  ( xmonadBusName
+  ( xmonadSesBusName
+  , xmonadSysBusName
   , btBus
   , notifyBus
   , notifyPath
@@ -12,8 +13,11 @@ where
 
 import DBus
 
-xmonadBusName :: BusName
-xmonadBusName = busName_ "org.xmonad"
+xmonadSesBusName :: BusName
+xmonadSesBusName = busName_ "org.xmonad.session"
+
+xmonadSysBusName :: BusName
+xmonadSysBusName = busName_ "org.xmonad.system"
 
 btBus :: BusName
 btBus = busName_ "org.bluez"

lib/XMonad/Internal/DBus/Control.hs

@@ -1,15 +1,17 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
 --------------------------------------------------------------------------------
 -- High-level interface for managing XMonad's DBus
 
 module XMonad.Internal.DBus.Control
   ( Client
   , DBusState (..)
+  , withDBusInterfaces
+  , withDBusX
+  , withDBusX_
+  , withDBus
+  , withDBus_
   , connectDBus
-  , connectDBusX
   , disconnectDBus
-  , disconnectDBusX
+  -- , disconnectDBusX
   , getDBusClient
   , withDBusClient
   , withDBusClient_
@@ -21,7 +23,7 @@ where
 import DBus
 import DBus.Client
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import RIO
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import XMonad.Internal.DBus.Brightness.IntelBacklight
@@ -30,54 +32,157 @@ import XMonad.Internal.DBus.Screensaver
 
 -- | Current connections to the DBus (session and system buses)
 data DBusState = DBusState
-  { dbSesClient :: Maybe SesClient
-  , dbSysClient :: Maybe SysClient
+  { dbSesClient :: Maybe NamedSesConnection
+  , dbSysClient :: Maybe NamedSysConnection
   }
 
+withDBusX_
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => (DBusState -> m a)
+  -> m ()
+withDBusX_ = void . withDBusX
+
+withDBusX
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => (DBusState -> m a)
+  -> m a
+withDBusX = withDBus (Just xmonadSesBusName) Nothing
+
+withDBus_
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe BusName
+  -> Maybe BusName
+  -> (DBusState -> m a)
+  -> m ()
+withDBus_ sesname sysname = void . withDBus sesname sysname
+
+withDBus
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe BusName
+  -> Maybe BusName
+  -> (DBusState -> m a)
+  -> m a
+withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
+
 -- | Connect to the DBus
-connectDBus :: MonadUnliftIO m => m DBusState
-connectDBus = do
-  ses <- getDBusClient
-  sys <- getDBusClient
+connectDBus
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe BusName
+  -> Maybe BusName
+  -> m DBusState
+connectDBus sesname sysname = do
+  ses <- getDBusClient sesname
+  sys <- getDBusClient sysname
   return DBusState {dbSesClient = ses, dbSysClient = sys}
 
 -- | Disconnect from the DBus
-disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
+disconnectDBus
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => DBusState
+  -> m ()
 disconnectDBus db = disc dbSesClient >> disc dbSysClient
   where
+    disc
+      :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
+      => (DBusState -> Maybe (NamedConnection c))
+      -> m ()
     disc f = maybe (return ()) disconnectDBusClient $ f db
 
--- | Connect to the DBus and request the XMonad name
-connectDBusX :: MonadUnliftIO m => m DBusState
-connectDBusX = do
-  db <- connectDBus
-  forM_ (dbSesClient db) requestXMonadName
-  return db
+-- -- | Connect to the DBus and request the XMonad name
+-- connectDBusX
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => m DBusState
+-- connectDBusX = do
+--   db <- connectDBus
+--   requestXMonadName2 db
+--   return db
 
--- | Disconnect from DBus and release the XMonad name
-disconnectDBusX :: MonadUnliftIO m => DBusState -> m ()
-disconnectDBusX db = do
-  forM_ (dbSesClient db) releaseXMonadName
-  disconnectDBus db
+-- -- | Disconnect from DBus and release the XMonad name
+-- disconnectDBusX
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => DBusState
+--   -> m ()
+-- disconnectDBusX db = do
+--   forM_ (dbSesClient db) releaseBusName
+--   forM_ (dbSysClient db) releaseBusName
+--   disconnectDBus db
+
+-- requestXMonadName2
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => DBusState
+--   -> m ()
+-- requestXMonadName2 db = do
+--   forM_ (dbSesClient db) requestXMonadName
+--   forM_ (dbSysClient db) requestXMonadName
+
+withDBusInterfaces
+  :: DBusState
+  -> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
+  -> ([XIO ()] -> XIO a)
+  -> XIO a
+withDBusInterfaces db interfaces = bracket up sequence
+  where
+    up = do
+      pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) interfaces
+      mapM_ fst pairs
+      return $ snd <$> pairs
 
 -- | All exporter features to be assigned to the DBus
-dbusExporters :: [Maybe SesClient -> SometimesIO]
+dbusExporters
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => [Maybe NamedSesConnection -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
-releaseXMonadName :: MonadUnliftIO m => SesClient -> m ()
-releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName
+-- releaseXMonadName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => c
+--   -> m ()
+-- releaseXMonadName cl = do
+--   -- TODO this might error?
+--   liftIO $ void $ releaseName (toClient cl) xmonadBusName
+--   logInfo "released xmonad name"
 
-requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
-requestXMonadName ses = do
-  res <- liftIO $ requestName (toClient ses) xmonadBusName []
-  -- TODO if the client is not released on shutdown the owner will be different
-  let msg
-        | res == NamePrimaryOwner = Nothing
-        | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
-        | res == NameInQueue
-            || res == NameExists =
-            Just $ "another process owns " ++ xn
-        | otherwise = Just $ "unknown error when requesting " ++ xn
-  liftIO $ forM_ msg putStrLn
-  where
-    xn = "'" ++ formatBusName xmonadBusName ++ "'"
+-- releaseBusName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => BusName
+--   -> c
+--   -> m ()
+-- releaseBusName n cl = do
+--   -- TODO this might error?
+--   liftIO $ void $ releaseName (toClient cl) n
+--   logInfo $ "released bus name: " <> displayBusName n
+
+-- requestBusName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => BusName
+--   -> c
+--   -> m ()
+-- requestBusName n cl = do
+--   res <- try $ liftIO $ requestName (toClient cl) n []
+--   case res of
+--     Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+--     Right r -> do
+--       let msg
+--             | r == NamePrimaryOwner = "registering name"
+--             | r == NameAlreadyOwner = "this process already owns name"
+--             | r == NameInQueue
+--                 || r == NameExists =
+--                 "another process owns name"
+--             -- this should never happen
+--             | otherwise = "unknown error when requesting name"
+--       logInfo $ msg <> ": " <> displayBusName n
+
+-- requestXMonadName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => c
+--   -> m ()
+-- requestXMonadName cl = do
+--   res <- liftIO $ requestName (toClient cl) xmonadBusName []
+--   let msg
+--         | res == NamePrimaryOwner = "registering name"
+--         | res == NameAlreadyOwner = "this process already owns name"
+--         | res == NameInQueue
+--             || res == NameExists =
+--             "another process owns name"
+--         | otherwise = "unknown error when requesting name"
+--   logInfo $ msg <> ": " <> displayBusName xmonadBusName

lib/XMonad/Internal/DBus/Removable.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Module for monitoring removable drive events
 --
@@ -11,7 +9,7 @@ module XMonad.Internal.DBus.Removable (runRemovableMon) where
 import DBus
 import DBus.Client
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import RIO
 import qualified RIO.Map as M
 import XMonad.Core (io)
@@ -73,25 +71,36 @@ removedHasDrive [_, a] =
     (fromVariant a :: Maybe [String])
 removedHasDrive _ = False
 
-playSoundMaybe :: FilePath -> Bool -> IO ()
+playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
 playSoundMaybe p b = when b $ io $ playSound p
 
 -- NOTE: the udisks2 service should be already running for this module to work.
 -- If it not already, we won't see any signals from the dbus until it is
 -- started (it will work after it is started however). It seems safe to simply
 -- enable the udisks2 service at boot; however this is not default behavior.
-listenDevices :: SysClient -> IO ()
+listenDevices
+  :: ( HasClient (DBusEnv env)
+     , MonadReader env m
+     , MonadUnliftIO m
+     )
+  => NamedSysConnection
+  -> m ()
 listenDevices cl = do
   addMatch' memAdded driveInsertedSound addedHasDrive
   addMatch' memRemoved driveRemovedSound removedHasDrive
   where
-    addMatch' m p f =
-      void $
-        addMatch (toClient cl) ruleUdisks {matchMember = Just m} $
-          playSoundMaybe p . f . signalBody
+    addMatch' m p f = do
+      let rule = ruleUdisks {matchMember = Just m}
+      void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
 
-runRemovableMon :: Maybe SysClient -> SometimesIO
+runRemovableMon
+  :: ( HasClient (DBusEnv env)
+     , MonadReader env m
+     , MonadUnliftIO m
+     )
+  => Maybe NamedSysConnection
+  -> Sometimes (m ())
 runRemovableMon cl =
-  sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices
+  sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
   where
     deps = toAnd_ addedDep removedDep

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- DBus module for X11 screensave/DPMS control
 
@@ -16,7 +14,7 @@ import DBus
 import DBus.Client
 import qualified DBus.Introspection as I
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import Graphics.X11.XScreenSaver
 import RIO
 import XMonad.Internal.DBus.Common
@@ -93,20 +91,20 @@ bodyGetCurrentState _ = Nothing
 --------------------------------------------------------------------------------
 -- Exported haskell API
 
-exportScreensaver :: Maybe SesClient -> SometimesIO
+exportScreensaver
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> Sometimes (m (), m ())
 exportScreensaver ses =
   sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
   where
-    cmd cl =
-      let cl' = toClient cl
-       in withRunInIO $ \run ->
-            export
-              cl'
-              ssPath
+    cmd = exportPair ssPath $ \cl_ -> do
+      liftIO $ withRunInIO $ \run ->
+        return $
           defaultInterface
             { interfaceName = interface
             , interfaceMethods =
-                    [ autoMethod memToggle $ run $ emitState cl' =<< toggle
+                [ autoMethod memToggle $ run $ emitState cl_ =<< toggle
                 , autoMethod memQuery (run query)
                 ]
             , interfaceSignals = [sig]
@@ -121,32 +119,42 @@ exportScreensaver ses =
                 }
             ]
         }
-    bus = Bus [] xmonadBusName
+    bus = Bus [] xmonadSesBusName
     ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
 
-callToggle :: Maybe SesClient -> SometimesX
+callToggle
+  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
+  => Maybe NamedSesConnection
+  -> Sometimes (m ())
 callToggle =
   sometimesEndpoint
     "screensaver toggle"
     "dbus switch"
     []
-    xmonadBusName
+    xmonadSesBusName
     ssPath
     interface
     memToggle
 
-callQuery :: MonadUnliftIO m => SesClient -> m (Maybe SSState)
-callQuery ses = do
-  reply <- callMethod ses xmonadBusName ssPath interface memQuery
+callQuery
+  :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
+  => m (Maybe SSState)
+callQuery = do
+  reply <- callMethod xmonadSesBusName ssPath interface memQuery
   return $ either (const Nothing) bodyGetCurrentState reply
 
-matchSignal :: MonadUnliftIO m => (Maybe SSState -> m ()) -> SesClient -> m ()
-matchSignal cb ses =
+matchSignal
+  :: ( HasClient env
+     , MonadReader (env SesClient) m
+     , MonadUnliftIO m
+     )
+  => (Maybe SSState -> m ())
+  -> m ()
+matchSignal cb =
   void $
     addMatchCallback
       ruleCurrentState
       (cb . bodyGetCurrentState)
-      ses
 
 ssSignalDep :: DBusDependency_ SesClient
-ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
+ssSignalDep = Endpoint [] xmonadSesBusName ssPath interface $ Signal_ memState

lib/XMonad/Internal/IO.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE ViewPatterns #-}
-
 --------------------------------------------------------------------------------
 -- Random IO-ish functions used throughtout xmonad
 --
@@ -41,7 +39,7 @@ import System.Process
 -- read
 
 readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
-readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
+readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
 
 readBool :: MonadIO m => FilePath -> m Bool
 readBool = fmap (== (1 :: Int)) . readInt
@@ -49,7 +47,7 @@ readBool = fmap (== (1 :: Int)) . readInt
 --------------------------------------------------------------------------------
 -- write
 
-writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
+writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
 writeInt f = writeFileUtf8 f . T.pack . show
 
 writeBool :: MonadIO m => FilePath -> Bool -> m ()
@@ -62,7 +60,7 @@ writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
 -- value. Assume that the file being read has a min of 0 and an unchanging max
 -- given by a runtime argument, which is scaled linearly to the range 0-100
 -- (percent).
-rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
+rawToPercent :: (Integral a, Integral b, RealFrac c) => (a, a) -> b -> c
 rawToPercent (lower, upper) raw =
   100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
 
@@ -166,7 +164,7 @@ getPermissionsSafe f = do
 -- | Block until a PID has exited.
 -- Use this to control flow based on a process that was not explicitly started
 -- by the Haskell runtime itself, and thus has no data structures to query.
-waitUntilExit :: (MonadIO m) => Pid -> m ()
+waitUntilExit :: (MonadUnliftIO m) => Pid -> m ()
 waitUntilExit pid = do
   res <- doesDirectoryExist $ "/proc" </> show pid
   when res $ do

lib/XMonad/Internal/Notify.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Functions for formatting and sending notifications
 --

lib/XMonad/Internal/Shell.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- Functions for formatting and spawning shell commands
 
 module XMonad.Internal.Shell
@@ -85,8 +83,31 @@ spawn :: MonadIO m => T.Text -> m ()
 spawn = X.spawn . T.unpack
 
 -- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
-spawnPipe :: MonadIO m => T.Text -> m Handle
-spawnPipe = XR.spawnPipe . T.unpack
+spawnPipe :: MonadUnliftIO m => T.Text -> m Handle
+spawnPipe = liftIO . XR.spawnPipe . T.unpack
+
+-- spawnPipeRW
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => T.Text
+--   -> m Handle
+-- spawnPipeRW x = do
+--   (r, h) <- liftIO mkPipe
+--   child r
+--   liftIO $ closeFd r
+--   return h
+--   where
+--     mkPipe = do
+--       (r, w) <- createPipe
+--       setFdOption w CloseOnExec True
+--       h <- fdToHandle w
+--       -- ASSUME we are using utf8 everywhere
+--       hSetEncoding h utf8
+--       hSetBuffering h LineBuffering
+--       return (r, h)
+--     child r = void $ withRunInIO $ \runIO -> do
+--       X.xfork $ runIO $ do
+--         void $ liftIO $ dupTo r stdInput
+--         liftIO $ executeFile "/bin/sh" False ["-c", T.unpack x] Nothing
 
 -- | Run 'XMonad.Core.spawn' with a command and arguments
 spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()

lib/XMonad/Internal/Theme.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Theme for XMonad and Xmobar
 
@@ -33,6 +31,7 @@ where
 
 import Data.Colour
 import Data.Colour.SRGB
+import RIO
 import qualified RIO.Text as T
 import qualified XMonad.Layout.Decoration as D
 import qualified XMonad.Prompt as P

lib/Xmobar/Plugins/ActiveConnection.hs

@@ -0,0 +1,155 @@
+--------------------------------------------------------------------------------
+-- NetworkManager Connection plugin
+--
+-- Show active connections of varying types.
+--
+-- This plugin exclusively monitors the */ActiveConnection/* paths in the
+-- NetworkManager DBus path for state changes. It does not pin these to any
+-- particular interface but instead looks at all connections equally and filters
+-- based on their Type (ethernet, wifi, VPN, etc). For many use cases this will
+-- track well enough with either one or a collection of similar interfaces (ie
+-- all ethernet or all wifi).
+
+module Xmobar.Plugins.ActiveConnection
+  ( ActiveConnection (..)
+  , devDep
+  , connAlias
+  )
+where
+
+import DBus
+import Data.Internal.DBus
+import Data.Internal.XIO
+import RIO
+import qualified RIO.Map as M
+import qualified RIO.NonEmpty as NE
+import qualified RIO.Text as T
+import XMonad.Internal.Command.Desktop
+import XMonad.Internal.DBus.Common
+import Xmobar
+import Xmobar.Plugins.Common
+
+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 Nothing (Just "ethernet.log") $ \c -> do
+      let dpy cb' = displayMaybe cb' formatter . Just =<< readState
+      i <- withDIO c $ initialState contypes
+      s <- newMVar i
+      let mapEnv c' = mapRIO (PluginEnv c' s dpy cb)
+      mapEnv c $ addListener mapEnv >> pluginDisplay
+    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 ->
+            -- Start a new connection and RIO process since the parent thread
+            -- will have died before these callbacks fire, therefore the logging
+            -- file descriptor will be closed. This makes a new one
+            -- TODO can I recycle the client?
+            void $
+              addMatchCallbackSignal rule $ \sig ->
+                withDBusClientConnection cb Nothing (Just "ethernet-cb.log") $ \c' ->
+                  mapEnv c' $
+                    testActiveType contypes sig
+
+nmBus :: BusName
+nmBus = "org.freedesktop.NetworkManager"
+
+nmPath :: ObjectPath
+nmPath = "/org/freedesktop/NetworkManager"
+
+nmInterface :: InterfaceName
+nmInterface = "org.freedesktop.NetworkManager"
+
+nmObjectTreePath :: ObjectPath
+nmObjectTreePath = "/org/freedesktop"
+
+nmActiveInterface :: InterfaceName
+nmActiveInterface = "org.freedesktop.NetworkManager.Connection.Active"
+
+stateChanged :: MemberName
+stateChanged = "StateChanged"
+
+-- semi-random method to test to ensure that NetworkManager is up and on DBus
+devDep :: DBusDependency_ SysClient
+devDep =
+  Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
+    Method_ "GetDeviceByIpIface"
+
+type EthIO = PluginIO EthState SysClient
+
+type EthState = M.Map ObjectPath T.Text
+
+getConnectionProp :: MemberName -> ObjectPath -> EthIO [Variant]
+getConnectionProp prop path = callPropertyGet nmBus path nmActiveInterface prop
+
+getConnectionId :: ObjectPath -> EthIO (Maybe T.Text)
+getConnectionId = fmap fromSingletonVariant . getConnectionProp "Id"
+
+getConnectionType :: ObjectPath -> EthIO (Maybe T.Text)
+getConnectionType = fmap fromSingletonVariant . getConnectionProp "Type"
+
+updateConnected :: NE.NonEmpty T.Text -> ObjectPath -> EthIO ()
+updateConnected contypes path = do
+  typeRes <- getConnectionType path
+  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
+        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 plugState
+  modifyMVar_ s $ return . M.delete path
+
+testActiveType :: NE.NonEmpty T.Text -> Signal -> EthIO ()
+testActiveType contypes sig = do
+  case signalBody sig of
+    [state, _] -> case fromVariant state of
+      Just (2 :: Word32) -> updateConnected contypes path >> pluginDisplay
+      Just 4 -> updateDisconnected path >> pluginDisplay
+      _ -> return ()
+    _ -> return ()
+  where
+    path = signalPath sig
+
+initialState
+  :: ( SafeClient c
+     , MonadUnliftIO m
+     , MonadReader (env c) m
+     , HasClient env
+     , HasLogFunc (env c)
+     )
+  => NE.NonEmpty T.Text
+  -> m EthState
+initialState contypes =
+  M.mapMaybe go <$> callGetManagedObjects nmBus nmObjectTreePath
+  where
+    go = getId <=< M.lookup nmActiveInterface
+    getId m =
+      fromVariant
+        =<< (\t -> if t `elem` contypes then M.lookup "Id" m else Nothing)
+        =<< fromVariant
+        =<< M.lookup "Type" m
+
+readState :: EthIO [T.Text]
+readState = M.elems <$> (readMVar =<< asks plugState)

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -1,11 +1,10 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- Common backlight plugin bits
 --
 -- Use the custom DBus interface exported by the XMonad process so I can react
 -- to signals spawned by commands
 module Xmobar.Plugins.BacklightCommon (startBacklight) where
 
+import DBus
 import Data.Internal.DBus
 import RIO
 import qualified RIO.Text as T
@@ -13,15 +12,17 @@ import Xmobar.Plugins.Common
 
 startBacklight
   :: (MonadUnliftIO m, RealFrac a)
-  => ((Maybe a -> m ()) -> SesClient -> m ())
-  -> (SesClient -> m (Maybe a))
+  => Maybe BusName
+  -> Maybe FilePath
+  -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
+  -> DIO SimpleApp SesClient (Maybe a)
   -> T.Text
   -> Callback
   -> m ()
-startBacklight matchSignal callGetBrightness icon cb = do
-  withDBusClientConnection cb $ \c -> do
-    matchSignal dpy c
-    dpy =<< callGetBrightness c
+startBacklight n name matchSignal callGetBrightness icon cb = do
+  withDBusClientConnection cb n name $ \c -> withDIO c $ do
+    matchSignal dpy
+    dpy =<< callGetBrightness
   where
     formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
     dpy = displayMaybe cb formatBrightness

lib/Xmobar/Plugins/Bluetooth.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Bluetooth plugin
 --
@@ -9,28 +7,18 @@
 -- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
 -- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
 --
--- This plugin will reflect if the adapter is powered and if any device is
--- connected to it. The rough outline for this procedure:
--- 1) get the adapter from the object manager
--- 2) get all devices associated with the adapter using the object interface
--- 3) determine if the adapter is powered
--- 4) determine if any devices are connected
--- 5) format the icon; powered vs not powered controls the color and connected
---    vs not connected controls the icon (connected bluetooth symbol has two
---    dots flanking it)
---
--- Step 3 can be accomplished using the "org.bluez.Adapter1" interface and
--- querying the "Powered" property. Step 4 can be done using the
--- "org.bluez.Device1" interface and the "Connected" property for each device
--- path. Since these are properties, we can asynchronously read changes to them
--- via the "PropertiesChanged" signal.
---
--- If any devices are added/removed, steps 2-4 will need to be redone and any
--- listeners will need to be updated. (TODO not sure which signals to use in
--- determining if a device is added)
+-- Simple and somewhat crude way to do this is to have two monitors, one
+-- watching the powered state of the adaptor and one listening for connection
+-- changes. The former is easy since this is just one /org/bluez/hciX. For the
+-- latter, each 'Connected' property is embedded in each individual device path
+-- on `org.bluez.Device1', so just watch the entire bluez bus for property
+-- changes and filter those that correspond to the aforementioned
+-- interface/property. Track all this in a state which keeps the powered
+-- property and a running list of connected devices.
 --
 -- TODO also not sure if I need to care about multiple adapters and/or the
--- adapter changing.
+-- adapter changing. For now it should just get the first adaptor and only pay
+-- attention to devices associated with it.
 
 module Xmobar.Plugins.Bluetooth
   ( Bluetooth (..)
@@ -42,11 +30,12 @@ where
 import DBus
 import DBus.Client
 import Data.Internal.DBus
-import Data.Internal.Dependency
+import Data.Internal.XIO
 import RIO
 import RIO.FilePath
 import RIO.List
 import qualified RIO.Map as M
+import qualified RIO.Set as S
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Common
 import Xmobar
@@ -65,31 +54,28 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
 instance Exec Bluetooth where
   alias (Bluetooth _ _) = T.unpack btAlias
   start (Bluetooth icons colors) cb =
-    withDBusClientConnection cb $ startAdapter icons colors cb
+    withDBusClientConnection cb Nothing (Just "bluetooth.log") $
+      startAdapter icons colors cb
 
 startAdapter
-  :: MonadUnliftIO m
-  => Icons
+  :: Icons
   -> Colors
   -> Callback
-  -> SysClient
-  -> m ()
+  -> NamedSysConnection
+  -> RIO SimpleApp ()
 startAdapter is cs cb cl = do
-  ot <- getBtObjectTree cl
   state <- newMVar emptyState
-  let dpy = displayIcon cb (iconFormatter is cs) state
-  forM_ (findAdapter ot) $ \adapter -> do
-    -- set up adapter
-    initAdapter state adapter cl
-    -- TODO this step could fail; at least warn the user...
-    void $ addAdaptorListener state dpy adapter cl
-    -- set up devices on the adapter (and listeners for adding/removing devices)
-    let devices = findDevices adapter ot
-    addDeviceAddedListener state dpy adapter cl
-    addDeviceRemovedListener state dpy adapter cl
-    forM_ devices $ \d -> addAndInitDevice state dpy d cl
-    -- after setting things up, show the icon based on the initialized state
-    dpy
+  let dpy cb' = displayIcon cb' (iconFormatter is cs)
+  mapRIO (PluginEnv cl state dpy cb) $ do
+    ot <- getBtObjectTree
+    case findAdaptor ot of
+      Nothing -> logError "could not find bluetooth adapter"
+      Just adaptor -> do
+        initAdapterState adaptor
+        initDevicesState adaptor ot
+        startAdaptorListener adaptor
+        startConnectedListener adaptor
+        pluginDisplay
 
 --------------------------------------------------------------------------------
 -- Icon Display
@@ -101,9 +87,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
 
 type Icons = (T.Text, T.Text)
 
-displayIcon :: MonadUnliftIO m => Callback -> IconFormatter -> MutableBtState -> m ()
+displayIcon :: Callback -> IconFormatter -> BTIO ()
 displayIcon callback formatter =
-  liftIO . callback . T.unpack . uncurry formatter <=< readState
+  liftIO . callback . T.unpack . uncurry formatter =<< readState
 
 -- TODO maybe I want this to fail when any of the device statuses are Nothing
 iconFormatter :: Icons -> Colors -> IconFormatter
@@ -114,47 +100,52 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
 
 --------------------------------------------------------------------------------
 -- Connection State
---
--- The signal handlers all run on separate threads, yet the icon depends on
--- the state reflected by all these signals. The best (only?) way to do this is
--- is to track the shared state of the bluetooth adaptor and its devices using
--- an MVar.
 
-data BTDevice = BTDevice
-  { btDevConnected :: Maybe Bool
-  , btDevSigHandler :: SignalHandler
-  }
-
-type ConnectedDevices = M.Map ObjectPath BTDevice
+type BTIO = PluginIO BtState SysClient
 
 data BtState = BtState
-  { btDevices :: ConnectedDevices
+  { btDevices :: S.Set ObjectPath
   , btPowered :: Maybe Bool
   }
 
-type MutableBtState = MVar BtState
-
 emptyState :: BtState
 emptyState =
   BtState
-    { btDevices = M.empty
+    { btDevices = S.empty
     , btPowered = Nothing
     }
 
-readState :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool, Bool)
-readState state = do
-  p <- readPowered state
-  c <- readDevices state
-  return (p, anyDevicesConnected c)
+readState :: BTIO (Maybe Bool, Bool)
+readState = do
+  p <- readPowered
+  c <- readDevices
+  return (p, not $ null c)
+
+modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
+modifyState f = do
+  m <- asks plugState
+  modifyMVar m f
+
+beforeDisplay :: BTIO () -> BTIO ()
+beforeDisplay f = f >> pluginDisplay
 
 --------------------------------------------------------------------------------
 -- Object manager
 
-findAdapter :: ObjectTree -> Maybe ObjectPath
-findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
+findAdaptor :: ObjectTree -> Maybe ObjectPath
+findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
 
-findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
-findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
+-- | Search the object tree for devices which are in a connected state.
+-- Return the object path for said devices.
+findConnectedDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
+findConnectedDevices adaptor =
+  filter (adaptorHasDevice adaptor) . M.keys . M.filter isConnectedDev
+  where
+    isConnectedDev m = Just True == lookupState m
+    lookupState =
+      fromVariant
+        <=< M.lookup (memberNameT devConnected)
+        <=< M.lookup devInterface
 
 adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
 adaptorHasDevice adaptor device = case splitPathNoRoot device of
@@ -164,190 +155,120 @@ adaptorHasDevice adaptor device = case splitPathNoRoot device of
 splitPathNoRoot :: ObjectPath -> [FilePath]
 splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
 
-getBtObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
-getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
+getBtObjectTree
+  :: ( HasClient env
+     , SafeClient c
+     , MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     )
+  => m ObjectTree
+getBtObjectTree = callGetManagedObjects btBus btOMPath
 
 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"
 
-addBtOMListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
-addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
-
-addDeviceAddedListener
-  :: MonadUnliftIO m
-  => MutableBtState
-  -> m ()
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-addDeviceAddedListener state dpy adapter client =
-  addBtOMListener addDevice client
-  where
-    addDevice = pathCallback adapter dpy $ \d ->
-      addAndInitDevice state dpy d client
-
-addDeviceRemovedListener
-  :: (MonadUnliftIO m)
-  => MutableBtState
-  -> m ()
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-addDeviceRemovedListener state dpy adapter sys =
-  addBtOMListener remDevice sys
-  where
-    remDevice = pathCallback adapter dpy $ \d -> do
-      old <- removeDevice state d
-      forM_ old $ liftIO . removeMatch (toClient sys) . btDevSigHandler
-
-pathCallback :: MonadUnliftIO m => ObjectPath -> m () -> (ObjectPath -> m ()) -> SignalCallback m
-pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
-  when (adaptorHasDevice adapter d) $ f d >> dpy
-pathCallback _ _ _ _ = return ()
-
 --------------------------------------------------------------------------------
 -- Adapter
 
-initAdapter
-  :: (MonadUnliftIO m)
-  => MutableBtState
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-initAdapter state adapter client = do
-  reply <- callGetPowered adapter client
-  putPowered state $ fromSingletonVariant reply
+-- | Get powered state of adaptor and log the result
+initAdapterState :: ObjectPath -> BTIO ()
+initAdapterState adapter = do
+  reply <- callGetPowered adapter
+  putPowered $ fromSingletonVariant reply
 
 matchBTProperty
-  :: (MonadUnliftIO m)
-  => SysClient
-  -> ObjectPath
+  :: ( SafeClient c
+     , HasClient env
+     , MonadReader (env c) m
+     , HasLogFunc (env c)
+     , MonadUnliftIO m
+     )
+  => ObjectPath
   -> m (Maybe MatchRule)
-matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
+matchBTProperty p = matchPropertyFull btBus (Just p)
 
-addAdaptorListener
-  :: MonadUnliftIO m
-  => MutableBtState
-  -> m ()
-  -> ObjectPath
-  -> SysClient
-  -> m (Maybe SignalHandler)
-addAdaptorListener state dpy adaptor sys = do
-  rule <- matchBTProperty sys adaptor
-  forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
+-- | Start a listener that monitors changes to the powered state of an adaptor
+startAdaptorListener :: ObjectPath -> BTIO ()
+startAdaptorListener adaptor = do
+  res <- matchBTProperty adaptor
+  case res of
+    Just rule -> void $ addMatchCallback rule callback
+    Nothing -> do
+      logError $
+        "could not add listener for prop "
+          <> displayMemberName adaptorPowered
+          <> " on path "
+          <> displayObjectPath adaptor
   where
-    procMatch = withSignalMatch $ \b -> putPowered state b >> dpy
+    callback sig =
+      withNestedDBusClientConnection Nothing Nothing $
+        withSignalMatch procMatch $
+          matchPropertyChanged adaptorInterface adaptorPowered sig
+    procMatch = beforeDisplay . putPowered
 
-callGetPowered :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
+callGetPowered
+  :: ( HasClient env
+     , MonadReader (env c) m
+     , HasLogFunc (env c)
+     , SafeClient c
+     , MonadUnliftIO m
+     )
+  => ObjectPath
+  -> m [Variant]
 callGetPowered adapter =
-  callPropertyGet btBus adapter adapterInterface $
-    memberName_ $
-      T.unpack adaptorPowered
+  callPropertyGet btBus adapter adaptorInterface adaptorPowered
 
-matchPowered :: [Variant] -> SignalMatch Bool
-matchPowered = matchPropertyChanged adapterInterface adaptorPowered
+putPowered :: Maybe Bool -> BTIO ()
+putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
 
-putPowered :: MonadUnliftIO m => MutableBtState -> Maybe Bool -> m ()
-putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
+readPowered :: BTIO (Maybe Bool)
+readPowered = fmap btPowered $ readMVar =<< asks plugState
 
-readPowered :: MonadUnliftIO m => MutableBtState -> m (Maybe Bool)
-readPowered = fmap btPowered . readMVar
+adaptorInterface :: InterfaceName
+adaptorInterface = interfaceName_ "org.bluez.Adapter1"
 
-adapterInterface :: InterfaceName
-adapterInterface = interfaceName_ "org.bluez.Adapter1"
-
-adaptorPowered :: T.Text
+adaptorPowered :: MemberName
 adaptorPowered = "Powered"
 
 --------------------------------------------------------------------------------
 -- Devices
 
-addAndInitDevice
-  :: MonadUnliftIO m
-  => MutableBtState
-  -> m ()
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-addAndInitDevice state dpy device client = do
-  sh <- addDeviceListener state dpy device client
-  -- TODO add some intelligent error messages here
-  forM_ sh $ \s -> initDevice state s device client
+initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
+initDevicesState adaptor ot = do
+  let devices = findConnectedDevices adaptor ot
+  modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
 
-initDevice
-  :: MonadUnliftIO m
-  => MutableBtState
-  -> SignalHandler
-  -> ObjectPath
-  -> SysClient
-  -> m ()
-initDevice state sh device sys = do
-  reply <- callGetConnected device sys
-  void $
-    insertDevice state device $
-      BTDevice
-        { btDevConnected = fromVariant =<< listToMaybe reply
-        , btDevSigHandler = sh
-        }
-
-addDeviceListener
-  :: MonadUnliftIO m
-  => MutableBtState
-  -> m ()
-  -> ObjectPath
-  -> SysClient
-  -> m (Maybe SignalHandler)
-addDeviceListener state dpy device sys = do
-  rule <- matchBTProperty sys device
-  forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
+startConnectedListener :: ObjectPath -> BTIO ()
+startConnectedListener adaptor = do
+  reply <- matchPropertyFull btBus Nothing
+  case reply of
+    Just rule -> do
+      void $ addMatchCallbackSignal rule callback
+      logInfo $ "Started listening for device connections on " <> adaptor_
+    Nothing -> logError "Could not listen for connection changes"
   where
-    procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
-
-matchConnected :: [Variant] -> SignalMatch Bool
+    adaptor_ = displayWrapQuote $ displayObjectPath adaptor
+    callback sig =
+      withNestedDBusClientConnection Nothing Nothing $ do
+        let devpath = signalPath sig
+        when (adaptorHasDevice adaptor devpath) $
+          withSignalMatch (update devpath) $
+            matchConnected $
+              signalBody sig
     matchConnected = matchPropertyChanged devInterface devConnected
+    update _ Nothing = return ()
+    update devpath (Just x) = do
+      let f = if x then S.insert else S.delete
+      beforeDisplay $
+        modifyState $
+          \s -> return (s {btDevices = f devpath $ btDevices s}, ())
 
-callGetConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
-callGetConnected p =
-  callPropertyGet btBus p devInterface $
-    memberName_ (T.unpack devConnected)
-
-insertDevice
-  :: MonadUnliftIO m
-  => MutableBtState
-  -> ObjectPath
-  -> BTDevice
-  -> m Bool
-insertDevice m device dev = modifyMVar m $ \s -> do
-  let new = M.insert device dev $ btDevices s
-  return (s {btDevices = new}, anyDevicesConnected new)
-
-updateDevice
-  :: MonadUnliftIO m
-  => MutableBtState
-  -> ObjectPath
-  -> Maybe Bool
-  -> m Bool
-updateDevice m device status = modifyMVar m $ \s -> do
-  let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
-  return (s {btDevices = new}, anyDevicesConnected new)
-
-anyDevicesConnected :: ConnectedDevices -> Bool
-anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
-
-removeDevice
-  :: MonadUnliftIO m
-  => MutableBtState
-  -> ObjectPath
-  -> m (Maybe BTDevice)
-removeDevice m device = modifyMVar m $ \s -> do
-  let devs = btDevices s
-  return (s {btDevices = M.delete device devs}, M.lookup device devs)
-
-readDevices :: MonadUnliftIO m => MutableBtState -> m ConnectedDevices
-readDevices = fmap btDevices . readMVar
+readDevices :: BTIO (S.Set ObjectPath)
+readDevices = fmap btDevices $ readMVar =<< asks plugState
 
 devInterface :: InterfaceName
 devInterface = interfaceName_ "org.bluez.Device1"
 
-devConnected :: T.Text
+devConnected :: MemberName
 devConnected = "Connected"

lib/Xmobar/Plugins/ClevoKeyboard.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Clevo Keyboard plugin
 --
@@ -12,6 +10,7 @@ module Xmobar.Plugins.ClevoKeyboard
   )
 where
 
+import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import Xmobar
@@ -25,4 +24,9 @@ ckAlias = "clevokeyboard"
 instance Exec ClevoKeyboard where
   alias (ClevoKeyboard _) = T.unpack ckAlias
   start (ClevoKeyboard icon) =
-    startBacklight matchSignalCK callGetBrightnessCK icon
+    startBacklight
+      (Just "org.xmobar.clevo")
+      (Just "clevo_kbd.log")
+      matchSignalCK
+      callGetBrightnessCK
+      icon

lib/Xmobar/Plugins/Common.hs

@@ -1,27 +1,52 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Xmobar.Plugins.Common
   ( colorText
   , startListener
   , procSignalMatch
   , na
   , fromSingletonVariant
+  , withNestedDBusClientConnection
   , withDBusClientConnection
   , Callback
   , Colors (..)
   , displayMaybe
   , displayMaybe'
   , xmobarFGColor
+  , PluginEnv (..)
+  , PluginIO
+  , pluginDisplay
   )
 where
 
 import DBus
 import DBus.Client
 import Data.Internal.DBus
+import Data.Internal.XIO
 import RIO
 import qualified RIO.Text as T
 import XMonad.Hooks.DynamicLog (xmobarColor)
 
+data PluginEnv s c = PluginEnv
+  { plugClient :: !(NamedConnection c)
+  , plugState :: !(MVar s)
+  , plugDisplay :: !(Callback -> PluginIO s c ())
+  , plugCallback :: !Callback
+  , plugEnv :: !SimpleApp
+  }
+
+pluginDisplay :: PluginIO s c ()
+pluginDisplay = do
+  cb <- asks plugCallback
+  dpy <- asks plugDisplay
+  dpy cb
+
+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 ()
 
@@ -32,18 +57,22 @@ data Colors = Colors
   deriving (Eq, Show, Read)
 
 startListener
-  :: (MonadUnliftIO m, SafeClient c, IsVariant a)
+  :: ( HasClient env
+     , MonadReader (env c) m
+     , MonadUnliftIO m
+     , SafeClient c
+     , IsVariant a
+     )
   => MatchRule
-  -> (c -> m [Variant])
+  -> m [Variant]
   -> ([Variant] -> SignalMatch a)
   -> (a -> m T.Text)
   -> Callback
-  -> c
   -> m ()
-startListener rule getProp fromSignal toColor cb client = do
-  reply <- getProp client
+startListener rule getProp fromSignal toColor cb = do
+  reply <- getProp
   displayMaybe cb toColor $ fromSingletonVariant reply
-  void $ addMatchCallback rule (procMatch . fromSignal) client
+  void $ addMatchCallback rule (procMatch . fromSignal)
   where
     procMatch = procSignalMatch cb toColor
 
@@ -70,6 +99,42 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
 withDBusClientConnection
   :: (MonadUnliftIO m, SafeClient c)
   => Callback
-  -> (c -> m ())
+  -> Maybe BusName
+  -> Maybe FilePath
+  -> (NamedConnection c -> RIO SimpleApp ())
   -> m ()
-withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
+withDBusClientConnection cb n logfile f =
+  maybe (run stderr) (`withLogFile` run) logfile
+  where
+    run h = do
+      logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
+      withLogFunc logOpts $ \lf -> do
+        env <- mkSimpleApp lf Nothing
+        runRIO env $ displayMaybe' cb f =<< getDBusClient n
+
+-- | Run a plugin action with a new DBus client and logfile path. This is
+-- necessary for DBus callbacks which run in separate threads, which will
+-- usually fire when the parent thread already exited and killed off its DBus
+-- connection and closed its logfile. NOTE: unlike 'withDBusClientConnection'
+-- this function will open and new logfile and client connection and close both
+-- on completion. 'withDBusClientConnection' will only close the log file but
+-- keep the client connection active upon termination; this client will only be
+-- killed when the entire process is killed. This distinction is important
+-- because callbacks only need ephemeral connections, while listeners (started
+-- with 'withDBusClientConnection') need long-lasting connections.
+withNestedDBusClientConnection
+  :: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
+  => Maybe BusName
+  -> Maybe FilePath
+  -> PluginIO s c ()
+  -> m ()
+withNestedDBusClientConnection n logfile f = do
+  dpy <- asks plugDisplay
+  s <- asks plugState
+  cb <- asks plugCallback
+  let run h = do
+        logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
+        withLogFunc logOpts $ \lf -> do
+          env <- mkSimpleApp lf Nothing
+          runRIO env $ withDBusClient_ n $ \cl -> mapRIO (PluginEnv cl s dpy cb) f
+  maybe (run stderr) (`withLogFile` run) logfile

lib/Xmobar/Plugins/Device.hs

@@ -1,76 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
---------------------------------------------------------------------------------
--- Device plugin
---
--- Display different text depending on whether or not the interface has
--- connectivity
-
-module Xmobar.Plugins.Device
-  ( Device (..)
-  , devDep
-  )
-where
-
-import DBus
-import Data.Internal.DBus
-import Data.Internal.Dependency
-import RIO
-import qualified RIO.Text as T
-import XMonad.Internal.Command.Desktop
-import XMonad.Internal.DBus.Common
-import Xmobar
-import Xmobar.Plugins.Common
-
-newtype Device = Device (T.Text, T.Text, Colors) deriving (Read, Show)
-
-nmPath :: ObjectPath
-nmPath = objectPath_ "/org/freedesktop/NetworkManager"
-
-nmInterface :: InterfaceName
-nmInterface = interfaceName_ "org.freedesktop.NetworkManager"
-
-nmDeviceInterface :: InterfaceName
-nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device"
-
-getByIP :: MemberName
-getByIP = memberName_ "GetDeviceByIpIface"
-
-devSignal :: T.Text
-devSignal = "Ip4Connectivity"
-
-devDep :: DBusDependency_ SysClient
-devDep =
-  Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
-    Method_ getByIP
-
-getDevice :: MonadUnliftIO m => SysClient -> T.Text -> m (Maybe ObjectPath)
-getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
-  where
-    mc =
-      (methodCallBus networkManagerBus nmPath nmInterface getByIP)
-        { methodCallBody = [toVariant iface]
-        }
-
-getDeviceConnected :: MonadUnliftIO m => ObjectPath -> SysClient -> m [Variant]
-getDeviceConnected path =
-  callPropertyGet networkManagerBus path nmDeviceInterface $
-    memberName_ $
-      T.unpack devSignal
-
-matchStatus :: [Variant] -> SignalMatch Word32
-matchStatus = matchPropertyChanged nmDeviceInterface devSignal
-
-instance Exec Device where
-  alias (Device (iface, _, _)) = T.unpack iface
-  start (Device (iface, text, colors)) cb = do
-    withDBusClientConnection cb $ \sys -> do
-      path <- getDevice sys iface
-      displayMaybe' cb (listener sys) path
-    where
-      listener sys path = do
-        rule <- matchPropertyFull sys networkManagerBus (Just path)
-        -- TODO warn the user here rather than silently drop the listener
-        forM_ rule $ \r ->
-          startListener r (getDeviceConnected path) matchStatus chooseColor' cb sys
-      chooseColor' = return . (\s -> colorText colors s text) . (> 1)

lib/Xmobar/Plugins/IntelBacklight.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Intel backlight plugin
 --
@@ -12,6 +10,7 @@ module Xmobar.Plugins.IntelBacklight
   )
 where
 
+import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Brightness.IntelBacklight
 import Xmobar
@@ -25,4 +24,9 @@ blAlias = "intelbacklight"
 instance Exec IntelBacklight where
   alias (IntelBacklight _) = T.unpack blAlias
   start (IntelBacklight icon) =
-    startBacklight matchSignalIB callGetBrightnessIB icon
+    startBacklight
+      (Just "org.xmobar.intelbacklight")
+      (Just "intel_backlight.log")
+      matchSignalIB
+      callGetBrightnessIB
+      icon

lib/Xmobar/Plugins/Screensaver.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Screensaver plugin
 --
@@ -12,6 +10,8 @@ module Xmobar.Plugins.Screensaver
   )
 where
 
+import Data.Internal.DBus
+import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Screensaver
 import Xmobar
@@ -24,9 +24,13 @@ ssAlias = "screensaver"
 
 instance Exec Screensaver where
   alias (Screensaver _) = T.unpack ssAlias
-  start (Screensaver (text, colors)) cb = do
-    withDBusClientConnection cb $ \sys -> do
-      matchSignal display sys
-      display =<< callQuery sys
+  start (Screensaver (text, colors)) cb =
+    withDBusClientConnection
+      cb
+      (Just "org.xmobar.screensaver")
+      (Just "screensaver.log")
+      $ \cl -> withDIO cl $ do
+        matchSignal dpy
+        dpy =<< callQuery
     where
-      display = displayMaybe cb $ return . (\s -> colorText colors s text)
+      dpy = displayMaybe cb $ return . (\s -> colorText colors s text)

lib/Xmobar/Plugins/VPN.hs

@@ -1,133 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
---------------------------------------------------------------------------------
--- VPN plugin
---
--- Use the networkmanager to detect when a VPN interface is added or removed.
--- Specifically, monitor the object tree to detect paths with the interface
--- "org.freedesktop.NetworkManager.Device.Tun".
-
-module Xmobar.Plugins.VPN
-  ( VPN (..)
-  , vpnAlias
-  , vpnDep
-  )
-where
-
-import DBus
-import Data.Internal.DBus
-import Data.Internal.Dependency
-import RIO
-import qualified RIO.Map as M
-import qualified RIO.Set as S
-import qualified RIO.Text as T
-import XMonad.Internal.Command.Desktop
-import XMonad.Internal.DBus.Common
-import Xmobar
-import Xmobar.Plugins.Common
-
-newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
-
-instance Exec VPN where
-  alias (VPN _) = T.unpack vpnAlias
-  start (VPN (text, colors)) cb =
-    withDBusClientConnection cb $ \c -> do
-      state <- initState c
-      let dpy = displayMaybe cb iconFormatter . Just =<< readState state
-      let signalCallback' f = f state dpy
-      vpnAddedListener (signalCallback' addedCallback) c
-      vpnRemovedListener (signalCallback' removedCallback) c
-      dpy
-    where
-      iconFormatter b = return $ colorText colors b text
-
---------------------------------------------------------------------------------
--- VPN State
---
--- Maintain a set of paths which are the currently active VPNs. Most of the time
--- 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.
-
-type VPNState = S.Set ObjectPath
-
-type MutableVPNState = MVar VPNState
-
-initState :: MonadUnliftIO m => SysClient -> m MutableVPNState
-initState client = do
-  ot <- getVPNObjectTree client
-  newMVar $ findTunnels ot
-
-readState :: MonadUnliftIO m => MutableVPNState -> m Bool
-readState = fmap (not . null) . readMVar
-
-updateState
-  :: MonadUnliftIO m
-  => (ObjectPath -> VPNState -> VPNState)
-  -> MutableVPNState
-  -> ObjectPath
-  -> m ()
-updateState f state op = modifyMVar_ state $ return . f op
-
---------------------------------------------------------------------------------
--- Tunnel Device Detection
-
-getVPNObjectTree :: MonadUnliftIO m => SysClient -> m ObjectTree
-getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
-
-findTunnels :: ObjectTree -> VPNState
-findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
-
-vpnAddedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
-vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
-
-vpnRemovedListener :: MonadUnliftIO m => SignalCallback m -> SysClient -> m ()
-vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
-
-addedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
-addedCallback state dpy [device, added] = update >> dpy
-  where
-    added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
-    is = M.keys $ fromMaybe M.empty added'
-    update = updateDevice S.insert state device is
-addedCallback _ _ _ = return ()
-
-removedCallback :: MonadUnliftIO m => MutableVPNState -> m () -> SignalCallback m
-removedCallback state dpy [device, interfaces] = update >> dpy
-  where
-    is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
-    update = updateDevice S.delete state device is
-removedCallback _ _ _ = return ()
-
-updateDevice
-  :: MonadUnliftIO m
-  => (ObjectPath -> VPNState -> VPNState)
-  -> MutableVPNState
-  -> Variant
-  -> [T.Text]
-  -> m ()
-updateDevice f state device interfaces =
-  when (vpnDeviceTun `elem` interfaces) $
-    forM_ d $
-      updateState f state
-  where
-    d = fromVariant device :: Maybe ObjectPath
-
---------------------------------------------------------------------------------
--- DBus Interface
-
-vpnBus :: BusName
-vpnBus = busName_ "org.freedesktop.NetworkManager"
-
-vpnPath :: ObjectPath
-vpnPath = objectPath_ "/org/freedesktop"
-
-vpnDeviceTun :: T.Text
-vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
-
-vpnAlias :: T.Text
-vpnAlias = "vpn"
-
-vpnDep :: DBusDependency_ SysClient
-vpnDep =
-  Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
-    Method_ getManagedObjects

package.yaml

@@ -9,9 +9,47 @@ extra-source-files:
 - README.md
 - fourmolu.yaml
 - make_pkgs
-- icons/*
+- runtime_pkgs
+- assets/icons/*
+- assets/sound/*
 - scripts/*
-- sound/*
+
+default-extensions:
+  - OverloadedStrings
+  - FlexibleContexts
+  - FlexibleInstances
+  - InstanceSigs
+  - MultiParamTypeClasses
+  - EmptyCase
+  - LambdaCase
+  - MultiWayIf
+  - NamedFieldPuns
+  - TupleSections
+  - DeriveFoldable
+  - DeriveFunctor
+  - DeriveGeneric
+  - DeriveLift
+  - DeriveTraversable
+  - DerivingStrategies
+  - DeriveDataTypeable
+  - EmptyDataDecls
+  - PartialTypeSignatures
+  - GeneralizedNewtypeDeriving
+  - StandaloneDeriving
+  - BangPatterns
+  - TypeOperators
+  - ScopedTypeVariables
+  - TypeApplications
+  - ConstraintKinds
+  - RankNTypes
+  - GADTs
+  - DefaultSignatures
+  - NoImplicitPrelude
+  - FunctionalDependencies
+  - DataKinds
+  - TypeFamilies
+  - BinaryLiterals
+  - ViewPatterns
 
 dependencies:
   - rio >= 0.1.21.0
@@ -35,14 +73,21 @@ dependencies:
   - typed-process >= 0.2.8.0
   - network >= 3.1.2.7
   - unliftio >= 0.2.21.0
+  - optparse-applicative >= 0.16.1.0
+
+ghc-options:
+- -Wall
+- -Wcompat
+- -Widentities
+- -Wincomplete-record-updates
+- -Wincomplete-uni-patterns
+- -Wredundant-constraints
+- -Wpartial-fields
+- -Werror
+- -O2
 
 library:
   source-dirs: lib/
-  ghc-options:
-    - -Wall
-    - -Werror
-    - -Wpartial-fields
-    - -O2
 
 executables:
   xmobar: &bin
@@ -52,21 +97,15 @@ executables:
      - xmonad-config
     ghc-options:
       - -threaded
-      - -Wall
-      - -Werror
-      - -Wpartial-fields
-      - -O2
   xmonad: 
     <<: *bin
     main:                xmonad.hs
     ghc-options:
       - -threaded
-      - -Wall
-      - -Werror
-      - -Wpartial-fields
-      - -O2
       # this is needed to avoid writing super complex layout types
       - -fno-warn-missing-signatures
   vbox-start:
     <<: *bin
     main:                vbox-start.hs
+    ghc-options:
+      - -threaded

scripts/screencap

@@ -0,0 +1,22 @@
+#! /bin/bash
+
+## capture a screenshot using scrot
+
+SS_DIR="$XDG_CACHE_HOME/screenshots"
+
+while getopts ":sw" opt; do
+	case ${opt} in
+		s)
+			scrot "$SS_DIR/desktop/%Y-%m-%d-%H:%M:%S_desktop.png"
+			notify-send "Screen captured"
+			;;
+		w)
+			scrot -u "$SS_DIR/window/%Y-%m-%d-%H:%M:%S-\$wx\$h.png"
+			notify-send "Window captured"
+			;;
+		\?)
+			echo "invalid option, read the code"
+			;;
+	esac
+done
+

scripts/screenlock

@@ -0,0 +1,61 @@
+#! /bin/bash
+
+## lock the screen using i3lock (and maybe suspend)
+
+## usage: screenlock [SUSPEND]
+
+# WORKAROUND make the date show up in the right place on 2+ monitor setups
+# I want it to only show up on the primary screen, so use xrandr to get the
+# dimensions and position of the primary monitor and calculate the date position
+# from that
+geometry=$(xrandr | sed -n 's/^.*primary \([0-9]*\)x[0-9]*+\([0-9]\)*+[0-9]* .*/\1 \2/p')
+width=$(echo "$geometry" | cut -f1 -d" ")
+xpos=$(echo "$geometry" | cut -f2 -d" ")
+xoffset=$(("$xpos" + "$width" / 2))
+datepos="$xoffset:600"
+
+# lock and fork so we can suspend with the screen locked
+i3lock --color=000000 \
+       --pass-media-keys \
+       --nofork \
+       --ignore-empty-password \
+       --screen=0 \
+       --indicator \
+       --inside-color=00000055 \
+       --insidever-color=00000055 \
+       --insidewrong-color=00000055 \
+       --ring-color=555555ff \
+       --ringwrong-color=ff3333ff \
+       --ringver-color=99ceffff \
+       --keyhl-color=99ceffff \
+       --bshl-color=9523ffff \
+       --line-color=00000000 \
+       --separator-color=00000000 \
+       --clock \
+       --verif-color=99ceffff \
+       --wrong-color=ff8282ff \
+       --time-color=ffffffff \
+       --time-size=72 \
+       --time-str="%H:%M" \
+       --date-color=ffffffff \
+       --date-size=42 \
+       --date-str="%b %d, %Y" \
+       --date-align 0 \
+       --date-pos="$datepos" \
+       --wrong-size=72 \
+       --verif-size=72 \
+       --radius=300 \
+       --ring-width=25 &
+
+# suspend if we want, and if this machine is currently using a battery
+batpath=/sys/class/power_supply/BAT0/status
+
+if [ -f "$batpath" ] && \
+       [ "$(cat $batpath)" == "Discharging" ] && \
+       [ "$1" == "true" ]; then
+    systemctl suspend
+fi
+
+# block until the screen is unlocked (since xss-lock expects the locker to exit
+# only when unlocked)
+wait

stack.yaml

@@ -17,8 +17,8 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-#resolver: lts-17.4
-resolver: nightly-2022-03-03
+resolver: lts-19.33
+#resolver: nightly-2022-03-03
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.