bin/vbox-start.hs

@@ -1,3 +1,6 @@
+{-# 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,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- | Xmobar binary
 --
 -- Features:
@@ -11,14 +13,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 RIO.FilePath
+import qualified RIO.ByteString.Lazy as BL
 import RIO.List
-import qualified RIO.NonEmpty as NE
+import RIO.Process
 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
@@ -29,12 +31,13 @@ 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
@@ -64,7 +67,7 @@ parseTest =
 xio :: XOpts -> IO ()
 xio o = case o of
   XDeps -> hRunXIO False stderr printDeps
-  XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
+  XTest -> hRunXIO False stderr $ withDBus_ evalConfig
   XRun -> runXIO "xmobar.log" run
 
 run :: XIO ()
@@ -76,9 +79,9 @@ 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
-  -- TODO do these dbus things really need to remain connected?
+  withDBus_ $ \db -> do
-  c <- withDBus Nothing Nothing evalConfig
+    c <- evalConfig db
-  liftIO $ xmobar c
+    liftIO $ xmobar c
 
 evalConfig :: DBusState -> XIO Config
 evalConfig db = do
@@ -89,7 +92,7 @@ evalConfig db = do
   return $ config bf ifs ios cs d
 
 printDeps :: XIO ()
-printDeps = withDBus_ Nothing Nothing $ \db ->
+printDeps = withDBus_ $ \db ->
   mapM_ logInfo $
     fmap showFulfillment $
       sort $
@@ -118,7 +121,7 @@ iconFont =
   fontSometimes
     "XMobar Icon Font"
     "Symbols Nerd Font"
-    [Package Official "ttf-nerd-fonts-symbols"]
+    [Package Official "ttf-nerd-fonts-symbols-2048-em"]
 
 -- | Offsets for the icons in the bar (relative to the text offset)
 iconOffset :: BarFont -> Int
@@ -164,7 +167,7 @@ config bf ifs ios br confDir =
     , pickBroadest = False
     , persistent = True
     , -- store the icons with the xmonad/xmobar stack project
-      iconRoot = confDir </> "assets" </> "icons"
+      iconRoot = confDir ++ "/icons"
     , commands = csRunnable <$> concatRegions br
     }
 
@@ -219,11 +222,11 @@ getWireless =
     xpfWireless
     [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 
-getEthernet :: Maybe NamedSysConnection -> BarFeature
+getEthernet :: Maybe SysClient -> BarFeature
-getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
+getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
   where
-    root useIcon tree' =
+    root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
-      DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
+    tree = And1 (Only readEthernet) (Only_ devDep)
 
 getBattery :: BarFeature
 getBattery = iconIO_ "battery level indicator" xpfBattery root tree
@@ -235,12 +238,18 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
           io $
             fmap (Msg LevelError) <$> hasBattery
 
-getVPN :: Maybe NamedSysConnection -> BarFeature
+getVPN :: Maybe SysClient -> BarFeature
-getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
+getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
   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 NamedSysConnection -> BarFeature
+getBt :: Maybe SysClient -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
 
 getAlsa :: BarFeature
@@ -251,7 +260,7 @@ getAlsa =
   where
     root useIcon = IORoot_ (alsaCmd useIcon)
 
-getBl :: Maybe NamedSesConnection -> BarFeature
+getBl :: Maybe SesClient -> BarFeature
 getBl =
   xmobarDBus
     "Intel backlight indicator"
@@ -259,7 +268,7 @@ getBl =
     intelBacklightSignalDep
     blCmd
 
-getCk :: Maybe NamedSesConnection -> BarFeature
+getCk :: Maybe SesClient -> BarFeature
 getCk =
   xmobarDBus
     "Clevo keyboard indicator"
@@ -267,7 +276,7 @@ getCk =
     clevoKeyboardSignalDep
     ckCmd
 
-getSs :: Maybe NamedSesConnection -> BarFeature
+getSs :: Maybe SesClient -> BarFeature
 getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
 
 getLock :: Always CmdSpec
@@ -284,7 +293,7 @@ xmobarDBus
   -> XPQuery
   -> DBusDependency_ c
   -> (Fontifier -> CmdSpec)
-  -> Maybe (NamedConnection c)
+  -> Maybe c
   -> BarFeature
 xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
   where
@@ -298,16 +307,18 @@ iconIO_
   -> BarFeature
 iconIO_ = iconSometimes' And_ Only_
 
--- iconDBus
+iconDBus
---   :: T.Text
+  :: SafeClient c
---   -> XPQuery
+  => T.Text
---   -> (Fontifier -> DBusTree c p -> Root CmdSpec)
+  -> XPQuery
---   -> DBusTree c p
+  -> (Fontifier -> DBusTree c p -> Root CmdSpec)
---   -> BarFeature
+  -> DBusTree c p
--- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
+  -> BarFeature
+iconDBus = iconSometimes' And1 $ Only_ . DBusIO
 
 iconDBus_
-  :: T.Text
+  :: SafeClient c
+  => T.Text
   -> XPQuery
   -> (Fontifier -> DBusTree_ c -> Root CmdSpec)
   -> DBusTree_ c
@@ -369,19 +380,13 @@ wirelessCmd iface =
         , "<icon=wifi_%%.xpm/>"
         ]
 
-ethernetCmd :: Fontifier -> CmdSpec
+ethernetCmd :: Fontifier -> T.Text -> CmdSpec
-ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
+ethernetCmd fontify iface =
-
-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 = connAlias contypes
+    { csAlias = iface
     , csRunnable =
         Run $
-          ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
+          Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
     }
 
 batteryCmd :: Fontifier -> CmdSpec
@@ -417,13 +422,20 @@ 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' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
+          Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
     }
   where
     fontify' i = fontify IconLarge i . T.append "BT"
@@ -464,7 +476,7 @@ ckCmd :: Fontifier -> CmdSpec
 ckCmd fontify =
   CmdSpec
     { csAlias = ckAlias
-    , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
+    , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
     }
 
 ssCmd :: Fontifier -> CmdSpec
@@ -500,8 +512,8 @@ lockCmd fontify =
               ]
     }
   where
-    numIcon = fontify' "\x0f03a6" "N"
+    numIcon = fontify' "\xf8a5" "N"
-    capIcon = fontify' "\x0f0bf1" "C"
+    capIcon = fontify' "\xf657" "C"
     fontify' = fontify IconXLarge
     disabledColor = xmobarFGColor XT.backdropFgColor
 
@@ -512,6 +524,29 @@ 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,3 +1,9 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
 --------------------------------------------------------------------------------
 --  XMonad binary
 
@@ -21,7 +27,7 @@ import System.Process
   ( getPid
   , getProcessExitCode
   )
-import XMonad hiding (display)
+import XMonad
 import XMonad.Actions.CopyWindow
 import XMonad.Actions.CycleWS
 import XMonad.Actions.PhysicalScreens
@@ -45,7 +51,6 @@ 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
@@ -139,21 +144,21 @@ run = do
                         , normalBorderColor = T.unpack XT.bordersColor
                         , focusedBorderColor = T.unpack XT.selectedBordersColor
                         }
-          runXMonad conf
+          io $ 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 -> XIO ()
+runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
 runXMonad conf = do
   dirs <- getCreateDirectories
-  liftIO $ launch conf dirs
+  launch conf dirs
 
-getCreateDirectories :: XIO Directories
+getCreateDirectories :: IO Directories
 getCreateDirectories = do
-  ds <- liftIO getDirectories
+  ds <- getDirectories
   mapM_ (createIfMissing ds) [dataDir, cfgDir, cacheDir]
   return ds
   where
@@ -161,14 +166,14 @@ getCreateDirectories = do
       let d = f ds
       r <- tryIO $ createDirectoryIfMissing True d
       case r of
-        (Left e) -> logError $ display e
+        (Left e) -> print e
         _ -> return ()
 
 data FeatureSet = FeatureSet
   { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
+  , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
   , fsPowerMon :: SometimesIO
-  , fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
+  , fsRemovableMon :: Maybe SysClient -> SometimesIO
   , fsDaemons :: [Sometimes (XIO (Process () () ()))]
   , fsACPIHandler :: Always (String -> X ())
   , fsTabbedTheme :: Always Theme
@@ -183,7 +188,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 NamedSysConnection -> FeatureSet
+features :: Maybe SysClient -> FeatureSet
 features cl =
   FeatureSet
     { fsKeys = externalBindings
@@ -251,7 +256,7 @@ stopChildDaemons = mapM_ stop
       liftIO $ killNoWait p
 
 printDeps :: XIO ()
-printDeps = withDBus_ Nothing Nothing $ \db -> do
+printDeps = withDBus_ $ \db -> do
   runIO <- askRunInIO
   let mockCleanup = runCleanup runIO mockClean db
   let bfs =
@@ -292,7 +297,7 @@ runCleanup runIO ts db = liftIO $ runIO $ do
   mapM_ stopXmobar $ clXmobar ts
   stopChildDaemons $ clChildren ts
   sequence_ $ clDBusUnexporters ts
-  disconnectDBus db
+  disconnectDBusX db
 
 -- | Kill a process (group) after xmonad has already started
 -- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
@@ -345,6 +350,9 @@ vmTag = "VM"
 xsaneTag :: String
 xsaneTag = "XSANE"
 
+f5Tag :: String
+f5Tag = "F5VPN"
+
 gimpDynamicWorkspace :: Sometimes DynWorkspace
 gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
   where
@@ -417,11 +425,31 @@ 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
   ]
 
 --------------------------------------------------------------------------------
@@ -436,10 +464,6 @@ 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"] $
@@ -832,9 +856,8 @@ 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-<F7>" "select autorandr profile" $ Left $ toX runAutorandrMenu
+      , KeyBinding "M-<F8>" "select autorandr profile" $ Left $ toX runAutorandrMenu
-      , KeyBinding "M-<F8>" "toggle wifi" $ Left $ toX runToggleWifi
+      , KeyBinding "M-<F9>" "toggle ethernet" $ Left $ toX runToggleEthernet
-      , 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,3 +1,7 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Common internal DBus functions
 
@@ -5,17 +9,11 @@ module Data.Internal.DBus
   ( SafeClient (..)
   , SysClient (..)
   , SesClient (..)
-  , NamedConnection (..)
-  , NamedSesConnection
-  , NamedSysConnection
   , DBusEnv (..)
   , DIO
   , HasClient (..)
-  , releaseBusName
   , withDIO
   , addMatchCallback
-  , addMatchCallbackSignal
-  , matchSignalFull
   , matchProperty
   , matchPropertyFull
   , matchPropertyChanged
@@ -41,10 +39,6 @@ module Data.Internal.DBus
   , displayMemberName
   , displayInterfaceName
   , displayWrapQuote
-  , busNameT
-  , interfaceNameT
-  , memberNameT
-  , objectPathT
   )
 where
 
@@ -59,129 +53,48 @@ import qualified RIO.Text as T
 --------------------------------------------------------------------------------
 -- Type-safe client
 
-data NamedConnection c = NamedConnection
-  { ncClient :: !Client
-  , ncHumanName :: !(Maybe BusName)
-  --, ncUniqueName :: !BusName
-  , ncType :: !c
-  }
-
-type NamedSesConnection = NamedConnection SesClient
-
-type NamedSysConnection = NamedConnection SysClient
-
 class SafeClient c where
+  toClient :: c -> Client
+
   getDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
+    => m (Maybe c)
-    -> m (Maybe (NamedConnection c))
 
-  disconnectDBusClient
+  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
-    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  disconnectDBusClient = liftIO . disconnect . toClient
-    => NamedConnection c
-    -> m ()
-  disconnectDBusClient c = do
-    releaseBusName c
-    liftIO $ disconnect $ ncClient c
 
   withDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
+    => (c -> m a)
-    -> (NamedConnection c -> m a)
     -> m (Maybe a)
-  withDBusClient n f =
+  withDBusClient f =
-    bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
+    bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
 
   withDBusClient_
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
+    => (c -> m ())
-    -> (NamedConnection c -> m ())
     -> m ()
-  withDBusClient_ n = void . withDBusClient n
+  withDBusClient_ = void . withDBusClient
 
   fromDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
+    => (c -> a)
-    -> (NamedConnection c -> a)
     -> m (Maybe a)
-  fromDBusClient n f = withDBusClient n (return . f)
+  fromDBusClient f = withDBusClient (return . f)
 
-data SysClient = SysClient
+newtype SysClient = SysClient Client
 
 instance SafeClient SysClient where
-  getDBusClient = connectToDBusWithName True SysClient
+  toClient (SysClient cl) = cl
 
-data SesClient = SesClient
+  getDBusClient = fmap SysClient <$> getDBusClient' True
+
+newtype SesClient = SesClient Client
 
 instance SafeClient SesClient where
-  -- TODO wet
+  toClient (SesClient cl) = cl
-  getDBusClient = connectToDBusWithName False SesClient
 
-connectToDBusWithName
+  getDBusClient = fmap SesClient <$> getDBusClient' False
-  :: (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)
@@ -195,28 +108,19 @@ getDBusClient' sys = do
       return Nothing
     Right c -> return $ Just c
 
---callHello :: Client -> IO (Maybe BusName)
+data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env}
---callHello cl = do
---  reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
---  case methodReturnBody reply of
---    [name] | Just nameStr <- fromVariant name -> do
---      busName <- parseBusName nameStr
---      return $ Just busName
---    _ -> return Nothing
---
-data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
 
 type DIO env c = RIO (DBusEnv env c)
 
 instance HasClient (DBusEnv SimpleApp) where
   clientL = lens dClient (\x y -> x {dClient = y})
 
-instance HasLogFunc (DBusEnv SimpleApp c) where
+instance SafeClient c => HasLogFunc (DBusEnv SimpleApp c) where
   logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
 
 withDIO
-  :: (MonadUnliftIO m, MonadReader env m)
+  :: (MonadUnliftIO m, MonadReader env m, SafeClient c)
-  => NamedConnection c
+  => c
   -> DIO env c a
   -> m a
 withDIO cl x = do
@@ -224,7 +128,7 @@ withDIO cl x = do
   runRIO (DBusEnv cl env) x
 
 class HasClient env where
-  clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
+  clientL :: SafeClient c => Lens' (env c) c
 
 --------------------------------------------------------------------------------
 -- Methods
@@ -236,7 +140,7 @@ callMethod'
   => MethodCall
   -> m MethodBody
 callMethod' mc = do
-  cl <- ncClient <$> view clientL
+  cl <- toClient <$> view clientL
   liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
 
 callMethod
@@ -298,21 +202,9 @@ 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
@@ -320,7 +212,10 @@ addMatchCallback
   => MatchRule
   -> SignalCallback m
   -> m SignalHandler
-addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
+addMatchCallback rule cb = do
+  cl <- toClient <$> view clientL
+  withRunInIO $ \run -> do
+    addMatch cl rule $ run . cb . signalBody
 
 matchSignal
   :: Maybe BusName
@@ -389,7 +284,7 @@ callPropertyGet
   -> MemberName
   -> m [Variant]
 callPropertyGet bus path iface property = do
-  cl <- ncClient <$> view clientL
+  cl <- toClient <$> view clientL
   res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
   case res of
     Left err -> do
@@ -424,26 +319,26 @@ withSignalMatch _ NoMatch = return ()
 matchPropertyChanged
   :: IsVariant a
   => InterfaceName
-  -> MemberName
+  -> T.Text
   -> [Variant]
   -> SignalMatch a
-matchPropertyChanged iface property [sigIface, sigValues, _] =
+matchPropertyChanged iface property [i, body, _] =
-  let i = fromVariant sigIface :: Maybe T.Text
+  let i' = (fromVariant i :: Maybe T.Text)
-      v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
+      b = toMap body
-   in case (i, v) of
+   in case (i', b) of
-        (Just i', Just v') ->
+        (Just i'', Just b') ->
-          if i' == interfaceNameT iface
+          if i'' == T.pack (formatInterfaceName iface)
-            then
+            then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
-              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 InterfaceName (M.Map T.Text Variant))
+type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
 
 omInterface :: InterfaceName
 omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
@@ -473,11 +368,7 @@ callGetManagedObjects bus path = do
     Left err -> do
       logError $ Utf8Builder $ encodeUtf8Builder err
       return M.empty
-    Right v ->
+    Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
-      return $
-        fmap (M.mapKeys interfaceName_) $
-          fromMaybe M.empty $
-            fromSingletonVariant v
 
 addInterfaceChangedListener
   :: ( MonadReader (env c) m
@@ -541,14 +432,14 @@ addInterfaceRemovedListener bus =
 -- Interface export/unexport
 
 exportPair
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
   => ObjectPath
   -> (Client -> m Interface)
-  -> NamedConnection c
+  -> c
   -> (m (), m ())
 exportPair path toIface cl = (up, down)
   where
-    cl_ = ncClient cl
+    cl_ = toClient cl
     up = do
       logInfo $ "adding interface: " <> path_
       i <- toIface cl_
@@ -561,18 +452,6 @@ 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,3 +1,12 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 --------------------------------------------------------------------------------
 -- Functions for handling dependencies
 
@@ -100,7 +109,6 @@ 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)
@@ -132,9 +140,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 (withBinaryFile p AppendMode f) $ \e -> do
+  catchIO (withFile p AppendMode f) $ \e -> do
-    liftIO $ TI.putStrLn $ T.pack $ show e
+    liftIO $ print e
-    liftIO $ TI.putStrLn "could not open log file, falling back to stderr"
+    liftIO $ putStrLn "could not open log file, falling back to stderr"
     f stderr
 
 hRunXIO :: Bool -> Handle -> XIO a -> IO a
@@ -288,18 +296,8 @@ type SubfeatureRoot a = Subfeature (Root a)
 data Root a
   = forall p. IORoot (p -> a) (IOTree p)
   | IORoot_ a IOTree_
-  | forall c p.
+  | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
-    SafeClient c =>
+  | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe 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
@@ -427,7 +425,7 @@ data XEnv = XEnv
 instance HasLogFunc XEnv where
   logFuncL = lens xLogFun (\x y -> x {xLogFun = y})
 
-instance HasLogFunc (DBusEnv XEnv c) where
+instance SafeClient c => HasLogFunc (DBusEnv XEnv c) where
   logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
 
 instance HasProcessContext XEnv where
@@ -468,8 +466,7 @@ data XPFeatures = XPFeatures
   , xpfIntelBacklight :: Bool
   , xpfClevoBacklight :: Bool
   , xpfBattery :: Bool
-  , xpfEthPrefix :: Maybe Text
+  , xpfF5VPN :: Bool
-  , xpfWifiPrefix :: Maybe Text
   }
 
 instance FromJSON XPFeatures where
@@ -496,9 +493,7 @@ instance FromJSON XPFeatures where
       <*> o
       .:+ "battery"
       <*> o
-      .:? "ethPrefix"
+      .:+ "f5vpn"
-      <*> o
-      .:? "wifiPrefix"
 
 defParams :: XParams
 defParams =
@@ -521,8 +516,7 @@ defXPFeatures =
     , xpfIntelBacklight = False
     , xpfClevoBacklight = False
     , xpfBattery = False
-    , xpfEthPrefix = Nothing
+    , xpfF5VPN = False
-    , xpfWifiPrefix = Nothing
     }
 
 type XPQuery = XPFeatures -> Bool
@@ -533,7 +527,7 @@ getParams = do
   maybe (return defParams) (liftIO . decodeYaml) p
   where
     decodeYaml p =
-      either (\e -> TI.putStrLn (T.pack $ show e) >> return defParams) return
+      either (\e -> print e >> return defParams) return
         =<< decodeFileEither p
 
 getParamFile :: MonadIO m => m (Maybe FilePath)
@@ -833,16 +827,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" (fromMaybe "en" . xpfEthPrefix)
+readEthernet = readInterface "get ethernet interface" isEthernet
 
 readWireless :: IODependency T.Text
-readWireless = readInterface "get wireless interface" (fromMaybe "wl" . xpfWifiPrefix)
+readWireless = readInterface "get wireless interface" isWireless
 
--- isWireless :: T.Text -> Bool
+isWireless :: T.Text -> Bool
--- isWireless = T.isPrefixOf "wl"
+isWireless = T.isPrefixOf "wl"
 
--- isEthernet :: T.Text -> Bool
+isEthernet :: T.Text -> Bool
--- isEthernet = T.isPrefixOf "en"
+isEthernet = T.isPrefixOf "en"
 
 listInterfaces :: MonadUnliftIO m => m [T.Text]
 listInterfaces =
@@ -854,12 +848,11 @@ 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 -> (XPFeatures -> Text) -> IODependency T.Text
+readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text
 readInterface n f = IORead n [] go
   where
-    go = do
+    go = io $ do
-      p <- asks (f . xpFeatures . xParams)
+      ns <- filter f <$> listInterfaces
-      ns <- filter (T.isPrefixOf p) <$> listInterfaces
       case ns of
         [] -> return $ Left [Msg LevelError "no interfaces found"]
         (x : xs) -> do
@@ -895,10 +888,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
-testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
+testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
 testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
 
-testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
+testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
 testDBusDepNoCache_ cl (Bus _ bus) = do
   ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
   return $ case ret of
@@ -1029,11 +1022,11 @@ sometimesExeArgs fn n ful sys path args =
 
 sometimesDBus
   :: SafeClient c
-  => Maybe (NamedConnection c)
+  => Maybe c
   -> T.Text
   -> T.Text
   -> Tree_ (DBusDependency_ c)
-  -> (NamedConnection c -> a)
+  -> (c -> a)
   -> Sometimes a
 sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
 
@@ -1047,7 +1040,7 @@ sometimesEndpoint
   -> ObjectPath
   -> InterfaceName
   -> MemberName
-  -> Maybe (NamedConnection c)
+  -> Maybe 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,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Dmenu (Rofi) Commands
 
@@ -146,7 +148,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 runWinMenu :: MonadUnliftIO m => Sometimes (m ())
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
-runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
+runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
 runNetMenu cl =
   Sometimes
     "network control menu"
@@ -171,7 +173,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
 --------------------------------------------------------------------------------
 -- Password manager
 
-runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
   where
     cmd _ =
@@ -208,7 +210,7 @@ runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
 -- Shortcut menu
 
 runShowKeys
-  :: (MonadReader env m, MonadUnliftIO m)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => Always ([((KeyMask, KeySym), NamedAction)] -> m ())
 runShowKeys =
   Always "keyboard menu" $
@@ -223,7 +225,7 @@ runShowKeys =
           defNoteError {body = Just $ Text "could not display keymap"}
 
 showKeysDMenu
-  :: (MonadReader env m, MonadUnliftIO m)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
 showKeysDMenu =
   Subfeature
@@ -232,7 +234,7 @@ showKeysDMenu =
     }
 
 showKeys
-  :: (MonadReader env m, MonadUnliftIO m)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => [((KeyMask, KeySym), NamedAction)]
   -> m ()
 showKeys kbs = do

lib/XMonad/Internal/Command/Desktop.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- General commands
 
@@ -19,8 +21,7 @@ module XMonad.Internal.Command.Desktop
   , runVolumeUp
   , runVolumeMute
   , runToggleBluetooth
-  , runToggleNetworking
+  , runToggleEthernet
-  , runToggleWifi
   , runRestart
   , runRecompile
   , runAreaCapture
@@ -59,13 +60,13 @@ import XMonad.Operations
 -- My Executables
 
 myTerm :: FilePath
-myTerm = "alacritty"
+myTerm = "urxvt"
 
 myCalc :: FilePath
 myCalc = "bc"
 
 myBrowser :: FilePath
-myBrowser = "firefox"
+myBrowser = "brave"
 
 myEditor :: FilePath
 myEditor = "emacsclient"
@@ -93,7 +94,8 @@ myNotificationCtrl = "dunstctl"
 
 myTermPkgs :: [Fulfillment]
 myTermPkgs =
-  [ Package Official "alacritty"
+  [ Package Official "rxvt-unicode"
+  , Package Official "urxvt-perls"
   ]
 
 myEditorPkgs :: [Fulfillment]
@@ -108,9 +110,6 @@ bluetoothPkgs = [Package Official "bluez-utils"]
 networkManagerPkgs :: [Fulfillment]
 networkManagerPkgs = [Package Official "networkmanager"]
 
-nmcli :: IODependency_
-nmcli = sysExe networkManagerPkgs "nmcli"
-
 --------------------------------------------------------------------------------
 -- Misc constants
 
@@ -121,7 +120,7 @@ volumeChangeSound = "smb_fireball.wav"
 -- Some nice apps
 
 runTerm :: MonadUnliftIO m => Sometimes (m ())
-runTerm = sometimesExe "terminal" "alacritty" myTermPkgs True myTerm
+runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
 
 runTMux :: MonadUnliftIO m => Sometimes (m ())
 runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
@@ -209,7 +208,7 @@ runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
 -- Volume Commands
 
 soundDir :: FilePath
-soundDir = "assets" </> "sound"
+soundDir = "sound"
 
 playSound :: MonadIO m => FilePath -> m ()
 playSound file = do
@@ -249,7 +248,7 @@ runNotificationCmd
   :: MonadUnliftIO m
   => T.Text
   -> T.Text
-  -> Maybe NamedSesConnection
+  -> Maybe SesClient
   -> Sometimes (m ())
 runNotificationCmd n arg cl =
   sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
@@ -261,37 +260,37 @@ runNotificationCmd n arg cl =
           Method_ $
             memberName_ "NotificationAction"
 
-runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationClose = runNotificationCmd "close notification" "close"
 
-runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationCloseAll =
   runNotificationCmd "close all notifications" "close-all"
 
-runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationHistory =
   runNotificationCmd "see notification history" "history-pop"
 
-runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationContext =
   runNotificationCmd "open notification context" "context"
 
 --------------------------------------------------------------------------------
 -- System commands
 
--- needed to lookup/prompt for passwords/keys for wifi connections and some VPNs
+-- this is required for some vpn's to work properly with network-manager
-runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
+runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ()))
 runNetAppDaemon cl =
   Sometimes
     "network applet"
-    (\x -> xpfVPN x || xpfWireless x)
+    xpfVPN
     [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 NamedSysConnection -> Sometimes (m ())
+runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
 runToggleBluetooth cl =
   Sometimes
     "bluetooth toggle"
@@ -308,35 +307,27 @@ runToggleBluetooth cl =
           #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
           #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
 
-runToggleNetworking :: MonadUnliftIO m => Sometimes (m ())
+runToggleEthernet :: MonadUnliftIO m => Sometimes (m ())
-runToggleNetworking =
+runToggleEthernet =
   Sometimes
-    "network toggle"
+    "ethernet toggle"
-    (\x -> xpfEthernet x || xpfWireless x)
+    xpfEthernet
     [Subfeature root "nmcli"]
   where
-    root = IORoot_ cmd $ Only_ nmcli
+    root =
-    cmd =
+      IORoot cmd $
+        And1 (Only readEthernet) $
+          Only_ $
+            sysExe networkManagerPkgs "nmcli"
+    -- TODO make this less noisy
+    cmd iface =
       S.spawn $
-        fmtCmd "nmcli" ["networking"]
+        fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
-          #!| "grep -q enabled"
+          #!| "grep -q disconnected"
-          #!&& "a=off"
+          #!&& "a=connect"
-          #!|| "a=on"
+          #!|| "a=disconnect"
-          #!>> fmtCmd "nmcli" ["networking", "$a"]
+          #!>> fmtCmd "nmcli" ["device", "$a", iface]
-          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "networking switched $a"}
+          #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
-
-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
@@ -377,7 +368,7 @@ runFlameshot
   :: MonadUnliftIO m
   => T.Text
   -> T.Text
-  -> Maybe NamedSesConnection
+  -> Maybe SesClient
   -> Sometimes (m ())
 runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
   where
@@ -389,15 +380,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 NamedSesConnection -> Sometimes (m ())
+runAreaCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
-runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runScreenCapture = runFlameshot "screen capture" "screen"
 
 runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())

lib/XMonad/Internal/Command/Power.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Commands for controlling power
 
@@ -89,8 +91,7 @@ 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" args (P.startProcess . P.setCreateGroup True)
+    cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
-    args = ["--ignore-sleep", "--", "screenlock", "true"]
 
 --------------------------------------------------------------------------------
 -- Confirmation prompts
@@ -179,20 +180,17 @@ data PowerMaybeAction
   | Reboot
   deriving (Eq)
 
-fromPMA :: PowerMaybeAction -> Int
+instance Enum PowerMaybeAction where
-fromPMA a = case a of
+  toEnum 0 = Poweroff
-  Poweroff -> 0
+  toEnum 1 = Shutdown
-  Shutdown -> 1
+  toEnum 2 = Hibernate
-  Hibernate -> 2
+  toEnum 3 = Reboot
-  Reboot -> 3
+  toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
 
-toPMA :: Int -> Maybe PowerMaybeAction
+  fromEnum Poweroff = 0
-toPMA x = case x of
+  fromEnum Shutdown = 1
-  0 -> Just Poweroff
+  fromEnum Hibernate = 2
-  1 -> Just Shutdown
+  fromEnum Reboot = 3
-  2 -> Just Hibernate
-  3 -> Just Reboot
-  _ -> Nothing
 
 data PowerPrompt = PowerPrompt
 
@@ -224,11 +222,9 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
             , (xK_Return, quit)
             , (xK_Escape, quit)
             ]
-    sendMaybeAction a = setInput (show $ fromPMA a) >> setSuccess True >> setDone True
+    sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
-    executeMaybeAction a = case toPMA =<< readMaybe a of
+    executeMaybeAction a = case toEnum $ read a of
-      Just Poweroff -> liftIO runPowerOff
+      Poweroff -> liftIO runPowerOff
-      Just Shutdown -> lock >> liftIO runSuspend
+      Shutdown -> lock >> liftIO runSuspend
-      Just Hibernate -> lock >> liftIO runHibernate
+      Hibernate -> lock >> liftIO runHibernate
-      Just Reboot -> liftIO runReboot
+      Reboot -> liftIO runReboot
-      -- TODO log an error here since this should never happen
-      Nothing -> skip

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Concurrent module to handle events from acpid
 
@@ -30,18 +33,15 @@ data ACPIEvent
   | LidClose
   deriving (Eq)
 
-fromACPIEvent :: ACPIEvent -> Int
+instance Enum ACPIEvent where
-fromACPIEvent x = case x of
+  toEnum 0 = Power
-  Power -> 0
+  toEnum 1 = Sleep
-  Sleep -> 1
+  toEnum 2 = LidClose
-  LidClose -> 2
+  toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
 
-toACPIEvent :: Int -> Maybe ACPIEvent
+  fromEnum Power = 0
-toACPIEvent x = case x of
+  fromEnum Sleep = 1
-  0 -> Just Power
+  fromEnum LidClose = 2
-  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 . fromACPIEvent
+sendACPIEvent = sendXMsg ACPI . show . fromEnum
 
 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 = toACPIEvent =<< readMaybe tag :: Maybe ACPIEvent
+  let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
   forM_ acpiTag $ \case
     Power -> powerPrompt lock fb
     Sleep -> suspendPrompt fb

lib/XMonad/Internal/Concurrent/ClientMessage.hs

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

lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs

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

lib/XMonad/Internal/Concurrent/VirtualBox.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 --------------------------------------------------------------------------------
 -- VirtualBox-specific functions
 
@@ -33,7 +36,7 @@ vmInstanceConfig vmName = do
 vmDirectory :: IO (Either String String)
 vmDirectory = do
   p <- vmConfig
-  s <- tryIO $ readFileUtf8 p
+  s <- tryIO $ readFile p
   return $ case s of
     (Left _) -> Left "could not read VirtualBox config file"
     (Right x) ->

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

@@ -1,3 +1,6 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- DBus module for Clevo Keyboard control
 
@@ -117,7 +120,7 @@ clevoKeyboardSignalDep =
 
 exportClevoKeyboard
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe NamedSesConnection
+  => Maybe SesClient
   -> Sometimes (m (), m ())
 exportClevoKeyboard =
   brightnessExporter
@@ -128,7 +131,7 @@ exportClevoKeyboard =
 
 clevoKeyboardControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe NamedSesConnection
+  => Maybe SesClient
   -> BrightnessControls m
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
 
@@ -139,6 +142,7 @@ 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,3 +1,7 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
 --------------------------------------------------------------------------------
 -- DBus module for DBus brightness controls
 
@@ -53,7 +57,7 @@ brightnessControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
   => XPQuery
   -> BrightnessConfig m a b
-  -> Maybe NamedSesConnection
+  -> Maybe SesClient
   -> BrightnessControls m
 brightnessControls q bc cl =
   BrightnessControls
@@ -76,14 +80,15 @@ callGetBrightness
   -> m (Maybe n)
 callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
   either (const Nothing) bodyGetBrightness
-    <$> callMethod xmonadSesBusName p i memGet
+    <$> callMethod xmonadBusName p i memGet
 
-signalDep :: BrightnessConfig m a b -> DBusDependency_ c
+signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
 signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
-  Endpoint [] xmonadSesBusName p i $ Signal_ memCur
+  Endpoint [] xmonadBusName p i $ Signal_ memCur
 
 matchSignal
   :: ( HasClient env
+     , HasLogFunc (env c)
      , MonadReader (env c) m
      , MonadUnliftIO m
      , SafeClient c
@@ -112,18 +117,18 @@ brightnessExporter
   -> [Fulfillment]
   -> [IODependency_]
   -> BrightnessConfig m a b
-  -> Maybe NamedSesConnection
+  -> Maybe SesClient
   -> 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 xmonadSesBusName) $ fmap DBusIO deps
+    tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
 
 exportBrightnessControlsInner
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
   => BrightnessConfig m a b
-  -> NamedSesConnection
+  -> SesClient
   -> (m (), m ())
 exportBrightnessControlsInner bc = cmd
   where
@@ -172,7 +177,7 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
 callBacklight
   :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
   => XPQuery
-  -> Maybe NamedSesConnection
+  -> Maybe SesClient
   -> BrightnessConfig m a b
   -> T.Text
   -> MemberName
@@ -180,8 +185,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 [] xmonadSesBusName p i $ Method_ m) cl
+    root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
-    cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
+    cmd c = void $ withDIO c $ callMethod xmonadBusName p i m
 
 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

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

@@ -1,3 +1,6 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- DBus module for Intel Backlight control
 
@@ -103,7 +106,7 @@ intelBacklightSignalDep =
 
 exportIntelBacklight
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe NamedSesConnection
+  => Maybe SesClient
   -> Sometimes (m (), m ())
 exportIntelBacklight =
   brightnessExporter
@@ -114,7 +117,7 @@ exportIntelBacklight =
 
 intelBacklightControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe NamedSesConnection
+  => Maybe SesClient
   -> BrightnessControls m
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 
@@ -125,6 +128,7 @@ callGetBrightnessIB = callGetBrightness intelBacklightConfig
 
 matchSignalIB
   :: ( SafeClient c
+     , HasLogFunc (env c)
      , HasClient env
      , MonadReader (env c) m
      , MonadUnliftIO m

lib/XMonad/Internal/DBus/Common.hs

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

lib/XMonad/Internal/DBus/Control.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 --------------------------------------------------------------------------------
 -- High-level interface for managing XMonad's DBus
 
@@ -10,8 +13,9 @@ module XMonad.Internal.DBus.Control
   , withDBus
   , withDBus_
   , connectDBus
+  , connectDBusX
   , disconnectDBus
-  -- , disconnectDBusX
+  , disconnectDBusX
   , getDBusClient
   , withDBusClient
   , withDBusClient_
@@ -25,6 +29,7 @@ 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
@@ -32,8 +37,8 @@ import XMonad.Internal.DBus.Screensaver
 
 -- | Current connections to the DBus (session and system buses)
 data DBusState = DBusState
-  { dbSesClient :: Maybe NamedSesConnection
+  { dbSesClient :: Maybe SesClient
-  , dbSysClient :: Maybe NamedSysConnection
+  , dbSysClient :: Maybe SysClient
   }
 
 withDBusX_
@@ -45,79 +50,59 @@ withDBusX_ = void . withDBusX
 withDBusX
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => (DBusState -> m a)
-  -> m a
+  -> m (Maybe a)
-withDBusX = withDBus (Just xmonadSesBusName) Nothing
+withDBusX f = withDBus $ \db -> do
+  forM (dbSesClient db) $ \ses -> do
+    bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
 
 withDBus_
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe BusName
+  => (DBusState -> m a)
-  -> Maybe BusName
-  -> (DBusState -> m a)
   -> m ()
-withDBus_ sesname sysname = void . withDBus sesname sysname
+withDBus_ = void . withDBus
 
 withDBus
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe BusName
+  => (DBusState -> m a)
-  -> Maybe BusName
-  -> (DBusState -> m a)
   -> m a
-withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
+withDBus = bracket connectDBus disconnectDBus
 
 -- | Connect to the DBus
 connectDBus
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe BusName
+  => m DBusState
-  -> Maybe BusName
+connectDBus = do
-  -> m DBusState
+  ses <- getDBusClient
-connectDBus sesname sysname = do
+  sys <- getDBusClient
-  ses <- getDBusClient sesname
-  sys <- getDBusClient sysname
   return DBusState {dbSesClient = ses, dbSysClient = sys}
 
 -- | Disconnect from the DBus
-disconnectDBus
+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
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => DBusState
   -> m ()
-disconnectDBus db = disc dbSesClient >> disc dbSysClient
+disconnectDBusX db = do
-  where
+  forM_ (dbSesClient db) releaseXMonadName
-    disc
+  disconnectDBus db
-      :: (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 NamedSesConnection -> Sometimes (XIO (), XIO ())]
+  -> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
   -> ([XIO ()] -> XIO a)
   -> XIO a
 withDBusInterfaces db interfaces = bracket up sequence
@@ -130,59 +115,35 @@ withDBusInterfaces db interfaces = bracket up sequence
 -- | All exporter features to be assigned to the DBus
 dbusExporters
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => [Maybe NamedSesConnection -> Sometimes (m (), m ())]
+  => [Maybe SesClient -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
--- releaseXMonadName
+releaseXMonadName
---   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
---   => c
+  => SesClient
---   -> m ()
+  -> m ()
--- releaseXMonadName cl = do
+releaseXMonadName ses = do
---   -- TODO this might error?
+  -- TODO this might error?
---   liftIO $ void $ releaseName (toClient cl) xmonadBusName
+  liftIO $ void $ releaseName (toClient ses) xmonadBusName
---   logInfo "released xmonad name"
+  logInfo "released xmonad name"
 
--- releaseBusName
+requestXMonadName
---   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
---   => BusName
+  => SesClient
---   -> c
+  -> m ()
---   -> m ()
+requestXMonadName ses = do
--- releaseBusName n cl = do
+  res <- liftIO $ requestName (toClient ses) xmonadBusName []
---   -- TODO this might error?
+  let msg
---   liftIO $ void $ releaseName (toClient cl) n
+        | res == NamePrimaryOwner = "registering name"
---   logInfo $ "released bus name: " <> displayBusName n
+        | res == NameAlreadyOwner = "this process already owns name"
-
+        | res == NameInQueue
--- requestBusName
+            || res == NameExists =
---   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+            "another process owns name"
---   => BusName
+        | otherwise = "unknown error when requesting name"
---   -> c
+  logInfo $ msg <> ": " <> xn
---   -> m ()
+  where
--- requestBusName n cl = do
+    xn =
---   res <- try $ liftIO $ requestName (toClient cl) n []
+      Utf8Builder $
---   case res of
+        encodeUtf8Builder $
---     Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+          T.pack $
---     Right r -> do
+            formatBusName xmonadBusName
---       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,3 +1,6 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Module for monitoring removable drive events
 --
@@ -80,10 +83,11 @@ 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
      )
-  => NamedSysConnection
+  => SysClient
   -> m ()
 listenDevices cl = do
   addMatch' memAdded driveInsertedSound addedHasDrive
@@ -95,10 +99,11 @@ listenDevices cl = do
 
 runRemovableMon
   :: ( HasClient (DBusEnv env)
+     , HasLogFunc (DBusEnv env SysClient)
      , MonadReader env m
      , MonadUnliftIO m
      )
-  => Maybe NamedSysConnection
+  => Maybe SysClient
   -> Sometimes (m ())
 runRemovableMon cl =
   sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices

lib/XMonad/Internal/DBus/Screensaver.hs

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

lib/XMonad/Internal/IO.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ViewPatterns #-}
+
 --------------------------------------------------------------------------------
 -- Random IO-ish functions used throughtout xmonad
 --
@@ -39,7 +41,7 @@ import System.Process
 -- read
 
 readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
-readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
+readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
 
 readBool :: MonadIO m => FilePath -> m Bool
 readBool = fmap (== (1 :: Int)) . readInt
@@ -47,7 +49,7 @@ readBool = fmap (== (1 :: Int)) . readInt
 --------------------------------------------------------------------------------
 -- write
 
-writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
+writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
 writeInt f = writeFileUtf8 f . T.pack . show
 
 writeBool :: MonadIO m => FilePath -> Bool -> m ()
@@ -60,7 +62,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, RealFrac c) => (a, a) -> b -> c
+rawToPercent :: (Integral a, Integral b, Read 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,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Functions for formatting and sending notifications
 --

lib/XMonad/Internal/Shell.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- Functions for formatting and spawning shell commands
 
 module XMonad.Internal.Shell
@@ -83,7 +85,10 @@ spawn :: MonadIO m => T.Text -> m ()
 spawn = X.spawn . T.unpack
 
 -- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
-spawnPipe :: MonadUnliftIO m => T.Text -> m Handle
+spawnPipe
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => T.Text
+  -> m Handle
 spawnPipe = liftIO . XR.spawnPipe . T.unpack
 
 -- spawnPipeRW

lib/XMonad/Internal/Theme.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Theme for XMonad and Xmobar
 
@@ -31,7 +33,6 @@ 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

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

lib/Xmobar/Plugins/Bluetooth.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 --------------------------------------------------------------------------------
 -- Bluetooth plugin
 --
@@ -7,18 +9,28 @@
 -- 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>".
 --
--- Simple and somewhat crude way to do this is to have two monitors, one
+-- This plugin will reflect if the adapter is powered and if any device is
--- watching the powered state of the adaptor and one listening for connection
+-- connected to it. The rough outline for this procedure:
--- changes. The former is easy since this is just one /org/bluez/hciX. For the
+-- 1) get the adapter from the object manager
--- latter, each 'Connected' property is embedded in each individual device path
+-- 2) get all devices associated with the adapter using the object interface
--- on `org.bluez.Device1', so just watch the entire bluez bus for property
+-- 3) determine if the adapter is powered
--- changes and filter those that correspond to the aforementioned
+-- 4) determine if any devices are connected
--- interface/property. Track all this in a state which keeps the powered
+-- 5) format the icon; powered vs not powered controls the color and connected
--- property and a running list of connected devices.
+--    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)
 --
 -- TODO also not sure if I need to care about multiple adapters and/or the
--- adapter changing. For now it should just get the first adaptor and only pay
+-- adapter changing.
--- attention to devices associated with it.
 
 module Xmobar.Plugins.Bluetooth
   ( Bluetooth (..)
@@ -35,7 +47,6 @@ 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
@@ -54,28 +65,32 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
 instance Exec Bluetooth where
   alias (Bluetooth _ _) = T.unpack btAlias
   start (Bluetooth icons colors) cb =
-    withDBusClientConnection cb Nothing (Just "bluetooth.log") $
+    withDBusClientConnection cb (Just "bluetooth.log") $ startAdapter icons colors cb
-      startAdapter icons colors cb
 
 startAdapter
   :: Icons
   -> Colors
   -> Callback
-  -> NamedSysConnection
+  -> SysClient
   -> RIO SimpleApp ()
 startAdapter is cs cb cl = do
   state <- newMVar emptyState
-  let dpy cb' = displayIcon cb' (iconFormatter is cs)
+  let dpy = displayIcon cb (iconFormatter is cs)
-  mapRIO (PluginEnv cl state dpy cb) $ do
+  mapRIO (BTEnv cl state dpy) $ do
     ot <- getBtObjectTree
-    case findAdaptor ot of
+    case findAdapter ot of
       Nothing -> logError "could not find bluetooth adapter"
-      Just adaptor -> do
+      Just adapter -> do
-        initAdapterState adaptor
+        -- set up adapter
-        initDevicesState adaptor ot
+        initAdapter adapter
-        startAdaptorListener adaptor
+        void $ addAdaptorListener adapter
-        startConnectedListener adaptor
+        -- set up devices on the adapter (and listeners for adding/removing devices)
-        pluginDisplay
+        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
 
 --------------------------------------------------------------------------------
 -- Icon Display
@@ -100,18 +115,43 @@ 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.
 
-type BTIO = PluginIO BtState SysClient
+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
 
 data BtState = BtState
-  { btDevices :: S.Set ObjectPath
+  { btDevices :: ConnectedDevices
   , btPowered :: Maybe Bool
   }
 
 emptyState :: BtState
 emptyState =
   BtState
-    { btDevices = S.empty
+    { btDevices = M.empty
     , btPowered = Nothing
     }
 
@@ -119,33 +159,24 @@ readState :: BTIO (Maybe Bool, Bool)
 readState = do
   p <- readPowered
   c <- readDevices
-  return (p, not $ null c)
+  return (p, anyDevicesConnected c)
 
 modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
 modifyState f = do
-  m <- asks plugState
+  m <- asks btState
   modifyMVar m f
 
 beforeDisplay :: BTIO () -> BTIO ()
-beforeDisplay f = f >> pluginDisplay
+beforeDisplay f = f >> join (asks btDisplay)
 
 --------------------------------------------------------------------------------
 -- Object manager
 
-findAdaptor :: ObjectTree -> Maybe ObjectPath
+findAdapter :: ObjectTree -> Maybe ObjectPath
-findAdaptor = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
+findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
 
--- | Search the object tree for devices which are in a connected state.
+findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
--- Return the object path for said devices.
+findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
-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
@@ -168,14 +199,49 @@ 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
 
--- | Get powered state of adaptor and log the result
+initAdapter :: ObjectPath -> BTIO ()
-initAdapterState :: ObjectPath -> BTIO ()
+initAdapter adapter = do
-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
@@ -188,23 +254,40 @@ matchBTProperty
   -> m (Maybe MatchRule)
 matchBTProperty p = matchPropertyFull btBus (Just p)
 
--- | Start a listener that monitors changes to the powered state of an adaptor
+withBTPropertyRule
-startAdaptorListener :: ObjectPath -> BTIO ()
+  :: ( SafeClient c
-startAdaptorListener adaptor = do
+     , MonadReader (env c) m
-  res <- matchBTProperty adaptor
+     , 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
   case res of
-    Just rule -> void $ addMatchCallback rule callback
+    Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected)
     Nothing -> do
       logError $
         "could not add listener for prop "
-          <> displayMemberName adaptorPowered
+          <> prop_
           <> " on path "
-          <> displayObjectPath adaptor
+          <> 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
   where
-    callback sig =
-      withNestedDBusClientConnection Nothing Nothing $
-        withSignalMatch procMatch $
-          matchPropertyChanged adaptorInterface adaptorPowered sig
     procMatch = beforeDisplay . putPowered
 
 callGetPowered
@@ -217,58 +300,88 @@ callGetPowered
   => ObjectPath
   -> m [Variant]
 callGetPowered adapter =
-  callPropertyGet btBus adapter adaptorInterface adaptorPowered
+  callPropertyGet btBus adapter adapterInterface $
+    memberName_ $
+      T.unpack adaptorPowered
 
 putPowered :: Maybe Bool -> BTIO ()
 putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
 
 readPowered :: BTIO (Maybe Bool)
-readPowered = fmap btPowered $ readMVar =<< asks plugState
+readPowered = fmap btPowered $ readMVar =<< asks btState
 
-adaptorInterface :: InterfaceName
+adapterInterface :: InterfaceName
-adaptorInterface = interfaceName_ "org.bluez.Adapter1"
+adapterInterface = interfaceName_ "org.bluez.Adapter1"
 
-adaptorPowered :: MemberName
+adaptorPowered :: T.Text
 adaptorPowered = "Powered"
 
 --------------------------------------------------------------------------------
 -- Devices
 
-initDevicesState :: ObjectPath -> ObjectTree -> BTIO ()
+addAndInitDevice :: ObjectPath -> BTIO ()
-initDevicesState adaptor ot = do
+addAndInitDevice device = do
-  let devices = findConnectedDevices adaptor ot
+  res <- addDeviceListener device
-  modifyState $ \s -> return (s {btDevices = S.fromList devices}, ())
+  case res of
-
+    Just handler -> do
-startConnectedListener :: ObjectPath -> BTIO ()
+      logInfo $ "initializing device at path " <> device_
-startConnectedListener adaptor = do
+      initDevice handler device
-  reply <- matchPropertyFull btBus Nothing
+    Nothing -> logError $ "could not initialize device at path " <> device_
-  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
-    adaptor_ = displayWrapQuote $ displayObjectPath adaptor
+    device_ = displayWrapQuote $ displayObjectPath device
-    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}, ())
 
-readDevices :: BTIO (S.Set ObjectPath)
+initDevice :: SignalHandler -> ObjectPath -> BTIO ()
-readDevices = fmap btDevices $ readMVar =<< asks plugState
+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
 
 devInterface :: InterfaceName
 devInterface = interfaceName_ "org.bluez.Device1"
 
-devConnected :: MemberName
+devConnected :: T.Text
 devConnected = "Connected"

lib/Xmobar/Plugins/ClevoKeyboard.hs

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

lib/Xmobar/Plugins/Common.hs

@@ -1,19 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Xmobar.Plugins.Common
   ( colorText
   , startListener
   , procSignalMatch
   , na
   , fromSingletonVariant
-  , withNestedDBusClientConnection
   , withDBusClientConnection
   , Callback
   , Colors (..)
   , displayMaybe
   , displayMaybe'
   , xmobarFGColor
-  , PluginEnv (..)
-  , PluginIO
-  , pluginDisplay
   )
 where
 
@@ -25,28 +23,6 @@ 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 ()
 
@@ -57,7 +33,8 @@ data Colors = Colors
   deriving (Eq, Show, Read)
 
 startListener
-  :: ( HasClient env
+  :: ( HasLogFunc (env c)
+     , HasClient env
      , MonadReader (env c) m
      , MonadUnliftIO m
      , SafeClient c
@@ -99,42 +76,14 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
 withDBusClientConnection
   :: (MonadUnliftIO m, SafeClient c)
   => Callback
-  -> Maybe BusName
   -> Maybe FilePath
-  -> (NamedConnection c -> RIO SimpleApp ())
+  -> (c -> RIO SimpleApp ())
   -> m ()
-withDBusClientConnection cb n logfile f =
+withDBusClientConnection cb logfile f =
   maybe (run stderr) (`withLogFile` run) logfile
   where
     run h = do
       logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
       withLogFunc logOpts $ \lf -> do
         env <- mkSimpleApp lf Nothing
-        runRIO env $ displayMaybe' cb f =<< getDBusClient n
+        runRIO env $ displayMaybe' cb f =<< getDBusClient
-
--- | 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

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

lib/Xmobar/Plugins/Screensaver.hs

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

lib/Xmobar/Plugins/VPN.hs

@@ -0,0 +1,173 @@
+{-# 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,47 +9,9 @@ extra-source-files:
 - README.md
 - fourmolu.yaml
 - make_pkgs
-- runtime_pkgs
+- icons/*
-- 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
@@ -75,19 +37,13 @@ dependencies:
   - unliftio >= 0.2.21.0
   - optparse-applicative >= 0.16.1.0
 
-ghc-options:
-- -Wall
-- -Wcompat
-- -Widentities
-- -Wincomplete-record-updates
-- -Wincomplete-uni-patterns
-- -Wredundant-constraints
-- -Wpartial-fields
-- -Werror
-- -O2
-
 library:
   source-dirs: lib/
+  ghc-options:
+    - -Wall
+    - -Werror
+    - -Wpartial-fields
+    - -O2
 
 executables:
   xmobar: &bin
@@ -97,15 +53,21 @@ 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

@@ -1,22 +0,0 @@
-#! /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

@@ -1,61 +0,0 @@
-#! /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-19.33
+#resolver: lts-17.4
-#resolver: nightly-2022-03-03
+resolver: nightly-2022-03-03
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.