REF wrap everything in simpleapp

app/pinentry-rofi.hs

@@ -10,17 +10,17 @@ import Bitwarden.Internal
 import qualified Data.Text.IO as TI
 import Data.Yaml
 import RIO
+import RIO.Directory
 import qualified RIO.List as L
 import qualified RIO.Text as T
-import System.Directory
-import System.Environment
 import System.FilePath.Posix
 import System.Posix.Process
+import UnliftIO.Environment
 
 main :: IO ()
-main = do
+main = runSimpleApp $ do
   hSetBuffering stdout LineBuffering
-  TI.putStrLn "OK Pleased to meet you"
+  logInfo "OK Pleased to meet you"
   pinentryLoop =<< readPinConf
 
 newtype PinConf = PinConf {pcBwName :: T.Text} deriving (Eq, Show)
@@ -29,25 +29,27 @@ instance FromJSON PinConf where
   parseJSON (Object o) = PinConf <$> o .:? "bitwarden-name" .!= "gnupg"
   parseJSON _ = fail "pinentry yaml parse error"
 
-readPinConf :: IO PinConf
+readPinConf :: RIO SimpleApp PinConf
 readPinConf = do
-  c <- decodeFileEither =<< pinConfDir
+  c <- liftIO . decodeFileEither =<< pinConfDir
   case c of
-    Left e -> TI.putStrLn (T.pack $ show e) >> exitWith (ExitFailure 1)
+    Left e -> do
+      logError $ displayShow e
+      exitWith (ExitFailure 1)
     Right r -> return r
 
-pinConfDir :: IO FilePath
+pinConfDir :: RIO SimpleApp FilePath
 pinConfDir = maybe defHome (return . (</> confname)) =<< lookupEnv "GNUPGHOME"
   where
     defHome = (</> ".gnupg" </> confname) <$> getHomeDirectory
     confname = "pinentry-rofi.yml"
 
-pinentryLoop :: PinConf -> IO ()
+pinentryLoop :: PinConf -> RIO SimpleApp ()
 pinentryLoop p = do
-  processLine p . T.words =<< TI.getLine
+  processLine p . T.words =<< liftIO TI.getLine
   pinentryLoop p
 
-processLine :: PinConf -> [T.Text] -> IO ()
+processLine :: PinConf -> [T.Text] -> RIO SimpleApp ()
 processLine _ [] = noop
 processLine _ ["BYE"] = exitSuccess
 processLine p ["GETPIN"] = getPin p
@@ -66,33 +68,36 @@ processLine _ ["CONFIRM"] = noop
 processLine _ ["CONFIRM", "--one-button", _] = noop
 processLine _ ss = unknownCommand $ T.unwords ss
 
-unknownCommand :: T.Text -> IO ()
+unknownCommand :: T.Text -> RIO SimpleApp ()
-unknownCommand c = TI.putStrLn $ T.append "ERR 275 Unknown command " c
+unknownCommand c = putStrLnT $ T.append "ERR 275 Unknown command " c
 
-getPin :: PinConf -> IO ()
+getPin :: PinConf -> RIO SimpleApp ()
 getPin p = do
   its <- getItems
   let w = (password . login) =<< L.find (\i -> pcBwName p == name i) its
   maybe err send w
   where
-    err = TI.putStrLn "ERR 83886179 Operation canceled <rofi>"
+    err = putStrLnT "ERR 83886179 Operation canceled <rofi>"
 
 -- these are the only supported options for GETINFO; anything else is an error
-processGetInfo :: T.Text -> IO ()
+processGetInfo :: T.Text -> RIO SimpleApp ()
-processGetInfo "pid" = send . T.pack . show =<< getProcessID
+processGetInfo "pid" = send . T.pack . show =<< liftIO getProcessID
 processGetInfo "version" = noop
 processGetInfo "flavor" = noop
 processGetInfo "ttyinfo" = noop
-processGetInfo _ = TI.putStrLn "ERR 83886360 IPC parameter error <rofi>"
+processGetInfo _ = putStrLnT "ERR 83886360 IPC parameter error <rofi>"
 
-processOption :: T.Text -> IO ()
+processOption :: T.Text -> RIO SimpleApp ()
 processOption _ = noop
 
-send :: T.Text -> IO ()
+send :: T.Text -> RIO SimpleApp ()
-send s = TI.putStrLn (T.append "D " s) >> ok
+send s = putStrLnT (T.append "D " s) >> ok
 
-noop :: IO ()
+noop :: RIO SimpleApp ()
 noop = ok
 
-ok :: IO ()
+ok :: RIO SimpleApp ()
-ok = TI.putStrLn "OK"
+ok = putStrLnT "OK"
+
+putStrLnT :: MonadIO m => T.Text -> m ()
+putStrLnT = liftIO . TI.putStrLn

app/rofi-autorandr.hs

@@ -5,29 +5,27 @@
 
 module Main (main) where
 
-import Control.Monad
-import Data.Maybe
-import qualified Data.Text.IO as TI
 import RIO
+import RIO.Directory
 import qualified RIO.Text as T
 import Rofi.Command
-import System.Directory
-import System.Environment
 import System.FilePath.Posix
 import System.Process
+import UnliftIO.Environment
 
 main :: IO ()
-main = runChecks >> getArgs >>= runPrompt
+main = runSimpleApp $ do
+  runChecks
+  getArgs >>= runPrompt
 
--- TOOD not DRY
+runChecks :: (MonadReader c m, HasLogFunc c, MonadIO m) => m ()
-runChecks :: IO ()
 runChecks = checkExe "autorandr" >> checkExe "rofi"
 
-checkExe :: String -> IO ()
+checkExe :: (MonadReader c m, HasLogFunc c, MonadIO m) => String -> m ()
 checkExe cmd = do
   res <- findExecutable cmd
   unless (isJust res) $ do
-    TI.putStrLn $ T.append "Could not find executable: " $ T.pack cmd
+    logError $ displayBytesUtf8 $ encodeUtf8 $ T.append "Could not find executable: " $ T.pack cmd
     exitWith $ ExitFailure 1
 
 newtype ARClientConf = ARClientConf [T.Text]
@@ -35,7 +33,7 @@ newtype ARClientConf = ARClientConf [T.Text]
 instance HasRofiConf ARClientConf where
   defArgs (ARClientConf a) = a
 
-runPrompt :: [String] -> IO ()
+runPrompt :: MonadIO m => [String] -> m ()
 runPrompt a = do
   let c = ARClientConf $ fmap T.pack a
   staticProfs <- getAutoRandrProfiles
@@ -54,13 +52,13 @@ virtProfs :: [T.Text]
 virtProfs = ["off", "common", "clone-largest", "horizontal", "vertical"]
 
 -- TODO filter profiles based on which xrandr outputs are actually connected
-getAutoRandrProfiles :: IO [T.Text]
+getAutoRandrProfiles :: MonadIO m => m [T.Text]
 getAutoRandrProfiles = do
   dir <- getAutoRandrDir
   contents <- listDirectory dir
   (fmap T.pack) <$> filterM (doesDirectoryExist . (dir </>)) contents
 
-getAutoRandrDir :: IO FilePath
+getAutoRandrDir :: MonadIO m => m FilePath
 getAutoRandrDir = do
   c <- getXdgDirectory XdgConfig "autorandr"
   e <- doesDirectoryExist c
@@ -69,6 +67,7 @@ getAutoRandrDir = do
     appendToHome p = (</> p) <$> getHomeDirectory
 
 selectProfile :: T.Text -> RIO ARClientConf ()
-selectProfile name = liftIO $ do
+selectProfile name =
-  TI.putStrLn name
+  liftIO $
-  void $ spawnProcess "autorandr" ["--change", T.unpack name]
+    void $
+      spawnProcess "autorandr" ["--change", T.unpack name]

app/rofi-bt.hs

@@ -8,46 +8,53 @@ import DBus
 import DBus.Client
 import qualified Data.Map as M
 import Data.Maybe
-import qualified Data.Text.IO as TI
 import RIO
 import qualified RIO.List as L
 import qualified RIO.Text as T
 import Rofi.Command
-import System.Environment
+import UnliftIO.Environment
 
 main :: IO ()
-main = getArgs >>= runPrompt
+main = runSimpleApp $ getArgs >>= runPrompt
 
-data RofiBTConf = RofiBTConf [T.Text] ObjectPath
+data RofiBTConf = RofiBTConf
+  { btArgs :: ![T.Text]
+  , btAdapter :: !ObjectPath
+  , btEnv :: !SimpleApp
+  }
 
 instance HasRofiConf RofiBTConf where
-  defArgs (RofiBTConf as _) = as
+  defArgs = btArgs
+
+instance HasLogFunc RofiBTConf where
+  logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
 
 type BTAction = RofiAction RofiBTConf
 
-runPrompt :: [String] -> IO ()
+runPrompt :: [String] -> RIO SimpleApp ()
 runPrompt args = do
   c <- getClient
-  maybe (TI.putStrLn "could not get DBus client") run c
+  maybe (logError "could not get DBus client") run c
   where
     run client = do
       paths <- M.keys <$> getObjectTree client
-      maybe (TI.putStrLn "could not get DBus adapter") (actions client paths) $
+      case getAdapter paths of
-        getAdapter paths
+        Nothing -> logError "could not get DBus adapter"
-    actions client paths adapter = do
+        Just adapter -> do
           ras <- getRofiActions client paths
-      runRofi (RofiBTConf (fmap T.pack args) adapter) $
+          mapRIO (RofiBTConf (fmap T.pack args) adapter) $
+            selectAction $
               emptyMenu
                 { groups = [untitledGroup $ toRofiActions ras]
                 , prompt = Just "Select Device"
                 }
 
-getRofiActions :: Client -> [ObjectPath] -> IO [BTAction]
+getRofiActions :: MonadIO m => Client -> [ObjectPath] -> m [BTAction]
 getRofiActions client os = do
   devs <- getDevices client os
   catMaybes <$> mapM (deviceToRofiAction client) devs
 
-deviceToRofiAction :: Client -> ObjectPath -> IO (Maybe BTAction)
+deviceToRofiAction :: MonadIO m => Client -> ObjectPath -> m (Maybe BTAction)
 deviceToRofiAction client dev = do
   c <- getDeviceConnected client dev
   n <- getDeviceName client dev
@@ -64,11 +71,11 @@ deviceToRofiAction client dev = do
 
 powerAdapterMaybe :: Client -> RIO RofiBTConf ()
 powerAdapterMaybe client = do
-  (RofiBTConf _ adapter) <- ask
+  adapter <- asks btAdapter
   let mc = btMethodCall adapter i m
-  let powerOnMaybe = flip unless $ void $ setProperty client mc value
+  let powerOnMaybe = flip unless $ void $ liftIO $ setProperty client mc value
-  powered <- io $ getBTProperty client adapter i m
+  powered <- getBTProperty client adapter i m
-  io $ maybe (TI.putStrLn "could not get adapter powered status") powerOnMaybe powered
+  maybe (logError "could not get adapter powered status") powerOnMaybe powered
   where
     i = interfaceName_ "org.bluez.Adapter1"
     m = memberName_ "Powered"
@@ -85,12 +92,12 @@ formatDeviceEntry connected name = T.unwords [prefix connected, name]
 getAdapter :: [ObjectPath] -> Maybe ObjectPath
 getAdapter = L.find pathIsAdaptor
 
-getDevices :: Client -> [ObjectPath] -> IO [ObjectPath]
+getDevices :: MonadIO m => Client -> [ObjectPath] -> m [ObjectPath]
 getDevices client = filterM (getDevicePaired client) . filter pathIsDevice
 
 type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
 
-getObjectTree :: Client -> IO ObjectTree
+getObjectTree :: MonadIO m => Client -> m ObjectTree
 getObjectTree client =
   fromMaybe M.empty . eitherMaybe from <$> callBTMethod client o i m
   where
@@ -99,19 +106,19 @@ getObjectTree client =
     m = memberName_ "GetManagedObjects"
     from = fromVariant <=< listToMaybe . methodReturnBody
 
-getDeviceConnected :: Client -> ObjectPath -> IO (Maybe Bool)
+getDeviceConnected :: MonadIO m => Client -> ObjectPath -> m (Maybe Bool)
 getDeviceConnected = getDevProperty "Connected"
 
-getDeviceName :: Client -> ObjectPath -> IO (Maybe T.Text)
+getDeviceName :: MonadIO m => Client -> ObjectPath -> m (Maybe T.Text)
 getDeviceName = getDevProperty "Name"
 
-getDevicePaired :: Client -> ObjectPath -> IO Bool
+getDevicePaired :: MonadIO m => Client -> ObjectPath -> m Bool
 getDevicePaired c = fmap (fromMaybe False) . getDevProperty "Paired" c
 
-callDeviceConnect :: Client -> ObjectPath -> IO ()
+callDeviceConnect :: MonadIO m => Client -> ObjectPath -> m ()
 callDeviceConnect = callDevMethod "Connect"
 
-callDeviceDisconnect :: Client -> ObjectPath -> IO ()
+callDeviceDisconnect :: MonadIO m => Client -> ObjectPath -> m ()
 callDeviceDisconnect = callDevMethod "Disconnect"
 
 pathIsAdaptor :: ObjectPath -> Bool
@@ -130,39 +137,42 @@ pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `T.isPrefixOf` c
 splitPath :: ObjectPath -> [T.Text]
 splitPath = T.split (== '/') . T.dropWhile (== '/') . T.pack . formatObjectPath
 
-getClient :: IO (Maybe Client)
+getClient :: (MonadReader c m, HasLogFunc c, MonadUnliftIO m) => m (Maybe Client)
-getClient = either warn (return . Just) =<< try connectSystem
+getClient = either warn (return . Just) =<< try (liftIO connectSystem)
   where
-    warn e = TI.putStrLn (T.pack $ clientErrorMessage e) >> return Nothing
+    warn e = do
+      logWarn $ displayBytesUtf8 $ encodeUtf8 $ (T.pack $ clientErrorMessage e)
+      return Nothing
 
-callDevMethod :: T.Text -> Client -> ObjectPath -> IO ()
+callDevMethod :: MonadIO m => T.Text -> Client -> ObjectPath -> m ()
 callDevMethod mem client dev =
   void $ callBTMethod client dev btDevInterface $ memberName_ $ T.unpack mem
 
-getDevProperty :: IsVariant a => T.Text -> Client -> ObjectPath -> IO (Maybe a)
+getDevProperty :: (MonadIO m, IsVariant a) => T.Text -> Client -> ObjectPath -> m (Maybe a)
 getDevProperty mem client dev =
   getBTProperty client dev btDevInterface $ memberName_ $ T.unpack mem
 
 callBTMethod
-  :: Client
+  :: MonadIO m
+  => Client
   -> ObjectPath
   -> InterfaceName
   -> MemberName
-  -> IO (Either MethodError MethodReturn)
+  -> m (Either MethodError MethodReturn)
-callBTMethod client o i m = call client (btMethodCall o i m)
+callBTMethod client o i m = liftIO $ call client (btMethodCall o i m)
 
 -- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
 -- <$> call client (btMethodCall o i m)
 
 getBTProperty
-  :: IsVariant a
+  :: (MonadIO m, IsVariant a)
   => Client
   -> ObjectPath
   -> InterfaceName
   -> MemberName
-  -> IO (Maybe a)
+  -> m (Maybe a)
 getBTProperty client o i m =
-  eitherMaybe fromVariant <$> getProperty client (btMethodCall o i m)
+  eitherMaybe fromVariant <$> (liftIO $ getProperty client (btMethodCall o i m))
 
 btMethodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall
 btMethodCall o i m = (methodCall o i m) {methodCallDestination = Just btBus}

app/rofi-bw.hs

@@ -17,36 +17,37 @@
 module Main (main) where
 
 import Bitwarden.Internal
-import qualified Data.Text.IO as TI
 import RIO
 import RIO.Directory
 import qualified RIO.Text as T
-import Rofi.Command
+import UnliftIO.Environment
-import System.Environment
 
 main :: IO ()
-main = runChecks >> getArgs >>= parse
+main = runSimpleApp $ runChecks >> getArgs >>= parse
 
 -- TODO check if daemon is running when running client
-parse :: [String] -> IO ()
+parse :: HasLogFunc c => [String] -> RIO c ()
 parse ["-d", t] = case readMaybe t of Just t' -> runDaemon t'; _ -> usage
 parse ("-c" : args) = runClient $ fmap T.pack args
 parse _ = usage
 
-usage :: IO ()
+usage :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
 usage =
-  TI.putStrLn $
+  logInfo $
-    joinNewline
+    displayBytesUtf8 $
+      encodeUtf8 $
+        T.unlines
           [ "daemon mode: rofi-bw -d TIMEOUT"
           , "client mode: rofi-bw -c [ROFI-ARGS]"
           ]
 
-runChecks :: IO ()
+runChecks :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
 runChecks = checkExe "bw" >> checkExe "rofi"
 
-checkExe :: String -> IO ()
+-- TODO not DRY
+checkExe :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => String -> m ()
 checkExe cmd = do
   res <- findExecutable cmd
   unless (isJust res) $ do
-    TI.putStrLn $ T.append "Could not find executable: " $ T.pack cmd
+    logError $ displayBytesUtf8 $ encodeUtf8 $ T.append "Could not find executable: " $ T.pack cmd
     exitWith $ ExitFailure 1

app/rofi-dev.hs

@@ -12,7 +12,6 @@
 module Main (main) where
 
 import Bitwarden.Internal
-import qualified Data.Text.IO as TI
 import Dhall hiding (maybe, sequence, void)
 import Dhall.TH
 import RIO
@@ -23,10 +22,10 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import Rofi.Command
 import System.Console.GetOpt
-import System.Environment
 import System.FilePath.Posix
 import System.Posix.User (getEffectiveUserName)
 import System.Process
+import UnliftIO.Environment
 
 --------------------------------------------------------------------------------
 -- Static device configuration (dhall)
@@ -51,12 +50,17 @@ makeHaskellTypesWith
   ]
 
 main :: IO ()
-main = getArgs >>= parse
+main = runSimpleApp $ getArgs >>= parse
 
-parse :: [String] -> IO ()
+parse :: [String] -> RIO SimpleApp ()
 parse args = case getOpt Permute options args of
   (o, n, []) -> runMounts $ L.foldl (flip id) (defaultOpts (fmap T.pack n)) o
-  (_, _, errs) -> TI.putStrLn $ T.pack $ concat errs ++ usageInfo h options
+  (_, _, errs) ->
+    logError $
+      displayBytesUtf8 $
+        encodeUtf8 $
+          T.pack $
+            concat errs ++ usageInfo h options
   where
     h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
     defaultOpts r =
@@ -101,29 +105,35 @@ data Opts = Opts
 -- mounts grouped by device type (eg removable, sshfs, cifs, etc). I like
 -- pretty things, so ensure the entries are aligned properly as well
 
-runMounts :: Opts -> IO ()
+runMounts :: Opts -> RIO SimpleApp ()
 runMounts opts = do
   static <- join <$> traverse parseStaticConfig (optsConfig opts)
-  defaultTmpPath <- ("/tmp/media" </>) <$> getEffectiveUserName
+  defaultTmpPath <- ("/tmp/media" </>) <$> liftIO getEffectiveUserName
   let tmpPath = fromMaybe defaultTmpPath $ (fmap T.unpack . scTmpPath) =<< static
   let staticDevs = maybe M.empty (M.fromList . fmap (\(TreeMap k v) -> (k, v)) . scDevices) static
   let verbose = fromMaybe False $ scVerbose =<< static
-  let mountconf =
+  let mountconf e =
         MountConf
           { mountconfVolatilePath = tmpPath
           , mountconfRofiArgs = optsRofiArgs opts
           , mountconfStaticDevs = staticDevs
           , mountconfVerbose = verbose
+          , mountconfEnv = e
           }
   let byAlias = mountByAlias $ optsUnmount opts
   let byPrompt = runPrompt =<< getGroups
-  runRIO mountconf $ maybe byPrompt byAlias $ optsAlias opts
+  mapRIO mountconf $ maybe byPrompt byAlias $ optsAlias opts
 
-parseStaticConfig :: FilePath -> IO (Maybe StaticConfig)
+parseStaticConfig
+  :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m)
+  => FilePath
+  -> m (Maybe StaticConfig)
 parseStaticConfig p = do
-  res <- tryIO $ inputFile auto p
+  res <- tryIO $ liftIO $ inputFile auto p
   case res of
-    Left e -> TI.putStrLn (T.pack $ show e) >> return Nothing
+    Left e -> do
+      logError $ displayBytesUtf8 $ encodeUtf8 $ T.pack $ show e
+      return Nothing
     Right c -> return $ Just c
 
 runPrompt :: HasRofiConf c => [RofiGroup c] -> RIO c ()
@@ -134,7 +144,7 @@ runPrompt gs =
       , prompt = Just "Select Device"
       }
 
-getGroups :: RofiMountIO [RofiGroup MountConf]
+getGroups :: MIO [RofiGroup MountConf]
 getGroups = do
   actions <- sequence [getStaticActions, getRemovableActions, getMTPActions]
   return $
@@ -147,17 +157,17 @@ getGroups = do
       titledGroup "Meta Actions" $
         toRofiActions [("  Dismount All", dismountAll)]
 
-dismountAll :: RofiMountIO ()
+dismountAll :: MIO ()
 dismountAll = do
   umount =<< asks (configToTree' . mountconfStaticDevs)
   umount =<< getRemovableDevices
   umount =<< getMTPDevices
   return ()
   where
-    umount :: Mountable a => [a] -> RofiMountIO ()
+    umount :: Mountable a => [a] -> MIO ()
     umount = mapM_ (`mountMaybe` True)
 
-mountByAlias :: Bool -> T.Text -> RofiMountIO ()
+mountByAlias :: Bool -> T.Text -> MIO ()
 mountByAlias unmountFlag alias = do
   static <- asks mountconfStaticDevs
   mapM_ (`mountMaybe` unmountFlag) $ configToTree static <$> M.lookup alias static
@@ -170,7 +180,7 @@ mkGroup as = titledGroup h $ toRofiActions $ NE.toList $ alignEntries $ snd <$>
 alignSep :: T.Text
 alignSep = " | "
 
-alignEntries :: NE.NonEmpty (ProtoAction) -> NE.NonEmpty (T.Text, RofiMountIO ())
+alignEntries :: NE.NonEmpty (ProtoAction) -> NE.NonEmpty (T.Text, MIO ())
 alignEntries ps = NE.zip (align es) as
   where
     (es, as) = NE.unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
@@ -195,6 +205,7 @@ data MountConf = MountConf
   , mountconfRofiArgs :: [T.Text]
   , mountconfStaticDevs :: M.Map T.Text TreeConfig
   , mountconfVerbose :: Bool
+  , mountconfEnv :: !SimpleApp
   }
 
 -- deriving (Show)
@@ -202,6 +213,9 @@ data MountConf = MountConf
 instance HasRofiConf MountConf where
   defArgs MountConf {mountconfRofiArgs = a} = a
 
+instance HasLogFunc MountConf where
+  logFuncL = lens mountconfEnv (\x y -> x {mountconfEnv = y}) . logFuncL
+
 --------------------------------------------------------------------------------
 -- Mountable typeclass
 --
@@ -215,9 +229,9 @@ mountedState _ = False
 
 class Mountable a where
   -- | Mount the given type (or dismount if False is passed)
-  mount :: a -> Bool -> RofiMountIO MountResult
+  mount :: a -> Bool -> MIO MountResult
 
-  mountMaybe :: a -> Bool -> RofiMountIO ()
+  mountMaybe :: a -> Bool -> MIO ()
   mountMaybe dev mountFlag = do
     let lab = getLabel dev
     mounted <- isMounted dev
@@ -232,16 +246,16 @@ class Mountable a where
             return ()
 
   -- | Check if the mounting utilities are present
-  allInstalled :: a -> RofiMountIO Bool
+  allInstalled :: a -> MIO Bool
 
   -- | Return a string representing the label of the device
   getLabel :: a -> T.Text
 
   -- | Determine if the given type is mounted or not
-  isMounted :: a -> RofiMountIO Bool
+  isMounted :: a -> MIO Bool
   isMounted dev = mountedState <$> mountState dev
 
-  mountState :: a -> RofiMountIO MountState
+  mountState :: a -> MIO MountState
 
 --------------------------------------------------------------------------------
 -- Actionable typeclass
@@ -261,7 +275,7 @@ class Mountable a => Actionable a where
 
   -- | Given a mountable type, return a rofi action (string to go in the
   -- Rofi prompt and an action to perform when it is selected)
-  mkAction :: a -> RofiMountIO (Header, ProtoAction)
+  mkAction :: a -> MIO (Header, ProtoAction)
   mkAction dev = do
     m <- mountState dev
     i <- allInstalled dev
@@ -278,11 +292,11 @@ class Mountable a => Actionable a where
 
 mountableToAction
   :: Actionable a
-  => RofiMountIO [a]
+  => MIO [a]
-  -> RofiMountIO [(Header, ProtoAction)]
+  -> MIO [(Header, ProtoAction)]
 mountableToAction ms = mapM mkAction =<< ms
 
-type RofiMountIO a = RIO MountConf a
+type MIO a = RIO MountConf a
 
 -- headers appear in the order listed here (per Enum)
 data Header
@@ -303,7 +317,7 @@ instance Show Header where
     where
       suffix = (++ " Devices")
 
-data ProtoAction = ProtoAction (NE.NonEmpty T.Text) (RofiMountIO ())
+data ProtoAction = ProtoAction (NE.NonEmpty T.Text) (MIO ())
 
 --------------------------------------------------------------------------------
 -- Static devices trees
@@ -367,7 +381,6 @@ instance Mountable DeviceConfig where
   mount DeviceConfig {deviceMount = m, deviceData = devData} False = do
     m' <- getAbsMountpoint m
     withTmpMountDir m' $
-      io $
       case devData of
         SSHFSConfig (SSHFSData {sshfsRemote = r, sshfsPassword = p}) ->
           mountSSHFS m' p r
@@ -416,19 +429,25 @@ instance Mountable DeviceConfig where
       { deviceMount = MountConfig {mpPath = p, mpLabel = l}
       } = fromMaybe (T.pack $ takeFileName $ T.unpack p) l
 
-mountSSHFS :: FilePath -> Maybe PasswordConfig -> T.Text -> IO MountResult
+mountSSHFS
+  :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m)
+  => FilePath
+  -> Maybe PasswordConfig
+  -> T.Text
+  -> m MountResult
 mountSSHFS mountpoint pwdConfig remote =
   withPasswordGetter pwdConfig (run ["-o", "password_stdin"]) $ run [] ""
   where
     run other = runMount "sshfs" (other ++ [remote, T.pack mountpoint])
 
 mountCIFS
-  :: Bool
+  :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m)
+  => Bool
   -> T.Text
   -> FilePath
   -> Maybe CIFSOpts
   -> Maybe PasswordConfig
-  -> IO MountResult
+  -> m MountResult
 mountCIFS useSudo remote mountpoint opts pwdConfig =
   withPasswordGetter pwdConfig runPwd run
   where
@@ -448,7 +467,12 @@ fromCIFSOpts o = T.intercalate "," $ mapMaybe concatMaybe fs
       ]
     concatMaybe (k, f) = (\v -> T.concat [k, "=", v]) <$> f o
 
-mountVeracrypt :: FilePath -> Maybe PasswordConfig -> T.Text -> IO MountResult
+mountVeracrypt
+  :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m)
+  => FilePath
+  -> Maybe PasswordConfig
+  -> T.Text
+  -> m MountResult
 mountVeracrypt mountpoint pwdConfig volume =
   withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"])) $
     runVeraCrypt args ""
@@ -457,12 +481,12 @@ mountVeracrypt mountpoint pwdConfig volume =
 
 -- NOTE: the user is assumed to have added themselves to the sudoers file so
 -- that this command will work
-runVeraCrypt :: [T.Text] -> T.Text -> IO MountResult
+runVeraCrypt :: MonadIO m => [T.Text] -> T.Text -> m MountResult
 runVeraCrypt args = runMount "sudo" (defaultArgs ++ args)
   where
     defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]
 
-veracryptMountState :: MountConfig -> RofiMountIO MountState
+veracryptMountState :: MountConfig -> MIO MountState
 veracryptMountState mc = do
   mp <- getAbsMountpoint mc
   primary <- io $ lookupSpec mp
@@ -479,29 +503,29 @@ veracryptMountState mc = do
       Just (i, _) -> if i `elem` ['0' .. '9'] then Just i else Nothing
       _ -> Nothing
 
-getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
+getAbsMountpoint :: MountConfig -> MIO FilePath
 getAbsMountpoint MountConfig {mpPath = m} =
   asks $ flip appendRoot (T.unpack m) . mountconfVolatilePath
 
-getStaticActions :: RofiMountIO [(Header, ProtoAction)]
+getStaticActions :: MIO [(Header, ProtoAction)]
 getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
 
 --------------------------------------------------------------------------------
 -- Password-getting functions for static devices
 
-type PasswordGetter = IO (Maybe T.Text)
+type PasswordGetter m = m (Maybe T.Text)
 
-runSecret :: M.Map T.Text T.Text -> PasswordGetter
+runSecret :: MonadUnliftIO m => M.Map T.Text T.Text -> PasswordGetter m
 runSecret kvs = readCmdSuccess "secret-tool" ("lookup" : kvs') ""
   where
     kvs' = concatMap (\(k, v) -> [k, v]) $ M.toList kvs
 
-runBitwarden :: T.Text -> PasswordGetter
+runBitwarden :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => T.Text -> PasswordGetter m
 runBitwarden pname =
   ((password . login) <=< L.find (\i -> name i == pname))
     <$> getItems
 
-runPromptLoop :: Natural -> PasswordGetter -> PasswordGetter
+runPromptLoop :: MonadUnliftIO m => Natural -> PasswordGetter m -> PasswordGetter m
 runPromptLoop n pwd = do
   res <- pwd
   if isNothing res
@@ -523,17 +547,18 @@ runPromptLoop n pwd = do
 --     getPrompt = maybe (return Nothing) (flip runPromptLoop readPassword . promptTries)
 --     runMaybe x y = (\r -> if isNothing r then y else return r) =<< x
 
-configToPwd :: PasswordConfig -> PasswordGetter
+configToPwd :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => PasswordConfig -> PasswordGetter m
 configToPwd (PwdBW (BitwardenConfig {bwKey = k, bwTries = n})) =
   runPromptLoop n $ runBitwarden k
 configToPwd (PwdLS s) = runSecret $ M.fromList $ fmap (\(SecretMap k v) -> (k, v)) $ secretAttributes s
 configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
 
 withPasswordGetter
-  :: Maybe PasswordConfig
+  :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m)
-  -> (T.Text -> IO MountResult)
+  => Maybe PasswordConfig
-  -> IO MountResult
+  -> (T.Text -> m MountResult)
-  -> IO MountResult
+  -> m MountResult
+  -> m MountResult
 withPasswordGetter (Just pwdConfig) runPwd _ =
   maybe (return $ MountError "Password could not be obtained") runPwd
     =<< configToPwd pwdConfig
@@ -590,7 +615,7 @@ getRemovableDevices =
       _ -> Nothing
     mk d l = Just $ Removable {removablePath = d, removableLabel = l}
 
-getRemovableActions :: RofiMountIO [(Header, ProtoAction)]
+getRemovableActions :: MIO [(Header, ProtoAction)]
 getRemovableActions = mountableToAction getRemovableDevices
 
 --------------------------------------------------------------------------------
@@ -625,7 +650,7 @@ instance Mountable MTPFS where
   getLabel = mtpfsDescription
 
 -- | Return list of all available MTP devices
-getMTPDevices :: RofiMountIO [MTPFS]
+getMTPDevices :: MIO [MTPFS]
 getMTPDevices = do
   i <- io mtpExeInstalled
   if i then go else return []
@@ -656,7 +681,7 @@ getMTPDevices = do
       | c == ' ' = Just '-'
       | otherwise = Just c
 
-getMTPActions :: RofiMountIO [(Header, ProtoAction)]
+getMTPActions :: MIO [(Header, ProtoAction)]
 getMTPActions = mountableToAction getMTPDevices
 
 mtpExeInstalled :: IO Bool
@@ -697,19 +722,19 @@ notify icon summary body =
 
 data MountResult = MountSuccess | MountError T.Text deriving (Show, Eq)
 
-runMount :: T.Text -> [T.Text] -> T.Text -> IO MountResult
+runMount :: MonadIO m => T.Text -> [T.Text] -> T.Text -> m MountResult
 runMount cmd args stdin_ = eitherToMountResult <$> readCmdEither cmd args stdin_
 
-runMount' :: T.Text -> [T.Text] -> T.Text -> [(T.Text, T.Text)] -> IO MountResult
+runMount' :: MonadIO m => T.Text -> [T.Text] -> T.Text -> [(T.Text, T.Text)] -> m MountResult
 runMount' cmd args stdin_ environ =
   eitherToMountResult
     <$> readCmdEither' cmd args stdin_ environ
 
-runMountSudoMaybe :: Bool -> T.Text -> [T.Text] -> IO MountResult
+runMountSudoMaybe :: MonadIO m => Bool -> T.Text -> [T.Text] -> m MountResult
 runMountSudoMaybe useSudo cmd args =
   runMountSudoMaybe' useSudo cmd args []
 
-runMountSudoMaybe' :: Bool -> T.Text -> [T.Text] -> [(T.Text, T.Text)] -> IO MountResult
+runMountSudoMaybe' :: MonadIO m => Bool -> T.Text -> [T.Text] -> [(T.Text, T.Text)] -> m MountResult
 runMountSudoMaybe' useSudo cmd args environ =
   maybe
     (runMount' cmd args "" environ)
@@ -720,7 +745,7 @@ runMountSudoMaybe' useSudo cmd args environ =
 -- runSudoMount :: T.Text -> T.Text -> [T.Text] -> T.Text -> IO MountResult
 -- runSudoMount rootpass cmd args stdin = runSudoMount' rootpass cmd args stdin []
 
-runSudoMount' :: T.Text -> T.Text -> [T.Text] -> [(T.Text, T.Text)] -> IO MountResult
+runSudoMount' :: MonadIO m => T.Text -> T.Text -> [T.Text] -> [(T.Text, T.Text)] -> m MountResult
 runSudoMount' rootpass cmd args environ = runMount "sudo" args' rootpass
   where
     args' = ["-S"] ++ environ' ++ [cmd] ++ args
@@ -758,7 +783,7 @@ lookupSpec mountpoint = M.lookup mountpoint <$> mountMap
 -- base path in /tmp, so all this is saying is that umounting everything will
 -- leave /tmp/media/USER without removing all the way down to /tmp)
 
-rmDirOnMountError :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
+rmDirOnMountError :: FilePath -> MIO MountResult -> MIO MountResult
 rmDirOnMountError d f = do
   res <- f
   unless (res == MountSuccess) $ rmDirMaybe d
@@ -766,22 +791,22 @@ rmDirOnMountError d f = do
 
 -- | Run a mount command and create the mountpoint if it does not exist, and
 -- remove the mountpoint if a mount error occurs
-withTmpMountDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
+withTmpMountDir :: FilePath -> MIO MountResult -> MIO MountResult
 withTmpMountDir m =
   rmDirOnMountError m
     . bracketOnError_ (mkDirMaybe m) (rmDirMaybe m)
 
 -- | Run an unmount command and remove the mountpoint if no errors occur
-runAndRemoveDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
+runAndRemoveDir :: FilePath -> MIO MountResult -> MIO MountResult
 runAndRemoveDir m f = do
   res <- catch f (return . MountError . (T.pack . displayException :: SomeException -> T.Text))
   when (res == MountSuccess) $ rmDirMaybe m
   return res
 
-mkDirMaybe :: FilePath -> RofiMountIO ()
+mkDirMaybe :: FilePath -> MIO ()
 mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp
 
-rmDirMaybe :: FilePath -> RofiMountIO ()
+rmDirMaybe :: FilePath -> MIO ()
 rmDirMaybe fp =
   whenInMountDir fp $
     unlessMountpoint fp $
@@ -791,7 +816,7 @@ rmDirMaybe fp =
       removePathForcibly cur
       rmUntil (takeDirectory cur) target
 
-whenInMountDir :: FilePath -> RofiMountIO () -> RofiMountIO ()
+whenInMountDir :: FilePath -> MIO () -> MIO ()
 whenInMountDir fp f = do
   mDir <- asks mountconfVolatilePath
   when (mDir `L.isPrefixOf` fp) f

app/rofi-evpn.hs

@@ -4,17 +4,16 @@
 
 module Main (main) where
 
-import Data.Maybe
 import RIO
 import qualified RIO.Text as T
 import Rofi.Command
-import System.Environment
 import System.Process
+import UnliftIO.Environment
 
 main :: IO ()
-main = getArgs >>= runPrompt
+main = runSimpleApp $ getArgs >>= runPrompt
 
-runPrompt :: [String] -> IO ()
+runPrompt :: [String] -> RIO SimpleApp ()
 runPrompt args = do
   servers <- getServers
   maybe (return ()) run servers
@@ -42,19 +41,19 @@ type VPNServer = (T.Text, T.Text)
 
 data VPNStatus = VPNStatus (Maybe T.Text) [VPNServer] deriving (Show)
 
-getServers :: IO (Maybe VPNStatus)
+getServers :: MonadIO m => m (Maybe VPNStatus)
 getServers = do
   running <- daemonIsRunning
   if running
     then Just <$> getStatus
     else notify IconError "ExpressVPN daemon not running" >> return Nothing
 
-getStatus :: IO VPNStatus
+getStatus :: MonadIO m => m VPNStatus
 getStatus = do
   connected <- getConnectedServer
   VPNStatus connected <$> getAvailableServers
 
-getConnectedServer :: IO (Maybe T.Text)
+getConnectedServer :: MonadIO m => m (Maybe T.Text)
 getConnectedServer = (procStatus =<<) <$> readCmdSuccess eVPN ["status"] ""
   where
     procStatus = listToMaybe . mapMaybe procLine . T.lines
@@ -63,7 +62,7 @@ getConnectedServer = (procStatus =<<) <$> readCmdSuccess eVPN ["status"] ""
       ("\ESC[1;32;49mConnected" : "to" : server) -> Just $ T.unwords server
       _ -> Nothing
 
-getAvailableServers :: IO [VPNServer]
+getAvailableServers :: MonadIO m => m [VPNServer]
 getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
   where
     procOut Nothing = do
@@ -91,7 +90,7 @@ getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
     matchLine [i, _, _, _, l] = Just (i, l)
     matchLine _ = Nothing
 
-daemonIsRunning :: IO Bool
+daemonIsRunning :: MonadIO m => m Bool
 daemonIsRunning = isJust <$> readCmdSuccess "pgrep" [eVPND] ""
 
 getDisconnectAction :: T.Text -> VPNAction
@@ -119,7 +118,7 @@ eVPN = "expressvpn"
 eVPND :: T.Text
 eVPND = "expressvpnd"
 
-connect :: VPNServer -> IO ()
+connect :: MonadIO m => VPNServer -> m ()
 connect (sid, sname) = do
   res <- readCmdSuccess' eVPN ["connect", sid]
   notifyIf
@@ -127,7 +126,7 @@ connect (sid, sname) = do
     (T.append "connected to " sname)
     (T.append "failed to connect to " sname)
 
-disconnect :: T.Text -> IO Bool
+disconnect :: MonadIO m => T.Text -> m Bool
 disconnect server = do
   res <- readCmdSuccess' eVPN ["disconnect"]
   notifyIf
@@ -136,7 +135,7 @@ disconnect server = do
     (T.append "failed to disconnect from " server)
   return res
 
-readCmdSuccess' :: T.Text -> [T.Text] -> IO Bool
+readCmdSuccess' :: MonadIO m => T.Text -> [T.Text] -> m Bool
 readCmdSuccess' cmd args = isJust <$> readCmdSuccess cmd args ""
 
 -- TODO not DRY
@@ -146,12 +145,12 @@ instance Show NotifyIcon where
   show IconError = "dialog-error-symbolic"
   show IconInfo = "dialog-information-symbolic"
 
-notifyIf :: Bool -> T.Text -> T.Text -> IO ()
+notifyIf :: MonadIO m => Bool -> T.Text -> T.Text -> m ()
 notifyIf True s _ = notify IconInfo s
 notifyIf False _ s = notify IconError s
 
-notify :: NotifyIcon -> T.Text -> IO ()
+notify :: MonadIO m => NotifyIcon -> T.Text -> m ()
-notify icon body = void $ spawnProcess "notify-send" $ args ++ [T.unpack body]
+notify icon body = liftIO $ void $ spawnProcess "notify-send" $ args ++ [T.unpack body]
   where
     args = ["-i", show icon, summary]
     summary = "ExpressVPN"

lib/Bitwarden/Internal.hs

@@ -12,7 +12,6 @@ where
 import DBus
 import DBus.Client
 import Data.Aeson
-import qualified Data.Text.IO as TI
 import Data.UnixTime
 import GHC.Generics
 import RIO hiding (timeout)
@@ -37,23 +36,23 @@ newtype BWServerConf = BWServerConf
 
 -- TODO add a cache so the browse list will load faster
 data CurrentSession = CurrentSession
-  { timestamp :: UnixTime
+  { timestamp :: !UnixTime
-  , hash :: T.Text
+  , hash :: !T.Text
   }
 
 type Session = MVar (Maybe CurrentSession)
 
-runDaemon :: Int -> IO ()
+runDaemon :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => Int -> m ()
 runDaemon t = do
   ses <- newMVar Nothing
   let c = BWServerConf {timeout = UnixDiffTime (fromIntegral t) 0}
   startService c ses
   forever $ threadDelay 1000000
 
-lockSession :: Session -> IO ()
+lockSession :: MonadIO m => Session -> m ()
 lockSession ses = void $ swapMVar ses Nothing
 
-syncSession :: BWServerConf -> Session -> IO ()
+syncSession :: MonadUnliftIO m => BWServerConf -> Session -> m ()
 syncSession conf ses = notify =<< fmap join . mapM cmd =<< getSession' conf ses
   where
     cmd h = readCmdSuccess "bw" ["sync", "--session", h] ""
@@ -61,9 +60,9 @@ syncSession conf ses = notify =<< fmap join . mapM cmd =<< getSession' conf ses
       let j = isJust res
        in notifyStatus j $ if j then "sync succeeded" else "sync failed"
 
-getSession' :: BWServerConf -> Session -> IO (Maybe T.Text)
+getSession' :: MonadUnliftIO m => BWServerConf -> Session -> m (Maybe T.Text)
 getSession' BWServerConf {timeout = t} ses = do
-  ut <- getUnixTime
+  ut <- liftIO $ getUnixTime
   modifyMVar ses $ \s -> case s of
     Just CurrentSession {timestamp = ts, hash = h} ->
       if diffUnixTime ut ts > t then getNewSession else return (s, Just h)
@@ -74,18 +73,18 @@ getSession' BWServerConf {timeout = t} ses = do
       newHash <- join <$> mapM readSession pwd
       (,newHash) <$> mapM newSession newHash
     newSession h = do
-      ut <- getUnixTime
+      ut <- liftIO $ getUnixTime
       return CurrentSession {timestamp = ut, hash = h}
 
-getSession :: BWServerConf -> Session -> IO T.Text
+getSession :: MonadUnliftIO m => BWServerConf -> Session -> m T.Text
 getSession conf ses = fromMaybe "" <$> getSession' conf ses
 
-readSession :: T.Text -> IO (Maybe T.Text)
+readSession :: MonadIO m => T.Text -> m (Maybe T.Text)
 readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
 
-notifyStatus :: Bool -> T.Text -> IO ()
+notifyStatus :: MonadIO m => Bool -> T.Text -> m ()
 notifyStatus succeeded msg =
-  void $ spawnProcess "notify-send" ["-i", i, T.unpack msg]
+  void $ liftIO $ spawnProcess "notify-send" ["-i", i, T.unpack msg]
   where
     i =
       if succeeded
@@ -108,15 +107,21 @@ notifyStatus succeeded msg =
 --     - username (if applicable) -> copy to clipboard
 --     - password (if applicable) -> copy to clipboard
 --     - anything else (notes and such) -> copy to clipboard
-newtype BWClientConf = BWClientConf [T.Text]
+data BWClientConf c = BWClientConf
+  { bwArgs :: ![T.Text]
+  , bwEnv :: !c
+  }
 
-instance HasRofiConf BWClientConf where
+instance HasRofiConf (BWClientConf c) where
-  defArgs (BWClientConf a) = a
+  defArgs = bwArgs
 
-runClient :: [T.Text] -> IO ()
+instance HasLogFunc c => HasLogFunc (BWClientConf c) where
-runClient a = do
+  logFuncL = lens bwEnv (\x y -> x {bwEnv = y}) . logFuncL
-  let c = BWClientConf a
+
-  runRofi c $
+runClient :: HasLogFunc c => [T.Text] -> RIO c ()
+runClient a =
+  mapRIO (BWClientConf a) $
+    selectAction $
       emptyMenu
         { groups = [untitledGroup $ toRofiActions ras]
         , prompt = Just "Action"
@@ -124,19 +129,19 @@ runClient a = do
   where
     ras =
       [ ("Browse Logins", browseLogins)
-      , ("Sync Session", io callSyncSession)
+      , ("Sync Session", callSyncSession)
-      , ("Lock Session", io callLockSession)
+      , ("Lock Session", callLockSession)
       ]
 
-browseLogins :: HasRofiConf c => RIO c ()
+browseLogins :: (HasLogFunc c, HasRofiConf c) => RIO c ()
-browseLogins = io getItems >>= selectItem
+browseLogins = getItems >>= selectItem
 
-getItems :: IO [Item]
+getItems :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m [Item]
 getItems = maybe (return []) getItems' =<< callGetSession
 
-getItems' :: T.Text -> IO [Item]
+getItems' :: MonadIO m => T.Text -> m [Item]
 getItems' session = do
-  items <- io $ readProcess "bw" ["list", "items", "--session", T.unpack session] ""
+  items <- liftIO $ readProcess "bw" ["list", "items", "--session", T.unpack session] ""
   return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
   where
     notEmpty Item {login = Login {username = Nothing, password = Nothing}} =
@@ -166,7 +171,7 @@ instance FromJSON Login
 
 -- TODO make menu buttons here to go back and to copy without leaving
 -- the current menu
-selectItem :: HasRofiConf c => [Item] -> RIO c ()
+selectItem :: (HasLogFunc c, HasRofiConf c) => [Item] -> RIO c ()
 selectItem items =
   selectAction $
     emptyMenu
@@ -174,10 +179,10 @@ selectItem items =
       , prompt = Just "Login"
       }
 
-itemsToRofiActions :: HasRofiConf c => [Item] -> RofiActions c
+itemsToRofiActions :: (HasLogFunc c, HasRofiConf c) => [Item] -> RofiActions c
 itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
 
-selectCopy :: HasRofiConf c => Login -> RIO c ()
+selectCopy :: (HasLogFunc c, HasRofiConf c) => Login -> RIO c ()
 selectCopy l =
   selectAction $
     emptyMenu
@@ -213,17 +218,18 @@ loginToRofiActions Login {username = u, password = p} a =
     user = copyIfJust fmtUsername u
     pwd = copyIfJust fmtPassword p
 
-getItemPassword' :: BWServerConf -> Session -> T.Text -> IO (Maybe T.Text)
+getItemPassword' :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m (Maybe T.Text)
 getItemPassword' conf session item = mapM getPwd =<< getSession' conf session
   where
-    getPwd s =
+    getPwd = fmap T.pack . pr
-      T.pack
+    pr s =
-        <$> readProcess
+      liftIO $
+        readProcess
           "bw"
           ["get", "password", T.unpack item, "--session", T.unpack s]
           ""
 
-getItemPassword :: BWServerConf -> Session -> T.Text -> IO T.Text
+getItemPassword :: MonadUnliftIO m => BWServerConf -> Session -> T.Text -> m T.Text
 getItemPassword conf session item =
   fromMaybe ""
     <$> getItemPassword' conf session item
@@ -231,22 +237,23 @@ getItemPassword conf session item =
 --------------------------------------------------------------------------------
 
 -- | DBus
-startService :: BWServerConf -> Session -> IO ()
+startService :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => BWServerConf -> Session -> m ()
 startService c ses = do
-  client <- connectSession
+  client <- liftIO $ connectSession
   let flags = [nameAllowReplacement, nameReplaceExisting]
-  _ <- requestName client busname flags
+  _ <- liftIO $ requestName client busname flags
-  TI.putStrLn "Started rofi bitwarden dbus client"
+  logInfo "Started rofi bitwarden dbus client"
+  withRunInIO $ \runIO ->
     export
       client
       path
       defaultInterface
         { interfaceName = interface
         , interfaceMethods =
-          [ autoMethod memGetSession $ getSession c ses
+            [ autoMethod memGetSession $ runIO $ getSession c ses
-          , autoMethod memLockSession $ lockSession ses
+            , autoMethod memLockSession $ runIO $ lockSession ses
-          , autoMethod memSyncSession $ syncSession c ses
+            , autoMethod memSyncSession $ runIO $ syncSession c ses
-          , autoMethod memGetPassword $ getItemPassword c ses
+            , autoMethod memGetPassword $ runIO . getItemPassword c ses
             ]
         }
 
@@ -271,20 +278,25 @@ memSyncSession = "SyncSession"
 memGetPassword :: MemberName
 memGetPassword = "GetPassword"
 
-callMember :: MemberName -> IO [Variant]
+callMember :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => MemberName -> m [Variant]
 callMember m = do
   reply <- callMethod $ methodCall path interface m
   case reply of
-    Left err -> TI.putStrLn (T.pack (methodErrorMessage err)) >> return []
+    Left err -> do
+      logError $
+        displayBytesUtf8 $
+          encodeUtf8 $
+            (T.pack (methodErrorMessage err))
+      return []
     Right body -> return body
 
-callLockSession :: IO ()
+callLockSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
 callLockSession = void $ callMember memLockSession
 
-callSyncSession :: IO ()
+callSyncSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m ()
 callSyncSession = void $ callMember memSyncSession
 
-callGetSession :: IO (Maybe T.Text)
+callGetSession :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) => m (Maybe T.Text)
 callGetSession = getBodyString <$> callMember memGetSession
 
 -- TODO maybe will need to add a caller for getItemPassword
@@ -295,8 +307,8 @@ getBodyString [b] = case fromVariant b :: Maybe T.Text of
   s -> s
 getBodyString _ = Nothing
 
-callMethod :: MethodCall -> IO (Either MethodError [Variant])
+callMethod :: MonadIO m => MethodCall -> m (Either MethodError [Variant])
-callMethod mc = do
+callMethod mc = liftIO $ do
   client <- connectSession
   reply <- call client mc {methodCallDestination = Just busname}
   disconnect client

lib/Rofi/Command.hs

@@ -149,27 +149,29 @@ readRofi uargs input = do
   dargs <- asks defArgs
   io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
 
-readCmdSuccess :: T.Text -> [T.Text] -> T.Text -> IO (Maybe T.Text)
+readCmdSuccess :: MonadIO m => T.Text -> [T.Text] -> T.Text -> m (Maybe T.Text)
 readCmdSuccess cmd args input =
   either (const Nothing) Just
     <$> readCmdEither cmd args input
 
 readCmdEither
-  :: T.Text
+  :: MonadIO m
+  => T.Text
   -> [T.Text]
   -> T.Text
-  -> IO (Either (Int, T.Text, T.Text) T.Text)
+  -> m (Either (Int, T.Text, T.Text) T.Text)
 readCmdEither cmd args input = readCmdEither' cmd args input []
 
 readCmdEither'
-  :: T.Text
+  :: MonadIO m
+  => T.Text
   -> [T.Text]
   -> T.Text
   -> [(T.Text, T.Text)]
-  -> IO (Either (Int, T.Text, T.Text) T.Text)
+  -> m (Either (Int, T.Text, T.Text) T.Text)
 readCmdEither' cmd args input environ =
   resultToEither
-    <$> readCreateProcessWithExitCode p (T.unpack input)
+    <$> (liftIO $ readCreateProcessWithExitCode p (T.unpack input))
   where
     e = case environ of
       [] -> Nothing
@@ -187,10 +189,10 @@ resultToEither (ExitFailure n, out, err) =
 joinNewline :: [T.Text] -> T.Text
 joinNewline = T.intercalate "\n"
 
-readPassword :: IO (Maybe T.Text)
+readPassword :: MonadIO m => m (Maybe T.Text)
 readPassword = readPassword' "Password"
 
-readPassword' :: T.Text -> IO (Maybe T.Text)
+readPassword' :: MonadIO m => T.Text -> m (Maybe T.Text)
 readPassword' p = readCmdSuccess "rofi" args ""
   where
     args = dmenuArgs ++ ["-p", p, "-password"]