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

bin/xmobar.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 -- | Xmobar binary
 --
 -- Features:
@@ -13,14 +11,14 @@ module Main (main) where
 
 import Data.Internal.DBus
 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 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
@@ -31,13 +29,12 @@ 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 = parse >>= xio
@@ -67,7 +64,7 @@ parseTest =
 xio :: XOpts -> IO ()
 xio o = case o of
   XDeps -> hRunXIO False stderr printDeps
-  XTest -> hRunXIO False stderr $ withDBus_ evalConfig
+  XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
   XRun -> runXIO "xmobar.log" run
 
 run :: XIO ()
@@ -79,8 +76,8 @@ run = do
   -- linebuffering it usually only prints the first few characters (even then
   -- it only prints 10-20% of the time)
   liftIO $ hSetBuffering stderr LineBuffering
-  withDBus_ $ \db -> do
-    c <- evalConfig db
+  -- TODO do these dbus things really need to remain connected?
+  c <- withDBus Nothing Nothing evalConfig
   liftIO $ xmobar c
 
 evalConfig :: DBusState -> XIO Config
@@ -92,7 +89,7 @@ evalConfig db = do
   return $ config bf ifs ios cs d
 
 printDeps :: XIO ()
-printDeps = withDBus_ $ \db ->
+printDeps = withDBus_ Nothing Nothing $ \db ->
   mapM_ logInfo $
     fmap showFulfillment $
       sort $
@@ -121,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
@@ -167,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
     }
 
@@ -222,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
@@ -238,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
@@ -260,7 +251,7 @@ getAlsa =
   where
     root useIcon = IORoot_ (alsaCmd useIcon)
 
-getBl :: Maybe SesClient -> BarFeature
+getBl :: Maybe NamedSesConnection -> BarFeature
 getBl =
   xmobarDBus
     "Intel backlight indicator"
@@ -268,7 +259,7 @@ getBl =
     intelBacklightSignalDep
     blCmd
 
-getCk :: Maybe SesClient -> BarFeature
+getCk :: Maybe NamedSesConnection -> BarFeature
 getCk =
   xmobarDBus
     "Clevo keyboard indicator"
@@ -276,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
@@ -293,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
@@ -307,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
@@ -380,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
@@ -422,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"
@@ -476,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
@@ -512,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
 
@@ -524,29 +512,6 @@ dateCmd =
     , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
     }
 
---------------------------------------------------------------------------------
--- low-level testing functions
-
-vpnPresent :: XIO (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
 --

bin/xmonad.hs

@@ -1,9 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-
 --------------------------------------------------------------------------------
 --  XMonad binary
 
@@ -27,7 +21,7 @@ import System.Process
   ( getPid
   , getProcessExitCode
   )
-import XMonad
+import XMonad hiding (display)
 import XMonad.Actions.CopyWindow
 import XMonad.Actions.CycleWS
 import XMonad.Actions.PhysicalScreens
@@ -51,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
@@ -144,21 +139,21 @@ run = do
                         , normalBorderColor = T.unpack XT.bordersColor
                         , focusedBorderColor = T.unpack XT.selectedBordersColor
                         }
-          io $ runXMonad conf
+          runXMonad conf
   where
     startDynWorkspaces fs = do
       dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
       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
 
-getCreateDirectories :: IO Directories
+getCreateDirectories :: XIO Directories
 getCreateDirectories = do
-  ds <- getDirectories
+  ds <- liftIO getDirectories
   mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
   return ds
   where
@@ -166,14 +161,14 @@ 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 :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
+  , fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
   , fsPowerMon :: SometimesIO
-  , fsRemovableMon :: Maybe SysClient -> SometimesIO
+  , fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
   , fsDaemons :: [Sometimes (XIO (Process () () ()))]
   , fsACPIHandler :: Always (String -> X ())
   , fsTabbedTheme :: Always Theme
@@ -188,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
@@ -256,7 +251,7 @@ stopChildDaemons = mapM_ stop
       liftIO $ killNoWait p
 
 printDeps :: XIO ()
-printDeps = withDBus_ $ \db -> do
+printDeps = withDBus_ Nothing Nothing $ \db -> do
   runIO <- askRunInIO
   let mockCleanup = runCleanup runIO mockClean db
   let bfs =
@@ -297,7 +292,7 @@ runCleanup runIO ts db = liftIO $ runIO $ do
   mapM_ stopXmobar $ clXmobar ts
   stopChildDaemons $ clChildren ts
   sequence_ $ clDBusUnexporters ts
-  disconnectDBusX db
+  disconnectDBus db
 
 -- | Kill a process (group) after xmonad has already started
 -- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
@@ -350,9 +345,6 @@ vmTag = "VM"
 xsaneTag :: String
 xsaneTag = "XSANE"
 
-f5Tag :: String
-f5Tag = "F5VPN"
-
 gimpDynamicWorkspace :: Sometimes DynWorkspace
 gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
   where
@@ -425,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
   ]
 
 --------------------------------------------------------------------------------
@@ -464,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"] $
@@ -856,8 +832,9 @@ externalBindings runIO cleanup 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 $ toX runAutorandrMenu
-      , KeyBinding "M-<F9>" "toggle ethernet" $ Left $ toX runToggleEthernet
+      , 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

lib/Data/Internal/DBus.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Common internal DBus functions
 
@@ -9,11 +5,17 @@ module Data.Internal.DBus
   ( SafeClient (..)
   , SysClient (..)
   , SesClient (..)
+  , NamedConnection (..)
+  , NamedSesConnection
+  , NamedSysConnection
   , DBusEnv (..)
   , DIO
   , HasClient (..)
+  , releaseBusName
   , withDIO
   , addMatchCallback
+  , addMatchCallbackSignal
+  , matchSignalFull
   , matchProperty
   , matchPropertyFull
   , matchPropertyChanged
@@ -39,6 +41,10 @@ module Data.Internal.DBus
   , displayMemberName
   , displayInterfaceName
   , displayWrapQuote
+  , busNameT
+  , interfaceNameT
+  , memberNameT
+  , objectPathT
   )
 where
 
@@ -53,48 +59,129 @@ import qualified RIO.Text as T
 --------------------------------------------------------------------------------
 -- Type-safe client
 
-class SafeClient c where
-  toClient :: c -> 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
   getDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => m (Maybe c)
+    => Maybe BusName
+    -> m (Maybe (NamedConnection c))
 
-  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
-  disconnectDBusClient = liftIO . disconnect . toClient
+  disconnectDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => NamedConnection c
+    -> m ()
+  disconnectDBusClient c = do
+    releaseBusName c
+    liftIO $ disconnect $ ncClient c
 
   withDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => (c -> m a)
+    => Maybe BusName
+    -> (NamedConnection c -> m a)
     -> m (Maybe a)
-  withDBusClient f =
-    bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
+  withDBusClient n f =
+    bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
 
   withDBusClient_
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => (c -> m ())
+    => Maybe BusName
+    -> (NamedConnection c -> m ())
     -> m ()
-  withDBusClient_ = void . withDBusClient
+  withDBusClient_ n = void . withDBusClient n
 
   fromDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => (c -> a)
+    => Maybe BusName
+    -> (NamedConnection c -> a)
     -> m (Maybe a)
-  fromDBusClient f = withDBusClient (return . f)
+  fromDBusClient n f = withDBusClient n (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
+                }
+
+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)
@@ -108,19 +195,28 @@ getDBusClient' sys = do
       return Nothing
     Right c -> return $ Just c
 
-data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env}
+--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 SafeClient c => HasLogFunc (DBusEnv SimpleApp c) where
+instance HasLogFunc (DBusEnv SimpleApp c) where
   logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
 
 withDIO
-  :: (MonadUnliftIO m, MonadReader env m, SafeClient c)
-  => c
+  :: (MonadUnliftIO m, MonadReader env m)
+  => NamedConnection c
   -> DIO env c a
   -> m a
 withDIO cl x = do
@@ -128,7 +224,7 @@ withDIO cl x = do
   runRIO (DBusEnv cl env) x
 
 class HasClient env where
-  clientL :: SafeClient c => Lens' (env c) c
+  clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
 
 --------------------------------------------------------------------------------
 -- Methods
@@ -140,7 +236,7 @@ callMethod'
   => MethodCall
   -> m MethodBody
 callMethod' mc = do
-  cl <- toClient <$> view clientL
+  cl <- ncClient <$> view clientL
   liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
 
 callMethod
@@ -202,9 +298,21 @@ 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
   :: ( MonadReader (env c) m
-     , HasLogFunc (env c)
      , MonadUnliftIO m
      , SafeClient c
      , HasClient env
@@ -212,10 +320,7 @@ addMatchCallback
   => MatchRule
   -> SignalCallback m
   -> m SignalHandler
-addMatchCallback rule cb = do
-  cl <- toClient <$> view clientL
-  withRunInIO $ \run -> do
-    addMatch cl rule $ run . cb . signalBody
+addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
 
 matchSignal
   :: Maybe BusName
@@ -284,7 +389,7 @@ callPropertyGet
   -> MemberName
   -> m [Variant]
 callPropertyGet bus path iface property = do
-  cl <- toClient <$> view clientL
+  cl <- ncClient <$> view clientL
   res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
   case res of
     Left err -> do
@@ -319,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"
@@ -368,7 +473,11 @@ callGetManagedObjects bus path = do
     Left err -> do
       logError $ Utf8Builder $ encodeUtf8Builder err
       return M.empty
-    Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
+    Right v ->
+      return $
+        fmap (M.mapKeys interfaceName_) $
+          fromMaybe M.empty $
+            fromSingletonVariant v
 
 addInterfaceChangedListener
   :: ( MonadReader (env c) m
@@ -432,14 +541,14 @@ addInterfaceRemovedListener bus =
 -- Interface export/unexport
 
 exportPair
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => ObjectPath
   -> (Client -> m Interface)
-  -> c
+  -> NamedConnection c
   -> (m (), m ())
 exportPair path toIface cl = (up, down)
   where
-    cl_ = toClient cl
+    cl_ = ncClient cl
     up = do
       logInfo $ "adding interface: " <> path_
       i <- toIface cl_
@@ -452,6 +561,18 @@ exportPair path toIface cl = (up, down)
 --------------------------------------------------------------------------------
 -- 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
 

lib/Data/Internal/XIO.hs

@@ -1,12 +1,3 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 --------------------------------------------------------------------------------
 -- Functions for handling dependencies
 
@@ -109,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)
@@ -140,9 +132,9 @@ runXIO logfile x = withLogFile logfile $ \h -> hRunXIO True h x
 withLogFile :: MonadUnliftIO m => FilePath -> (Handle -> m a) -> m a
 withLogFile logfile f = do
   p <- (</> logfile) . dataDir <$> liftIO getDirectories
-  catchIO (withFile p AppendMode f) $ \e -> do
-    liftIO $ print e
-    liftIO $ putStrLn "could not open log file, falling back to stderr"
+  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
@@ -296,8 +288,18 @@ 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
@@ -425,7 +427,7 @@ data XEnv = XEnv
 instance HasLogFunc XEnv where
   logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
 
-instance SafeClient c => HasLogFunc (DBusEnv XEnv c) where
+instance HasLogFunc (DBusEnv XEnv c) where
   logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
 
 instance HasProcessContext XEnv where
@@ -466,7 +468,8 @@ data XPFeatures = XPFeatures
   , xpfIntelBacklight :: Bool
   , xpfClevoBacklight :: Bool
   , xpfBattery :: Bool
-  , xpfF5VPN :: Bool
+  , xpfEthPrefix :: Maybe Text
+  , xpfWifiPrefix :: Maybe Text
   }
 
 instance FromJSON XPFeatures where
@@ -493,7 +496,9 @@ instance FromJSON XPFeatures where
       <*> o
       .:+ "battery"
       <*> o
-      .:+ "f5vpn"
+      .:? "ethPrefix"
+      <*> o
+      .:? "wifiPrefix"
 
 defParams :: XParams
 defParams =
@@ -516,7 +521,8 @@ defXPFeatures =
     , xpfIntelBacklight = False
     , xpfClevoBacklight = False
     , xpfBattery = False
-    , xpfF5VPN = False
+    , xpfEthPrefix = Nothing
+    , xpfWifiPrefix = Nothing
     }
 
 type XPQuery = XPFeatures -> Bool
@@ -527,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)
@@ -827,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 =
@@ -848,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
@@ -888,10 +895,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
-testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
+testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
 testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
 
-testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
+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
@@ -1022,11 +1029,11 @@ 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
 
@@ -1040,7 +1047,7 @@ 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

lib/XMonad/Internal/Command/DMenu.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Dmenu (Rofi) Commands
 
@@ -148,7 +146,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 runWinMenu :: MonadUnliftIO m => Sometimes (m ())
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
-runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
+runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
 runNetMenu cl =
   Sometimes
     "network control menu"
@@ -173,7 +171,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
 --------------------------------------------------------------------------------
 -- Password manager
 
-runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
   where
     cmd _ =
@@ -210,7 +208,7 @@ runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
 -- Shortcut menu
 
 runShowKeys
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  :: (MonadReader env m, MonadUnliftIO m)
   => Always ([((KeyMask, KeySym), NamedAction)] -> m ())
 runShowKeys =
   Always "keyboard menu" $
@@ -225,7 +223,7 @@ runShowKeys =
           defNoteError {body = Just $ Text "could not display keymap"}
 
 showKeysDMenu
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  :: (MonadReader env m, MonadUnliftIO m)
   => SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
 showKeysDMenu =
   Subfeature
@@ -234,7 +232,7 @@ showKeysDMenu =
     }
 
 showKeys
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  :: (MonadReader env m, MonadUnliftIO m)
   => [((KeyMask, KeySym), NamedAction)]
   -> m ()
 showKeys kbs = do

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
@@ -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
 
@@ -120,7 +121,7 @@ volumeChangeSound = "smb_fireball.wav"
 -- Some nice apps
 
 runTerm :: MonadUnliftIO m => Sometimes (m ())
-runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
+runTerm = sometimesExe "terminal" "alacritty" myTermPkgs True myTerm
 
 runTMux :: MonadUnliftIO m => Sometimes (m ())
 runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
@@ -208,7 +209,7 @@ runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
 -- Volume Commands
 
 soundDir :: FilePath
-soundDir = "sound"
+soundDir = "assets" </> "sound"
 
 playSound :: MonadIO m => FilePath -> m ()
 playSound file = do
@@ -248,7 +249,7 @@ runNotificationCmd
   :: MonadUnliftIO m
   => T.Text
   -> T.Text
-  -> Maybe SesClient
+  -> Maybe NamedSesConnection
   -> Sometimes (m ())
 runNotificationCmd n arg cl =
   sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
@@ -260,37 +261,37 @@ runNotificationCmd n arg cl =
           Method_ $
             memberName_ "NotificationAction"
 
-runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationClose = runNotificationCmd "close notification" "close"
 
-runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationCloseAll =
   runNotificationCmd "close all notifications" "close-all"
 
-runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationHistory =
   runNotificationCmd "see notification history" "history-pop"
 
-runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+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 (XIO (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 :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
+runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
 runToggleBluetooth cl =
   Sometimes
     "bluetooth toggle"
@@ -307,27 +308,35 @@ runToggleBluetooth cl =
           #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
           #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
 
-runToggleEthernet :: MonadUnliftIO m => Sometimes (m ())
-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
@@ -368,7 +377,7 @@ runFlameshot
   :: MonadUnliftIO m
   => T.Text
   -> T.Text
-  -> Maybe SesClient
+  -> Maybe NamedSesConnection
   -> Sometimes (m ())
 runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
   where
@@ -380,15 +389,15 @@ 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 :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
-runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runScreenCapture = runFlameshot "screen capture" "screen"
 
 runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())

lib/XMonad/Internal/Command/Power.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Commands for controlling power
 
@@ -91,7 +89,8 @@ runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
       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
@@ -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 -> liftIO runPowerOff
-      Shutdown -> lock >> liftIO runSuspend
-      Hibernate -> lock >> liftIO runHibernate
-      Reboot -> liftIO 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
 
@@ -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,7 +91,7 @@ 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

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

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Automatically Manage Dynamic Workspaces
 -- This is a somewhat convoluted wrapper for the Dymamic Workspaces module

lib/XMonad/Internal/Concurrent/VirtualBox.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 --------------------------------------------------------------------------------
 -- VirtualBox-specific functions
 
@@ -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,6 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- DBus module for Clevo Keyboard control
 
@@ -120,7 +117,7 @@ clevoKeyboardSignalDep =
 
 exportClevoKeyboard
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> Sometimes (m (), m ())
 exportClevoKeyboard =
   brightnessExporter
@@ -131,7 +128,7 @@ exportClevoKeyboard =
 
 clevoKeyboardControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> BrightnessControls m
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
 
@@ -142,7 +139,6 @@ callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
 
 matchSignalCK
   :: ( SafeClient c
-     , HasLogFunc (env c)
      , HasClient env
      , MonadReader (env c) m
      , MonadUnliftIO m

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

@@ -1,7 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-
 --------------------------------------------------------------------------------
 -- DBus module for DBus brightness controls
 
@@ -57,7 +53,7 @@ brightnessControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
   => XPQuery
   -> BrightnessConfig m a b
-  -> Maybe SesClient
+  -> Maybe NamedSesConnection
   -> BrightnessControls m
 brightnessControls q bc cl =
   BrightnessControls
@@ -80,15 +76,14 @@ callGetBrightness
   -> m (Maybe n)
 callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
   either (const Nothing) bodyGetBrightness
-    <$> callMethod xmonadBusName p i memGet
+    <$> callMethod xmonadSesBusName p i memGet
 
-signalDep :: BrightnessConfig m 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
   :: ( HasClient env
-     , HasLogFunc (env c)
      , MonadReader (env c) m
      , MonadUnliftIO m
      , SafeClient c
@@ -117,18 +112,18 @@ brightnessExporter
   -> [Fulfillment]
   -> [IODependency_]
   -> BrightnessConfig m a b
-  -> Maybe SesClient
+  -> 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_ (exportBrightnessControlsInner bc) tree cl
-    tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
+    tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
 
 exportBrightnessControlsInner
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
   => BrightnessConfig m a b
-  -> SesClient
+  -> NamedSesConnection
   -> (m (), m ())
 exportBrightnessControlsInner bc = cmd
   where
@@ -177,7 +172,7 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
 callBacklight
   :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
   => XPQuery
-  -> Maybe SesClient
+  -> Maybe NamedSesConnection
   -> BrightnessConfig m a b
   -> T.Text
   -> MemberName
@@ -185,8 +180,8 @@ callBacklight
 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 = void $ withDIO c $ callMethod 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,6 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- DBus module for Intel Backlight control
 
@@ -106,7 +103,7 @@ intelBacklightSignalDep =
 
 exportIntelBacklight
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> Sometimes (m (), m ())
 exportIntelBacklight =
   brightnessExporter
@@ -117,7 +114,7 @@ exportIntelBacklight =
 
 intelBacklightControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> BrightnessControls m
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 
@@ -128,7 +125,6 @@ callGetBrightnessIB = callGetBrightness intelBacklightConfig
 
 matchSignalIB
   :: ( SafeClient c
-     , HasLogFunc (env c)
      , HasClient env
      , MonadReader (env c) m
      , MonadUnliftIO m

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,6 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 --------------------------------------------------------------------------------
 -- High-level interface for managing XMonad's DBus
 
@@ -13,9 +10,8 @@ module XMonad.Internal.DBus.Control
   , withDBus
   , withDBus_
   , connectDBus
-  , connectDBusX
   , disconnectDBus
-  , disconnectDBusX
+  -- , disconnectDBusX
   , getDBusClient
   , withDBusClient
   , withDBusClient_
@@ -29,7 +25,6 @@ import DBus.Client
 import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
-import qualified RIO.Text as T
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import XMonad.Internal.DBus.Brightness.IntelBacklight
 import XMonad.Internal.DBus.Common
@@ -37,8 +32,8 @@ 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_
@@ -50,59 +45,79 @@ withDBusX_ = void . withDBusX
 withDBusX
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => (DBusState -> m a)
-  -> m (Maybe a)
-withDBusX f = withDBus $ \db -> do
-  forM (dbSesClient db) $ \ses -> do
-    bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
+  -> m a
+withDBusX = withDBus (Just xmonadSesBusName) Nothing
 
 withDBus_
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => (DBusState -> m a)
+  => Maybe BusName
+  -> Maybe BusName
+  -> (DBusState -> m a)
   -> m ()
-withDBus_ = void . withDBus
+withDBus_ sesname sysname = void . withDBus sesname sysname
 
 withDBus
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => (DBusState -> m a)
+  => Maybe BusName
+  -> Maybe BusName
+  -> (DBusState -> m a)
   -> m a
-withDBus = bracket connectDBus disconnectDBus
+withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
 
 -- | Connect to the DBus
 connectDBus
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => m DBusState
-connectDBus = do
-  ses <- getDBusClient
-  sys <- getDBusClient
+  => 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 db = disc dbSesClient >> disc dbSysClient
-  where
-    disc f = maybe (return ()) disconnectDBusClient $ f db
-
--- | Connect to the DBus and request the XMonad name
-connectDBusX
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => m DBusState
-connectDBusX = do
-  db <- connectDBus
-  forM_ (dbSesClient db) requestXMonadName
-  return db
-
--- | Disconnect from DBus and release the XMonad name
-disconnectDBusX
+disconnectDBus
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => DBusState
   -> m ()
-disconnectDBusX db = do
-  forM_ (dbSesClient db) releaseXMonadName
-  disconnectDBus db
+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
+--   :: (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
+--   :: (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 SesClient -> Sometimes (XIO (), XIO ())]
+  -> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
   -> ([XIO ()] -> XIO a)
   -> XIO a
 withDBusInterfaces db interfaces = bracket up sequence
@@ -115,35 +130,59 @@ withDBusInterfaces db interfaces = bracket up sequence
 -- | All exporter features to be assigned to the DBus
 dbusExporters
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => [Maybe SesClient -> Sometimes (m (), m ())]
+  => [Maybe NamedSesConnection -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
-releaseXMonadName
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => SesClient
-  -> m ()
-releaseXMonadName ses = do
-  -- TODO this might error?
-  liftIO $ void $ releaseName (toClient ses) xmonadBusName
-  logInfo "released xmonad name"
+-- 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
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => SesClient
-  -> m ()
-requestXMonadName ses = do
-  res <- liftIO $ requestName (toClient ses) 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 <> ": " <> xn
-  where
-    xn =
-      Utf8Builder $
-        encodeUtf8Builder $
-          T.pack $
-            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,6 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- Module for monitoring removable drive events
 --
@@ -83,11 +80,10 @@ playSoundMaybe p b = when b $ io $ playSound p
 -- enable the udisks2 service at boot; however this is not default behavior.
 listenDevices
   :: ( HasClient (DBusEnv env)
-     , HasLogFunc (DBusEnv env SysClient)
      , MonadReader env m
      , MonadUnliftIO m
      )
-  => SysClient
+  => NamedSysConnection
   -> m ()
 listenDevices cl = do
   addMatch' memAdded driveInsertedSound addedHasDrive
@@ -99,11 +95,10 @@ listenDevices cl = do
 
 runRemovableMon
   :: ( HasClient (DBusEnv env)
-     , HasLogFunc (DBusEnv env SysClient)
      , MonadReader env m
      , MonadUnliftIO m
      )
-  => Maybe SysClient
+  => Maybe NamedSysConnection
   -> Sometimes (m ())
 runRemovableMon cl =
   sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- DBus module for X11 screensave/DPMS control
 
@@ -96,7 +93,7 @@ bodyGetCurrentState _ = Nothing
 
 exportScreensaver
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> Sometimes (m (), m ())
 exportScreensaver ses =
   sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
@@ -122,19 +119,19 @@ exportScreensaver ses =
                 }
             ]
         }
-    bus = Bus [] xmonadBusName
+    bus = Bus [] xmonadSesBusName
     ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
 
 callToggle
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> Sometimes (m ())
 callToggle =
   sometimesEndpoint
     "screensaver toggle"
     "dbus switch"
     []
-    xmonadBusName
+    xmonadSesBusName
     ssPath
     interface
     memToggle
@@ -143,12 +140,11 @@ callQuery
   :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
   => m (Maybe SSState)
 callQuery = do
-  reply <- callMethod xmonadBusName ssPath interface memQuery
+  reply <- callMethod xmonadSesBusName ssPath interface memQuery
   return $ either (const Nothing) bodyGetCurrentState reply
 
 matchSignal
-  :: ( HasLogFunc (env SesClient)
-     , HasClient env
+  :: ( HasClient env
      , MonadReader (env SesClient) m
      , MonadUnliftIO m
      )
@@ -161,4 +157,4 @@ matchSignal cb =
       (cb . bodyGetCurrentState)
 
 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)
 

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,10 +83,7 @@ spawn :: MonadIO m => T.Text -> m ()
 spawn = X.spawn . T.unpack
 
 -- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
-spawnPipe
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => T.Text
-  -> m Handle
+spawnPipe :: MonadUnliftIO m => T.Text -> m Handle
 spawnPipe = liftIO . XR.spawnPipe . T.unpack
 
 -- spawnPipeRW

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,14 +12,15 @@ import Xmobar.Plugins.Common
 
 startBacklight
   :: (MonadUnliftIO m, RealFrac a)
-  => Maybe FilePath
+  => Maybe BusName
+  -> Maybe FilePath
   -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
   -> DIO SimpleApp SesClient (Maybe a)
   -> T.Text
   -> Callback
   -> m ()
-startBacklight name matchSignal callGetBrightness icon cb = do
-  withDBusClientConnection cb name $ \c -> withDIO c $ do
+startBacklight n name matchSignal callGetBrightness icon cb = do
+  withDBusClientConnection cb n name $ \c -> withDIO c $ do
     matchSignal dpy
     dpy =<< callGetBrightness
   where

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 (..)
@@ -47,6 +35,7 @@ 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,32 +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 (Just "bluetooth.log") $ startAdapter icons colors cb
+    withDBusClientConnection cb Nothing (Just "bluetooth.log") $
+      startAdapter icons colors cb
 
 startAdapter
   :: Icons
   -> Colors
   -> Callback
-  -> SysClient
+  -> NamedSysConnection
   -> RIO SimpleApp ()
 startAdapter is cs cb cl = do
   state <- newMVar emptyState
-  let dpy = displayIcon cb (iconFormatter is cs)
-  mapRIO (BTEnv cl state dpy) $ do
+  let dpy cb' = displayIcon cb' (iconFormatter is cs)
+  mapRIO (PluginEnv cl state dpy cb) $ do
     ot <- getBtObjectTree
-    case findAdapter ot of
+    case findAdaptor ot of
       Nothing -> logError "could not find bluetooth adapter"
-      Just adapter -> do
-        -- set up adapter
-        initAdapter adapter
-        void $ addAdaptorListener adapter
-        -- set up devices on the adapter (and listeners for adding/removing devices)
-        let devices = findDevices adapter ot
-        addDeviceAddedListener adapter
-        addDeviceRemovedListener adapter
-        forM_ devices $ \d -> addAndInitDevice d
-        -- after setting things up, show the icon based on the initialized state
-        dpy
+      Just adaptor -> do
+        initAdapterState adaptor
+        initDevicesState adaptor ot
+        startAdaptorListener adaptor
+        startConnectedListener adaptor
+        pluginDisplay
 
 --------------------------------------------------------------------------------
 -- Icon Display
@@ -115,43 +100,18 @@ 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 BTEnv c = BTEnv
-  { btClient :: !c
-  , btState :: !(MVar BtState)
-  , btDisplay :: !(BTIO ())
-  , btEnv :: !SimpleApp
-  }
-
-instance HasClient BTEnv where
-  clientL = lens btClient (\x y -> x {btClient = y})
-
-instance HasLogFunc (BTEnv a) where
-  logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
-
-type BTIO = RIO (BTEnv SysClient)
-
-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
   }
 
 emptyState :: BtState
 emptyState =
   BtState
-    { btDevices = M.empty
+    { btDevices = S.empty
     , btPowered = Nothing
     }
 
@@ -159,24 +119,33 @@ readState :: BTIO (Maybe Bool, Bool)
 readState = do
   p <- readPowered
   c <- readDevices
-  return (p, anyDevicesConnected c)
+  return (p, not $ null c)
 
 modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
 modifyState f = do
-  m <- asks btState
+  m <- asks plugState
   modifyMVar m f
 
 beforeDisplay :: BTIO () -> BTIO ()
-beforeDisplay f = f >> join (asks btDisplay)
+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
@@ -199,49 +168,14 @@ getBtObjectTree = callGetManagedObjects btBus btOMPath
 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"
 
-addBtOMListener
-  :: ( HasClient env
-     , SafeClient c
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => SignalCallback m
-  -> m ()
-addBtOMListener sc = void $ addInterfaceAddedListener btBus btOMPath sc
-
-addDeviceAddedListener :: ObjectPath -> BTIO ()
-addDeviceAddedListener adapter = addBtOMListener addDevice
-  where
-    addDevice = pathCallback adapter $ \d ->
-      addAndInitDevice d
-
-addDeviceRemovedListener :: ObjectPath -> BTIO ()
-addDeviceRemovedListener adapter =
-  addBtOMListener remDevice
-  where
-    remDevice = pathCallback adapter $ \d -> do
-      old <- removeDevice d
-      cl <- asks btClient
-      forM_ old $ liftIO . removeMatch (toClient cl) . btDevSigHandler
-
-pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
-pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
-  when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
-pathCallback _ _ _ = return ()
-
 --------------------------------------------------------------------------------
 -- Adapter
 
-initAdapter :: ObjectPath -> BTIO ()
-initAdapter adapter = do
+-- | Get powered state of adaptor and log the result
+initAdapterState :: ObjectPath -> BTIO ()
+initAdapterState adapter = do
   reply <- callGetPowered adapter
-  logInfo $ "initializing adapter at path " <> adapter_
-  -- TODO this could fail if the variant is something weird; the only
-  -- indication I will get is "NA"
   putPowered $ fromSingletonVariant reply
-  where
-    adapter_ = displayWrapQuote $ displayObjectPath adapter
 
 matchBTProperty
   :: ( SafeClient c
@@ -254,40 +188,23 @@ matchBTProperty
   -> m (Maybe MatchRule)
 matchBTProperty p = matchPropertyFull btBus (Just p)
 
-withBTPropertyRule
-  :: ( SafeClient c
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , HasClient env
-     , MonadUnliftIO m
-     , IsVariant a
-     )
-  => ObjectPath
-  -> (Maybe a -> m ())
-  -> InterfaceName
-  -> T.Text
-  -> m (Maybe SignalHandler)
-withBTPropertyRule path update iface prop = do
-  res <- matchBTProperty path
+-- | 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 -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected)
+    Just rule -> void $ addMatchCallback rule callback
     Nothing -> do
       logError $
         "could not add listener for prop "
-          <> prop_
+          <> displayMemberName adaptorPowered
           <> " on path "
-          <> path_
-      return Nothing
-  where
-    path_ = displayObjectPath path
-    prop_ = Utf8Builder $ encodeUtf8Builder prop
-    signalToUpdate = withSignalMatch update
-    matchConnected = matchPropertyChanged iface prop
-
-addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler)
-addAdaptorListener adaptor =
-  withBTPropertyRule adaptor procMatch adapterInterface adaptorPowered
+          <> displayObjectPath adaptor
   where
+    callback sig =
+      withNestedDBusClientConnection Nothing Nothing $
+        withSignalMatch procMatch $
+          matchPropertyChanged adaptorInterface adaptorPowered sig
     procMatch = beforeDisplay . putPowered
 
 callGetPowered
@@ -300,88 +217,58 @@ callGetPowered
   => ObjectPath
   -> m [Variant]
 callGetPowered adapter =
-  callPropertyGet btBus adapter adapterInterface $
-    memberName_ $
-      T.unpack adaptorPowered
+  callPropertyGet btBus adapter adaptorInterface adaptorPowered
 
 putPowered :: Maybe Bool -> BTIO ()
 putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
 
 readPowered :: BTIO (Maybe Bool)
-readPowered = fmap btPowered $ readMVar =<< asks btState
+readPowered = fmap btPowered $ readMVar =<< asks plugState
 
-adapterInterface :: InterfaceName
-adapterInterface = interfaceName_ "org.bluez.Adapter1"
+adaptorInterface :: InterfaceName
+adaptorInterface = interfaceName_ "org.bluez.Adapter1"
 
-adaptorPowered :: T.Text
+adaptorPowered :: MemberName
 adaptorPowered = "Powered"
 
 --------------------------------------------------------------------------------
 -- Devices
 
-addAndInitDevice :: ObjectPath -> BTIO ()
-addAndInitDevice device = do
-  res <- addDeviceListener device
-  case res of
-    Just handler -> do
-      logInfo $ "initializing device at path " <> device_
-      initDevice handler device
-    Nothing -> logError $ "could not initialize device at path " <> device_
+initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
+initDevicesState adaptor ot = do
+  let devices = findConnectedDevices adaptor ot
+  modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
+
+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
-    device_ = displayWrapQuote $ displayObjectPath device
+    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}, ())
 
-initDevice :: SignalHandler -> ObjectPath -> BTIO ()
-initDevice sh device = do
-  reply <- callGetConnected device
-  void $
-    insertDevice device $
-      BTDevice
-        { btDevConnected = fromVariant =<< listToMaybe reply
-        , btDevSigHandler = sh
-        }
-
-addDeviceListener :: ObjectPath -> BTIO (Maybe SignalHandler)
-addDeviceListener device =
-  withBTPropertyRule device procMatch devInterface devConnected
-  where
-    procMatch = beforeDisplay . void . updateDevice device
-
-callGetConnected
-  :: ( SafeClient c
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => ObjectPath
-  -> m [Variant]
-callGetConnected p =
-  callPropertyGet btBus p devInterface $
-    memberName_ (T.unpack devConnected)
-
-insertDevice :: ObjectPath -> BTDevice -> BTIO Bool
-insertDevice device dev = modifyState $ \s -> do
-  let new = M.insert device dev $ btDevices s
-  return (s {btDevices = new}, anyDevicesConnected new)
-
-updateDevice :: ObjectPath -> Maybe Bool -> BTIO Bool
-updateDevice device status = modifyState $ \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 :: ObjectPath -> BTIO (Maybe BTDevice)
-removeDevice device = modifyState $ \s -> do
-  let devs = btDevices s
-  return (s {btDevices = M.delete device devs}, M.lookup device devs)
-
-readDevices :: BTIO ConnectedDevices
-readDevices = fmap btDevices $ readMVar =<< asks btState
+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 (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon
+    startBacklight
+      (Just "org.xmobar.clevo")
+      (Just "clevo_kbd.log")
+      matchSignalCK
+      callGetBrightnessCK
+      icon

lib/Xmobar/Plugins/Common.hs

@@ -1,17 +1,19 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Xmobar.Plugins.Common
   ( colorText
   , startListener
   , procSignalMatch
   , na
   , fromSingletonVariant
+  , withNestedDBusClientConnection
   , withDBusClientConnection
   , Callback
   , Colors (..)
   , displayMaybe
   , displayMaybe'
   , xmobarFGColor
+  , PluginEnv (..)
+  , PluginIO
+  , pluginDisplay
   )
 where
 
@@ -23,6 +25,28 @@ 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 ()
 
@@ -33,8 +57,7 @@ data Colors = Colors
   deriving (Eq, Show, Read)
 
 startListener
-  :: ( HasLogFunc (env c)
-     , HasClient env
+  :: ( HasClient env
      , MonadReader (env c) m
      , MonadUnliftIO m
      , SafeClient c
@@ -76,14 +99,42 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
 withDBusClientConnection
   :: (MonadUnliftIO m, SafeClient c)
   => Callback
+  -> Maybe BusName
   -> Maybe FilePath
-  -> (c -> RIO SimpleApp ())
+  -> (NamedConnection c -> RIO SimpleApp ())
   -> m ()
-withDBusClientConnection cb logfile f =
+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
+        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,89 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
---------------------------------------------------------------------------------
--- 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.XIO
-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
-  :: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
-  => T.Text
-  -> m (Maybe ObjectPath)
-getDevice iface = bodyToMaybe <$> callMethod' mc
-  where
-    mc =
-      (methodCallBus networkManagerBus nmPath nmInterface getByIP)
-        { methodCallBody = [toVariant iface]
-        }
-
-getDeviceConnected
-  :: ( SafeClient c
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => ObjectPath
-  -> 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 =
-    withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do
-      path <- getDevice iface
-      displayMaybe' cb listener path
-    where
-      logName = Just $ T.unpack $ T.concat ["device@", iface, ".log"]
-      listener path = do
-        res <- matchPropertyFull networkManagerBus (Just path)
-        case res of
-          Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb
-          Nothing -> logError "could not start listener"
-      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 (Just "intel_backlight.log") 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
 --
@@ -13,6 +11,7 @@ module Xmobar.Plugins.Screensaver
 where
 
 import Data.Internal.DBus
+import RIO
 import qualified RIO.Text as T
 import XMonad.Internal.DBus.Screensaver
 import Xmobar
@@ -26,7 +25,11 @@ ssAlias = "screensaver"
 instance Exec Screensaver where
   alias (Screensaver _) = T.unpack ssAlias
   start (Screensaver (text, colors)) cb =
-    withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do
+    withDBusClientConnection
+      cb
+      (Just "org.xmobar.screensaver")
+      (Just "screensaver.log")
+      $ \cl -> withDIO cl $ do
         matchSignal dpy
         dpy =<< callQuery
     where

lib/Xmobar/Plugins/VPN.hs

@@ -1,173 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# 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.XIO
-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 (Just "vpn.log") $ \c -> do
-      let dpy = displayMaybe cb iconFormatter . Just =<< readState
-      s <- newEmptyMVar
-      mapRIO (VEnv c s dpy) $ do
-        initState
-        vpnAddedListener addedCallback
-        vpnRemovedListener removedCallback
-        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.
-
-data VEnv c = VEnv
-  { vClient :: !c
-  , vState :: !(MVar VPNState)
-  , vDisplay :: !(VIO ())
-  , vEnv :: !SimpleApp
-  }
-
-instance SafeClient c => HasLogFunc (VEnv c) where
-  logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
-
-instance HasClient VEnv where
-  clientL = lens vClient (\x y -> x {vClient = y})
-
-type VIO = RIO (VEnv SysClient)
-
-type VPNState = S.Set ObjectPath
-
-initState :: VIO ()
-initState = do
-  ot <- getVPNObjectTree
-  s <- asks vState
-  putMVar s $ findTunnels ot
-
-readState :: VIO Bool
-readState = fmap (not . null) . readMVar =<< asks vState
-
-updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
-updateState f op = do
-  s <- asks vState
-  modifyMVar_ s $ return . f op
-
-beforeDisplay :: VIO () -> VIO ()
-beforeDisplay f = f >> join (asks vDisplay)
-
---------------------------------------------------------------------------------
--- Tunnel Device Detection
-
-getVPNObjectTree
-  :: ( SafeClient c
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => m ObjectTree
-getVPNObjectTree = callGetManagedObjects vpnBus vpnPath
-
-findTunnels :: ObjectTree -> VPNState
-findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
-
-vpnAddedListener
-  :: ( SafeClient c
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => SignalCallback m
-  -> m ()
-vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb
-
-vpnRemovedListener
-  :: ( SafeClient c
-     , HasClient env
-     , MonadReader (env c) m
-     , HasLogFunc (env c)
-     , MonadUnliftIO m
-     )
-  => SignalCallback m
-  -> m ()
-vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
-
-addedCallback :: SignalCallback VIO
-addedCallback [device, added] =
-  beforeDisplay $
-    updateDevice S.insert device $
-      M.keys $
-        fromMaybe M.empty added'
-  where
-    added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
-addedCallback _ = return ()
-
-removedCallback :: SignalCallback VIO
-removedCallback [device, interfaces] =
-  beforeDisplay $
-    updateDevice S.delete device $
-      fromMaybe [] $
-        fromVariant interfaces
-removedCallback _ = return ()
-
-updateDevice
-  :: (ObjectPath -> VPNState -> VPNState)
-  -> Variant
-  -> [T.Text]
-  -> VIO ()
-updateDevice f device interfaces =
-  when (vpnDeviceTun `elem` interfaces) $
-    forM_ d $
-      updateState f
-  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
@@ -37,14 +75,20 @@ dependencies:
   - unliftio >= 0.2.21.0
   - optparse-applicative >= 0.16.1.0
 
-library:
-  source-dirs: lib/
 ghc-options:
 - -Wall
-    - -Werror
+- -Wcompat
+- -Widentities
+- -Wincomplete-record-updates
+- -Wincomplete-uni-patterns
+- -Wredundant-constraints
 - -Wpartial-fields
+- -Werror
 - -O2
 
+library:
+  source-dirs: lib/
+
 executables:
   xmobar: &bin
     main:                xmobar.hs
@@ -53,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.