From d560db1548dd5b7e01684fdbdf497cefdd3873fd Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 30 Dec 2022 10:56:09 -0500 Subject: [PATCH] Revert "WIP use unliftio everywhere-ish" This reverts commit 769df2fb002f2e78d79e680aca8bbff4faf232bf. --- bin/xmobar.hs | 23 ++- bin/xmonad.hs | 9 +- lib/Data/Internal/DBus.hs | 144 ++++++------------ lib/Data/Internal/Dependency.hs | 31 ++-- lib/XMonad/Internal/Command/DMenu.hs | 5 +- lib/XMonad/Internal/Command/Desktop.hs | 2 +- lib/XMonad/Internal/Command/Power.hs | 6 +- .../Internal/Concurrent/ClientMessage.hs | 1 - .../Internal/Concurrent/DynamicWorkspaces.hs | 15 +- lib/XMonad/Internal/Concurrent/VirtualBox.hs | 4 +- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 4 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 4 +- .../DBus/Brightness/IntelBacklight.hs | 2 +- lib/XMonad/Internal/DBus/Control.hs | 53 +++---- lib/XMonad/Internal/DBus/Removable.hs | 8 +- lib/XMonad/Internal/DBus/Screensaver.hs | 19 ++- lib/XMonad/Internal/IO.hs | 7 +- lib/XMonad/Internal/Process.hs | 17 +++ lib/Xmobar/Plugins/BacklightCommon.hs | 9 +- lib/Xmobar/Plugins/Bluetooth.hs | 96 ++++++------ lib/Xmobar/Plugins/ClevoKeyboard.hs | 1 + lib/Xmobar/Plugins/Common.hs | 35 ++--- lib/Xmobar/Plugins/Device.hs | 8 +- lib/Xmobar/Plugins/IntelBacklight.hs | 1 + lib/Xmobar/Plugins/Screensaver.hs | 9 +- lib/Xmobar/Plugins/VPN.hs | 30 ++-- 26 files changed, 258 insertions(+), 285 deletions(-) create mode 100644 lib/XMonad/Internal/Process.hs diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 4f2e496..4a56132 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -56,20 +56,17 @@ main = getArgs >>= parse parse :: [String] -> IO () parse [] = run parse ["--deps"] = withCache printDeps -parse ["--test"] = withCache $ do - db <- connectDBus - void $ evalConfig db +parse ["--test"] = void $ withCache . evalConfig =<< connectDBus parse _ = usage run :: IO () -run = - withCache $ do - db <- connectDBus - c <- evalConfig db - disconnectDBus db - -- this is needed to see any printed messages - liftIO $ hFlush stdout - liftIO $ xmobar c +run = do + db <- connectDBus + c <- withCache $ evalConfig db + disconnectDBus db + -- this is needed to see any printed messages + hFlush stdout + xmobar c evalConfig :: DBusState -> FIO Config evalConfig db = do @@ -81,10 +78,10 @@ evalConfig db = do printDeps :: FIO () printDeps = do - db <- connectDBus + db <- io connectDBus let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db io $ mapM_ (putStrLn . T.unpack) ps - disconnectDBus db + io $ disconnectDBus db usage :: IO () usage = putStrLn $ intercalate "\n" diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 75ed5c4..316b242 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -8,8 +8,12 @@ module Main (main) where +import Control.Monad + import Data.Internal.DBus import Data.Internal.Dependency +import Data.List +import Data.Maybe import Data.Monoid import Data.Text.IO (hPutStrLn) @@ -19,7 +23,6 @@ import Graphics.X11.Xlib.Extras import RIO import RIO.Directory -import RIO.List import RIO.Process import qualified RIO.Text as T @@ -201,7 +204,7 @@ startChildDaemons :: FeatureSet -> FIO [Process () () ()] startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs) withDBusX :: (DBusState -> FIO a) -> FIO a -withDBusX = bracket connectDBusX cleanup +withDBusX = bracket (io connectDBusX) cleanup where cleanup db = do logInfo "unregistering xmonad from DBus" @@ -223,7 +226,7 @@ withXmobar = bracket startXmobar cleanup printDeps :: FIO () printDeps = do - db <- connectDBus + db <- io connectDBus (i, f, d) <- allFeatures db io $ mapM_ (putStrLn . T.unpack) $ fmap showFulfillment diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index 94a8c8f..0bfe459 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -27,9 +27,14 @@ module Data.Internal.DBus , bodyToMaybe ) where -import RIO -import qualified RIO.Map as M -import qualified RIO.Text as T +import Control.Exception +import Control.Monad + +import Data.Bifunctor +import qualified Data.Map.Strict as M +import Data.Maybe + +import qualified RIO.Text as T import DBus import DBus.Client @@ -40,38 +45,23 @@ import DBus.Client class SafeClient c where toClient :: c -> Client - getDBusClient - :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env) - => m (Maybe c) + getDBusClient :: IO (Maybe c) - disconnectDBusClient - :: (MonadUnliftIO m) - => c - -> m () - disconnectDBusClient = liftIO . disconnect . toClient + disconnectDBusClient :: c -> IO () + disconnectDBusClient = disconnect . toClient - withDBusClient - :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env) - => (c -> m a) - -> m (Maybe a) - -- TODO bracket + withDBusClient :: (c -> IO a) -> IO (Maybe a) withDBusClient f = do client <- getDBusClient forM client $ \c -> do r <- f c - liftIO $ disconnect (toClient c) + disconnect (toClient c) return r - withDBusClient_ - :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env) - => (c -> m ()) - -> m () + withDBusClient_ :: (c -> IO ()) -> IO () withDBusClient_ = void . withDBusClient - fromDBusClient - :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env) - => (c -> a) - -> m (Maybe a) + fromDBusClient :: (c -> a) -> IO (Maybe a) fromDBusClient f = withDBusClient (return . f) newtype SysClient = SysClient Client @@ -79,25 +69,20 @@ newtype SysClient = SysClient Client instance SafeClient SysClient where toClient (SysClient cl) = cl - getDBusClient = fmap SysClient <$> getDBusClient_ True + getDBusClient = fmap SysClient <$> getDBusClient' True newtype SesClient = SesClient Client instance SafeClient SesClient where toClient (SesClient cl) = cl - getDBusClient = fmap SesClient <$> getDBusClient_ False + getDBusClient = fmap SesClient <$> getDBusClient' False -getDBusClient_ - :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env) - => Bool - -> m (Maybe Client) -getDBusClient_ sys = do - res <- try $ liftIO $ if sys then connectSystem else connectSession +getDBusClient' :: Bool -> IO (Maybe Client) +getDBusClient' sys = do + res <- try $ if sys then connectSystem else connectSession case res of - Left e -> do - logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e - return Nothing + Left e -> putStrLn (clientErrorMessage e) >> return Nothing Right c -> return $ Just c -------------------------------------------------------------------------------- @@ -105,14 +90,12 @@ getDBusClient_ sys = do type MethodBody = Either T.Text [Variant] -callMethod' :: (MonadIO m, SafeClient c) => c -> MethodCall -> m MethodBody -callMethod' cl = - liftIO - . fmap (bimap (T.pack . methodErrorMessage) methodReturnBody) +callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody +callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody) . call (toClient cl) -callMethod :: (MonadIO m, SafeClient c) => c -> BusName -> ObjectPath -> InterfaceName - -> MemberName -> m MethodBody +callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName + -> MemberName -> IO MethodBody callMethod client bus path iface = callMethod' client . methodCallBus bus path iface methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall @@ -125,7 +108,7 @@ methodCallBus b p i m = (methodCall p i m) dbusInterface :: InterfaceName dbusInterface = interfaceName_ "org.freedesktop.DBus" -callGetNameOwner :: (MonadIO m, SafeClient c) => c -> BusName -> m (Maybe BusName) +callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName) callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc where mc = (methodCallBus dbusName dbusPath dbusInterface mem) @@ -146,14 +129,9 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant type SignalCallback = [Variant] -> IO () -addMatchCallback - :: (MonadIO m, SafeClient c) - => MatchRule - -> SignalCallback - -> c - -> m SignalHandler -addMatchCallback rule cb cl = - liftIO $ addMatch (toClient cl) rule $ cb . signalBody +addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c + -> IO SignalHandler +addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName -> Maybe MemberName -> MatchRule @@ -164,14 +142,8 @@ matchSignal b p i m = matchAny , matchMember = m } -matchSignalFull - :: (MonadIO m, SafeClient c) - => c - -> BusName - -> Maybe ObjectPath - -> Maybe InterfaceName - -> Maybe MemberName - -> m (Maybe MatchRule) +matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath + -> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule) matchSignalFull client b p i m = fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b @@ -184,29 +156,23 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties" propertySignal :: MemberName propertySignal = memberName_ "PropertiesChanged" -callPropertyGet :: (MonadIO m, SafeClient c) => BusName -> ObjectPath -> InterfaceName - -> MemberName -> c -> m [Variant] -callPropertyGet bus path iface property cl = - liftIO - $ fmap (either (const []) (:[])) +callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName + -> MemberName -> c -> IO [Variant] +callPropertyGet bus path iface property cl = fmap (either (const []) (:[])) $ getProperty (toClient cl) $ methodCallBus bus path iface property matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule matchProperty b p = matchSignal b p (Just propertyInterface) (Just propertySignal) -matchPropertyFull - :: (MonadIO m, SafeClient c) - => c - -> BusName - -> Maybe ObjectPath - -> m (Maybe MatchRule) +matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath + -> IO (Maybe MatchRule) matchPropertyFull cl b p = matchSignalFull cl b p (Just propertyInterface) (Just propertySignal) data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) -withSignalMatch :: Monad m => (Maybe a -> m ()) -> SignalMatch a -> m () +withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO () withSignalMatch f (Match x) = f (Just x) withSignalMatch f Failure = f Nothing withSignalMatch _ NoMatch = return () @@ -242,44 +208,24 @@ omInterfacesAdded = memberName_ "InterfacesAdded" omInterfacesRemoved :: MemberName omInterfacesRemoved = memberName_ "InterfacesRemoved" -callGetManagedObjects - :: (MonadIO m, SafeClient c) - => c - -> BusName - -> ObjectPath - -> m ObjectTree +callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath + -> IO ObjectTree callGetManagedObjects cl bus path = either (const M.empty) (fromMaybe M.empty . fromSingletonVariant) <$> callMethod cl bus path omInterface getManagedObjects -addInterfaceChangedListener - :: (MonadIO m, SafeClient c) - => BusName - -> MemberName - -> ObjectPath - -> SignalCallback - -> c - -> m (Maybe SignalHandler) +addInterfaceChangedListener :: SafeClient c => BusName -> MemberName + -> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler) addInterfaceChangedListener bus prop path sc cl = do rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop) forM rule $ \r -> addMatchCallback r sc cl -addInterfaceAddedListener - :: (MonadIO m, SafeClient c) - => BusName - -> ObjectPath - -> SignalCallback - -> c - -> m (Maybe SignalHandler) +addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath + -> SignalCallback -> c -> IO (Maybe SignalHandler) addInterfaceAddedListener bus = addInterfaceChangedListener bus omInterfacesAdded -addInterfaceRemovedListener - :: (MonadIO m, SafeClient c) - => BusName - -> ObjectPath - -> SignalCallback - -> c - -> m (Maybe SignalHandler) +addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath + -> SignalCallback -> c -> IO (Maybe SignalHandler) addInterfaceRemovedListener bus = addInterfaceChangedListener bus omInterfacesRemoved diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index 6a23520..930ce34 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -106,31 +106,38 @@ module Data.Internal.Dependency , shellTest ) where -import Data.Aeson hiding (Error, Result) +import Control.Monad.IO.Class +import Control.Monad.Identity +import Control.Monad.Reader + +import Data.Aeson hiding (Error, Result) import Data.Aeson.Key +import Data.Bifunctor +import Data.Either import Data.Internal.DBus +import Data.List +import Data.Maybe import Data.Yaml -import GHC.IO.Exception (ioe_description) +import GHC.IO.Exception (ioe_description) -import DBus hiding (typeOf) -import qualified DBus.Introspection as I +import DBus hiding (typeOf) +import qualified DBus.Introspection as I -import RIO hiding (bracket, fromString) -import RIO.Directory +import RIO hiding (bracket, fromString) import RIO.FilePath -import RIO.List -import RIO.Process hiding (findExecutable) -import qualified RIO.Text as T +import RIO.Process hiding (findExecutable) +import qualified RIO.Text as T +import System.Directory import System.Environment import System.IO.Error import System.Posix.Files -import System.Process.Typed (nullStream) +import System.Process.Typed (nullStream) -import XMonad.Core (X, io) +import XMonad.Core (X, io) import XMonad.Internal.IO -import XMonad.Internal.Shell hiding (proc, runProcess) +import XMonad.Internal.Shell hiding (proc, runProcess) import XMonad.Internal.Theme -------------------------------------------------------------------------------- diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 5d69630..2fb2477 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -24,9 +24,12 @@ import DBus import Graphics.X11.Types -import RIO.Directory import qualified RIO.Text as T +import System.Directory + ( XdgDirectory (..) + , getXdgDirectory + ) import System.IO import XMonad.Core hiding (spawn) diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 509bca0..6a4d00c 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -47,11 +47,11 @@ import Data.Internal.Dependency import DBus import RIO -import RIO.Directory import RIO.FilePath import qualified RIO.Process as P import qualified RIO.Text as T +import System.Directory import System.Environment import System.Posix.User diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index f376aa5..f9a83b2 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -29,15 +29,17 @@ module XMonad.Internal.Command.Power import Data.Internal.Dependency +import Data.Either +import qualified Data.Map as M + import Graphics.X11.Types import RIO -import RIO.Directory import RIO.FilePath -import qualified RIO.Map as M import qualified RIO.Process as P import qualified RIO.Text as T +import System.Directory import System.IO.Error import XMonad.Core hiding (spawn) diff --git a/lib/XMonad/Internal/Concurrent/ClientMessage.hs b/lib/XMonad/Internal/Concurrent/ClientMessage.hs index deda5a8..d5ee052 100644 --- a/lib/XMonad/Internal/Concurrent/ClientMessage.hs +++ b/lib/XMonad/Internal/Concurrent/ClientMessage.hs @@ -19,7 +19,6 @@ module XMonad.Internal.Concurrent.ClientMessage ( XMsgType(..) , sendXMsg , splitXMsg - , withOpenDisplay ) where import Data.Char diff --git a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs index 3a43626..4944611 100644 --- a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs +++ b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs @@ -33,7 +33,17 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces , doSink ) where +import Data.List (deleteBy, find) +import qualified Data.Map as M +import Data.Maybe + +-- import Control.Concurrent +import Control.Monad +import Control.Monad.Reader + + import Graphics.X11.Types + import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Event @@ -45,8 +55,6 @@ import RIO hiding ( Display , display ) -import RIO.List -import qualified RIO.Map as M import qualified RIO.Set as S import System.Process @@ -98,6 +106,9 @@ data WConf = WConf type W a = RIO WConf () +withOpenDisplay :: (Display -> IO a) -> IO a +withOpenDisplay = bracket (openDisplay "") closeDisplay + runWorkspaceMon :: [DynWorkspace] -> IO () runWorkspaceMon dws = withOpenDisplay $ \dpy -> do root <- rootWindow dpy $ defaultScreen dpy diff --git a/lib/XMonad/Internal/Concurrent/VirtualBox.hs b/lib/XMonad/Internal/Concurrent/VirtualBox.hs index 2695e74..7d1f857 100644 --- a/lib/XMonad/Internal/Concurrent/VirtualBox.hs +++ b/lib/XMonad/Internal/Concurrent/VirtualBox.hs @@ -12,13 +12,13 @@ module XMonad.Internal.Concurrent.VirtualBox import Data.Internal.Dependency +import Text.XML.Light + import RIO hiding (try) import RIO.Directory import RIO.FilePath import qualified RIO.Text as T -import Text.XML.Light - import XMonad.Internal.Shell vmExists :: T.Text -> IO (Maybe Msg) diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 1ce79f8..3395f4b 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -12,12 +12,14 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard , blPath ) where +import Control.Monad (when) + +import Data.Int (Int32) import Data.Internal.DBus import Data.Internal.Dependency import DBus -import RIO import RIO.FilePath import XMonad.Internal.DBus.Brightness.Common diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 05e6313..8146055 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -13,6 +13,9 @@ module XMonad.Internal.DBus.Brightness.Common , signalDep ) where +import Control.Monad (void) + +import Data.Int (Int32) import Data.Internal.DBus import Data.Internal.Dependency @@ -20,7 +23,6 @@ import DBus import DBus.Client import qualified DBus.Introspection as I -import RIO import qualified RIO.Text as T import XMonad.Core (io) diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index c79b557..9c29cae 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -12,12 +12,12 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight , blPath ) where +import Data.Int (Int32) import Data.Internal.DBus import Data.Internal.Dependency import DBus -import RIO import RIO.FilePath import XMonad.Internal.DBus.Brightness.Common diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index bb5d4fc..719a4c4 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -1,8 +1,8 @@ --- | High-level interface for managing XMonad's DBus - -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | High-level interface for managing XMonad's DBus + module XMonad.Internal.DBus.Control ( Client , DBusState(..) @@ -17,15 +17,14 @@ module XMonad.Internal.DBus.Control , dbusExporters ) where +import Control.Monad + import Data.Internal.DBus import Data.Internal.Dependency import DBus import DBus.Client -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 @@ -38,36 +37,27 @@ data DBusState = DBusState } -- | Connect to the DBus -connectDBus - :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env) - => m DBusState +connectDBus :: IO DBusState connectDBus = do ses <- getDBusClient sys <- getDBusClient return DBusState { dbSesClient = ses, dbSysClient = sys } -- | Disconnect from the DBus -disconnectDBus - :: (MonadUnliftIO m) - => DBusState -> m () +disconnectDBus :: DBusState -> IO () disconnectDBus db = disc dbSesClient >> disc dbSysClient where disc f = maybe (return ()) disconnectDBusClient $ f db -- | Connect to the DBus and request the XMonad name -connectDBusX - :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env) - => m DBusState +connectDBusX :: IO DBusState connectDBusX = do db <- connectDBus forM_ (dbSesClient db) requestXMonadName return db -- | Disconnect from DBus and release the XMonad name -disconnectDBusX - :: (MonadUnliftIO m) - => DBusState - -> m () +disconnectDBusX :: DBusState -> IO () disconnectDBusX db = do forM_ (dbSesClient db) releaseXMonadName disconnectDBus db @@ -76,25 +66,18 @@ disconnectDBusX db = do dbusExporters :: [Maybe SesClient -> SometimesIO] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] -releaseXMonadName - :: (MonadUnliftIO m) - => SesClient - -> m () -releaseXMonadName ses = void $ liftIO $ releaseName (toClient ses) xmonadBusName +releaseXMonadName :: SesClient -> IO () +releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName -requestXMonadName - :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env) - => SesClient - -> m () +requestXMonadName :: SesClient -> IO () requestXMonadName ses = do - res <- liftIO $ requestName (toClient ses) xmonadBusName [] + res <- requestName (toClient ses) xmonadBusName [] -- TODO if the client is not released on shutdown the owner will be different let msg | res == NamePrimaryOwner = Nothing - | res == NameAlreadyOwner = Just "this process already owns bus name" + | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn | res == NameInQueue - || res == NameExists = Just "another process owns bus name" - | otherwise = Just "unknown error when requesting bus name" - forM_ msg $ \m -> - logError $ Utf8Builder $ encodeUtf8Builder $ T.concat [m, ": ", xn] + || res == NameExists = Just $ "another process owns " ++ xn + | otherwise = Just $ "unknown error when requesting " ++ xn + forM_ msg putStrLn where - xn = T.pack $ formatBusName xmonadBusName + xn = "'" ++ formatBusName xmonadBusName ++ "'" diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index ed31e4a..e891314 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -8,15 +8,15 @@ module XMonad.Internal.DBus.Removable (runRemovableMon) where +import Control.Monad + import Data.Internal.DBus import Data.Internal.Dependency +import Data.Map.Strict (Map, member) import DBus import DBus.Client -import RIO -import qualified RIO.Map as M - import XMonad.Core (io) import XMonad.Internal.Command.Desktop @@ -60,7 +60,7 @@ driveFlag :: String driveFlag = "org.freedesktop.UDisks2.Drive" addedHasDrive :: [Variant] -> Bool -addedHasDrive [_, a] = maybe False (M.member driveFlag) +addedHasDrive [_, a] = maybe False (member driveFlag) (fromVariant a :: Maybe (Map String (Map String Variant))) addedHasDrive _ = False diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 8b5c6f5..81e8bab 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -14,15 +14,15 @@ module XMonad.Internal.DBus.Screensaver import Data.Internal.DBus import Data.Internal.Dependency -import DBus -import DBus.Client -import qualified DBus.Introspection as I - -import Graphics.X11.XScreenSaver - import RIO -import XMonad.Internal.Concurrent.ClientMessage +import DBus +import DBus.Client +import qualified DBus.Introspection as I + +import Graphics.X11.XScreenSaver +import Graphics.X11.Xlib.Display + import XMonad.Internal.DBus.Common import XMonad.Internal.Shell @@ -45,7 +45,10 @@ toggle = do query :: IO SSState query = do - xssi <- withOpenDisplay xScreenSaverQueryInfo + -- TODO bracket the display + dpy <- openDisplay "" + xssi <- xScreenSaverQueryInfo dpy + closeDisplay dpy return $ case xssi of Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False Just XScreenSaverInfo { xssi_state = _ } -> True diff --git a/lib/XMonad/Internal/IO.hs b/lib/XMonad/Internal/IO.hs index 87b374f..00e212f 100644 --- a/lib/XMonad/Internal/IO.hs +++ b/lib/XMonad/Internal/IO.hs @@ -25,11 +25,12 @@ module XMonad.Internal.IO ) where import Data.Char +import Data.Text (pack, unpack) +import Data.Text.IO as T (readFile, writeFile) import RIO import RIO.Directory import RIO.FilePath -import qualified RIO.Text as T import System.IO.Error @@ -37,7 +38,7 @@ import System.IO.Error -- | read readInt :: (Read a, Integral a) => FilePath -> IO a -readInt = fmap (read . T.unpack . T.takeWhile isDigit) . readFileUtf8 +readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile readBool :: FilePath -> IO Bool readBool = fmap (==(1 :: Int)) . readInt @@ -46,7 +47,7 @@ readBool = fmap (==(1 :: Int)) . readInt -- | write writeInt :: (Show a, Integral a) => FilePath -> a -> IO () -writeInt f = writeFileUtf8 f . T.pack . show +writeInt f = T.writeFile f . pack . show writeBool :: FilePath -> Bool -> IO () writeBool f b = writeInt f ((if b then 1 else 0) :: Int) diff --git a/lib/XMonad/Internal/Process.hs b/lib/XMonad/Internal/Process.hs new file mode 100644 index 0000000..1e493d6 --- /dev/null +++ b/lib/XMonad/Internal/Process.hs @@ -0,0 +1,17 @@ +-------------------------------------------------------------------------------- +-- | Functions for managing processes + +module XMonad.Internal.Process where + +-- import Control.Exception +-- import Control.Monad +-- import Control.Monad.IO.Class + +-- import qualified RIO.Text as T + +-- import System.Exit +-- import System.IO +-- import System.Process + +-- import XMonad.Core hiding (spawn) + diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index 9ca7a69..b8f9f7f 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -10,7 +10,6 @@ module Xmobar.Plugins.BacklightCommon (startBacklight) where import Data.Internal.DBus -import RIO import qualified RIO.Text as T import Xmobar.Plugins.Common @@ -18,9 +17,9 @@ import Xmobar.Plugins.Common startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ()) -> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO () startBacklight matchSignal callGetBrightness icon cb = do - withDBusClientConnection cb $ \c -> liftIO $ do - matchSignal dpy c - dpy =<< callGetBrightness c + withDBusClientConnection cb $ \c -> do + matchSignal display c + display =<< callGetBrightness c where formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"] - dpy = displayMaybe cb formatBrightness + display = displayMaybe cb formatBrightness diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 1fee0aa..9a9dbd9 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -38,16 +38,19 @@ module Xmobar.Plugins.Bluetooth , btDep ) where +import Control.Concurrent.MVar +import Control.Monad + import Data.Internal.DBus import Data.Internal.Dependency +import Data.List import Data.List.Split +import qualified Data.Map as M +import Data.Maybe import DBus import DBus.Client -import RIO -import RIO.List -import qualified RIO.Map as M import qualified RIO.Text as T import XMonad.Internal.DBus.Common @@ -68,24 +71,23 @@ instance Exec Bluetooth where start (Bluetooth icons colors) cb = withDBusClientConnection cb $ startAdapter icons colors cb -startAdapter :: MonadIO m => Icons -> Colors -> Callback -> SysClient -> m () +startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO () startAdapter is cs cb cl = do ot <- getBtObjectTree cl - -- TODO use RIO for this? state <- newMVar emptyState - let dpy = displayIcon cb (iconFormatter is cs) state - forM_ (findAdapter ot) $ \adapter -> liftIO $ do + let display = displayIcon cb (iconFormatter is cs) state + forM_ (findAdapter ot) $ \adapter -> do -- set up adapter initAdapter state adapter cl -- TODO this step could fail; at least warn the user... - void $ addAdaptorListener state dpy adapter cl + void $ addAdaptorListener state display adapter cl -- set up devices on the adapter (and listeners for adding/removing devices) let devices = findDevices adapter ot - addDeviceAddedListener state dpy adapter cl - addDeviceRemovedListener state dpy adapter cl - forM_ devices $ \d -> addAndInitDevice state dpy d cl + addDeviceAddedListener state display adapter cl + addDeviceRemovedListener state display adapter cl + forM_ devices $ \d -> addAndInitDevice state display d cl -- after setting things up, show the icon based on the initialized state - dpy + display -------------------------------------------------------------------------------- -- | Icon Display @@ -97,9 +99,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text) type Icons = (T.Text, T.Text) -displayIcon :: MonadIO m => Callback -> IconFormatter -> MutableBtState -> m () +displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO () displayIcon callback formatter = - liftIO . callback . T.unpack . uncurry formatter <=< readState + callback . T.unpack . uncurry formatter <=< readState -- TODO maybe I want this to fail when any of the device statuses are Nothing iconFormatter :: Icons -> Colors -> IconFormatter @@ -136,7 +138,7 @@ emptyState = BtState , btPowered = Nothing } -readState :: MonadIO m => MutableBtState -> m (Maybe Bool, Bool) +readState :: MutableBtState -> IO (Maybe Bool, Bool) readState state = do p <- readPowered state c <- readDevices state @@ -159,55 +161,55 @@ adaptorHasDevice adaptor device = case splitPath device of splitPath :: ObjectPath -> [T.Text] splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath -getBtObjectTree :: MonadIO m => SysClient -> m ObjectTree +getBtObjectTree :: SysClient -> IO ObjectTree getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath btOMPath :: ObjectPath btOMPath = objectPath_ "/" -addBtOMListener :: MonadIO m => SignalCallback -> SysClient -> m () -addBtOMListener sc = liftIO . void . addInterfaceAddedListener btBus btOMPath sc +addBtOMListener :: SignalCallback -> SysClient -> IO () +addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc -addDeviceAddedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m () -addDeviceAddedListener state dpy adapter client = +addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO () +addDeviceAddedListener state display adapter client = addBtOMListener addDevice client where - addDevice = pathCallback adapter dpy $ \d -> - addAndInitDevice state dpy d client + addDevice = pathCallback adapter display $ \d -> + addAndInitDevice state display d client -addDeviceRemovedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m () -addDeviceRemovedListener state dpy adapter sys = +addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO () +addDeviceRemovedListener state display adapter sys = addBtOMListener remDevice sys where - remDevice = pathCallback adapter dpy $ \d -> do + remDevice = pathCallback adapter display $ \d -> do old <- removeDevice state d forM_ old $ removeMatch (toClient sys) . btDevSigHandler pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback -pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d -> - when (adaptorHasDevice adapter d) $ f d >> dpy +pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d -> + when (adaptorHasDevice adapter d) $ f d >> display pathCallback _ _ _ _ = return () -------------------------------------------------------------------------------- -- | Adapter -initAdapter :: MonadIO m => MutableBtState -> ObjectPath -> SysClient -> m () +initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO () initAdapter state adapter client = do reply <- callGetPowered adapter client - liftIO $ putPowered state $ fromSingletonVariant reply + putPowered state $ fromSingletonVariant reply -matchBTProperty :: MonadIO m => SysClient -> ObjectPath -> m (Maybe MatchRule) +matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule) matchBTProperty sys p = matchPropertyFull sys btBus (Just p) -addAdaptorListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient - -> m (Maybe SignalHandler) -addAdaptorListener state dpy adaptor sys = do +addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient + -> IO (Maybe SignalHandler) +addAdaptorListener state display adaptor sys = do rule <- matchBTProperty sys adaptor forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys where - procMatch = withSignalMatch $ \b -> liftIO $ putPowered state b >> dpy + procMatch = withSignalMatch $ \b -> putPowered state b >> display -callGetPowered :: MonadIO m => ObjectPath -> SysClient -> m [Variant] +callGetPowered :: ObjectPath -> SysClient -> IO [Variant] callGetPowered adapter = callPropertyGet btBus adapter adapterInterface $ memberName_ $ T.unpack adaptorPowered @@ -217,7 +219,7 @@ matchPowered = matchPropertyChanged adapterInterface adaptorPowered putPowered :: MutableBtState -> Maybe Bool -> IO () putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds }) -readPowered :: MonadIO m => MutableBtState -> m (Maybe Bool) +readPowered :: MutableBtState -> IO (Maybe Bool) readPowered = fmap btPowered . readMVar adapterInterface :: InterfaceName @@ -229,13 +231,13 @@ adaptorPowered = "Powered" -------------------------------------------------------------------------------- -- | Devices -addAndInitDevice :: MonadUnliftIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m () -addAndInitDevice state dpy device client = do - sh <- addDeviceListener state dpy device client +addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO () +addAndInitDevice state display device client = do + sh <- addDeviceListener state display device client -- TODO add some intelligent error messages here forM_ sh $ \s -> initDevice state s device client -initDevice :: MonadUnliftIO m => MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> m () +initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO () initDevice state sh device sys = do reply <- callGetConnected device sys void $ insertDevice state device $ @@ -243,22 +245,22 @@ initDevice state sh device sys = do , btDevSigHandler = sh } -addDeviceListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient - -> m (Maybe SignalHandler) -addDeviceListener state dpy device sys = do +addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient + -> IO (Maybe SignalHandler) +addDeviceListener state display device sys = do rule <- matchBTProperty sys device forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys where - procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy + procMatch = withSignalMatch $ \c -> updateDevice state device c >> display matchConnected :: [Variant] -> SignalMatch Bool matchConnected = matchPropertyChanged devInterface devConnected -callGetConnected :: MonadIO m => ObjectPath -> SysClient -> m [Variant] +callGetConnected :: ObjectPath -> SysClient -> IO [Variant] callGetConnected p = callPropertyGet btBus p devInterface $ memberName_ (T.unpack devConnected) -insertDevice :: MonadUnliftIO m => MutableBtState -> ObjectPath -> BTDevice -> m Bool +insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool insertDevice m device dev = modifyMVar m $ \s -> do let new = M.insert device dev $ btDevices s return (s { btDevices = new }, anyDevicesConnected new) @@ -276,7 +278,7 @@ removeDevice m device = modifyMVar m $ \s -> do let devs = btDevices s return (s { btDevices = M.delete device devs }, M.lookup device devs) -readDevices :: MonadIO m => MutableBtState -> m ConnectedDevices +readDevices :: MutableBtState -> IO ConnectedDevices readDevices = fmap btDevices . readMVar devInterface :: InterfaceName diff --git a/lib/Xmobar/Plugins/ClevoKeyboard.hs b/lib/Xmobar/Plugins/ClevoKeyboard.hs index 67b45f5..92a8f12 100644 --- a/lib/Xmobar/Plugins/ClevoKeyboard.hs +++ b/lib/Xmobar/Plugins/ClevoKeyboard.hs @@ -14,6 +14,7 @@ module Xmobar.Plugins.ClevoKeyboard import qualified RIO.Text as T import Xmobar + import Xmobar.Plugins.BacklightCommon import XMonad.Internal.DBus.Brightness.ClevoKeyboard diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index 45b6eb0..d28ee2b 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -10,17 +10,18 @@ module Xmobar.Plugins.Common , Callback , Colors(..) , displayMaybe - , displayMaybe_ + , displayMaybe' , xmobarFGColor ) where +import Control.Monad + import Data.Internal.DBus import DBus import DBus.Client -import RIO import qualified RIO.Text as T import XMonad.Hooks.DynamicLog (xmobarColor) @@ -34,21 +35,17 @@ data Colors = Colors } deriving (Eq, Show, Read) -startListener :: (MonadIO m, SafeClient c, IsVariant a) => MatchRule -> (c -> m [Variant]) +startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant]) -> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback - -> c -> m () + -> c -> IO () startListener rule getProp fromSignal toColor cb client = do reply <- getProp client - displayMaybe cb (liftIO . toColor) $ fromSingletonVariant reply + displayMaybe cb toColor $ fromSingletonVariant reply void $ addMatchCallback rule (procMatch . fromSignal) client where procMatch = procSignalMatch cb toColor -procSignalMatch - :: Callback - -> (a -> IO T.Text) - -> SignalMatch a - -> IO () +procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO () procSignalMatch cb f = withSignalMatch (displayMaybe cb f) colorText :: Colors -> Bool -> T.Text -> T.Text @@ -61,17 +58,11 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack na :: T.Text na = "N/A" -displayMaybe :: (MonadIO m) => Callback -> (a -> m T.Text) -> Maybe a -> m () -displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f +displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO () +displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f -displayMaybe_ :: MonadIO m => Callback -> (a -> m ()) -> Maybe a -> m () -displayMaybe_ cb = maybe (liftIO $ cb $ T.unpack na) +displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO () +displayMaybe' cb = maybe (cb $ T.unpack na) -withDBusClientConnection - :: (SafeClient c) - => Callback - -> (c -> RIO SimpleApp ()) - -> IO () -withDBusClientConnection cb f = do - -- TODO be more sophisticated - runSimpleApp $ withDBusClient_ $ displayMaybe_ cb f . Just +withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO () +withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index e16db36..13abdb0 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -11,12 +11,14 @@ module Xmobar.Plugins.Device , devDep ) where +import Control.Monad + import Data.Internal.DBus import Data.Internal.Dependency +import Data.Word import DBus -import RIO import qualified RIO.Text as T import XMonad.Internal.Command.Desktop @@ -62,9 +64,9 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal instance Exec Device where alias (Device (iface, _, _)) = T.unpack iface start (Device (iface, text, colors)) cb = do - withDBusClientConnection cb $ \sys -> liftIO $ do + withDBusClientConnection cb $ \sys -> do path <- getDevice sys iface - displayMaybe_ cb (listener sys) path + displayMaybe' cb (listener sys) path where listener sys path = do rule <- matchPropertyFull sys networkManagerBus (Just path) diff --git a/lib/Xmobar/Plugins/IntelBacklight.hs b/lib/Xmobar/Plugins/IntelBacklight.hs index d9f35b3..e60a0fd 100644 --- a/lib/Xmobar/Plugins/IntelBacklight.hs +++ b/lib/Xmobar/Plugins/IntelBacklight.hs @@ -14,6 +14,7 @@ module Xmobar.Plugins.IntelBacklight import qualified RIO.Text as T import Xmobar + import Xmobar.Plugins.BacklightCommon import XMonad.Internal.DBus.Brightness.IntelBacklight diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index c511216..ef125cb 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -11,7 +11,6 @@ module Xmobar.Plugins.Screensaver , ssAlias ) where -import RIO import qualified RIO.Text as T import Xmobar @@ -27,9 +26,9 @@ ssAlias = "screensaver" instance Exec Screensaver where alias (Screensaver _) = T.unpack ssAlias start (Screensaver (text, colors)) cb = do - withDBusClientConnection cb $ \sys -> liftIO $ do - matchSignal dpy sys - dpy =<< callQuery sys + withDBusClientConnection cb $ \sys -> do + matchSignal display sys + display =<< callQuery sys where - dpy = displayMaybe cb $ return . (\s -> colorText colors s text) + display = displayMaybe cb $ return . (\s -> colorText colors s text) diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index c617d68..625abf8 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -13,15 +13,17 @@ module Xmobar.Plugins.VPN , vpnDep ) where +import Control.Concurrent.MVar +import Control.Monad import Data.Internal.DBus import Data.Internal.Dependency +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S import DBus -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 @@ -36,11 +38,11 @@ instance Exec VPN where start (VPN (text, colors)) cb = withDBusClientConnection cb $ \c -> do state <- initState c - let dpy = displayMaybe cb iconFormatter . Just =<< readState state - let signalCallback' f = f state dpy + let display = displayMaybe cb iconFormatter . Just =<< readState state + let signalCallback' f = f state display vpnAddedListener (signalCallback' addedCallback) c vpnRemovedListener (signalCallback' removedCallback) c - liftIO dpy + display where iconFormatter b = return $ colorText colors b text @@ -55,7 +57,7 @@ type VPNState = S.Set ObjectPath type MutableVPNState = MVar VPNState -initState :: MonadIO m => SysClient -> m MutableVPNState +initState :: SysClient -> IO MutableVPNState initState client = do ot <- getVPNObjectTree client newMVar $ findTunnels ot @@ -63,28 +65,28 @@ initState client = do readState :: MutableVPNState -> IO Bool readState = fmap (not . null) . readMVar -updateState :: MonadUnliftIO m => (ObjectPath -> VPNState -> VPNState) -> MutableVPNState - -> ObjectPath -> m () +updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState + -> ObjectPath -> IO () updateState f state op = modifyMVar_ state $ return . f op -------------------------------------------------------------------------------- -- | Tunnel Device Detection -- -getVPNObjectTree :: MonadIO m => SysClient -> m ObjectTree +getVPNObjectTree :: SysClient -> IO ObjectTree getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath findTunnels :: ObjectTree -> VPNState findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys) -vpnAddedListener :: MonadIO m => SignalCallback -> SysClient -> m () +vpnAddedListener :: SignalCallback -> SysClient -> IO () vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb -vpnRemovedListener :: MonadIO m => SignalCallback -> SysClient -> m () +vpnRemovedListener :: SignalCallback -> SysClient -> IO () vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb addedCallback :: MutableVPNState -> IO () -> SignalCallback -addedCallback state dpy [device, added] = update >> dpy +addedCallback state display [device, added] = update >> display where added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant)) is = M.keys $ fromMaybe M.empty added' @@ -92,7 +94,7 @@ addedCallback state dpy [device, added] = update >> dpy addedCallback _ _ _ = return () removedCallback :: MutableVPNState -> IO () -> SignalCallback -removedCallback state dpy [device, interfaces] = update >> dpy +removedCallback state display [device, interfaces] = update >> display where is = fromMaybe [] $ fromVariant interfaces :: [T.Text] update = updateDevice S.delete state device is