diff --git a/app/pinentry-rofi.hs b/app/pinentry-rofi.hs index 7167c6a..ea54fff 100644 --- a/app/pinentry-rofi.hs +++ b/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 c = TI.putStrLn $ T.append "ERR 275 Unknown command " c +unknownCommand :: T.Text -> RIO SimpleApp () +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 " + err = putStrLnT "ERR 83886179 Operation canceled " -- these are the only supported options for GETINFO; anything else is an error -processGetInfo :: T.Text -> IO () -processGetInfo "pid" = send . T.pack . show =<< getProcessID +processGetInfo :: T.Text -> RIO SimpleApp () +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 " +processGetInfo _ = putStrLnT "ERR 83886360 IPC parameter error " -processOption :: T.Text -> IO () +processOption :: T.Text -> RIO SimpleApp () processOption _ = noop -send :: T.Text -> IO () -send s = TI.putStrLn (T.append "D " s) >> ok +send :: T.Text -> RIO SimpleApp () +send s = putStrLnT (T.append "D " s) >> ok -noop :: IO () +noop :: RIO SimpleApp () noop = ok -ok :: IO () -ok = TI.putStrLn "OK" +ok :: RIO SimpleApp () +ok = putStrLnT "OK" + +putStrLnT :: MonadIO m => T.Text -> m () +putStrLnT = liftIO . TI.putStrLn diff --git a/app/rofi-autorandr.hs b/app/rofi-autorandr.hs index 63ce502..1ee2b55 100644 --- a/app/rofi-autorandr.hs +++ b/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 :: IO () +runChecks :: (MonadReader c m, HasLogFunc c, MonadIO m) => m () 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 - TI.putStrLn name - void $ spawnProcess "autorandr" ["--change", T.unpack name] +selectProfile name = + liftIO $ + void $ + spawnProcess "autorandr" ["--change", T.unpack name] diff --git a/app/rofi-bt.hs b/app/rofi-bt.hs index ca42140..e6befaf 100644 --- a/app/rofi-bt.hs +++ b/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) $ - getAdapter paths - actions client paths adapter = do - ras <- getRofiActions client paths - runRofi (RofiBTConf (fmap T.pack args) adapter) $ - emptyMenu - { groups = [untitledGroup $ toRofiActions ras] - , prompt = Just "Select Device" - } + case getAdapter paths of + Nothing -> logError "could not get DBus adapter" + Just adapter -> do + ras <- getRofiActions client paths + 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 - powered <- io $ getBTProperty client adapter i m - io $ maybe (TI.putStrLn "could not get adapter powered status") powerOnMaybe powered + let powerOnMaybe = flip unless $ void $ liftIO $ setProperty client mc value + powered <- getBTProperty client adapter i m + 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 = either warn (return . Just) =<< try connectSystem +getClient :: (MonadReader c m, HasLogFunc c, MonadUnliftIO m) => m (Maybe Client) +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) -callBTMethod client o i m = call client (btMethodCall o i m) + -> m (Either MethodError MethodReturn) +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} diff --git a/app/rofi-bw.hs b/app/rofi-bw.hs index f6593d6..12afc5e 100644 --- a/app/rofi-bw.hs +++ b/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 System.Environment +import UnliftIO.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 $ - joinNewline - [ "daemon mode: rofi-bw -d TIMEOUT" - , "client mode: rofi-bw -c [ROFI-ARGS]" - ] + logInfo $ + 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 diff --git a/app/rofi-dev.hs b/app/rofi-dev.hs index 76af2a5..ddd85e9 100644 --- a/app/rofi-dev.hs +++ b/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] - -> RofiMountIO [(Header, ProtoAction)] + => MIO [a] + -> 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,26 +381,25 @@ 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 - CIFSConfig - ( CIFSData - { cifsRemote = r - , cifsSudo = s - , cifsPassword = p - , cifsOpts = o - } - ) -> - mountCIFS s r m' o p - VeracryptConfig - ( VeracryptData - { vcPassword = p - , vcVolume = v - } - ) -> - mountVeracrypt m' p v + case devData of + SSHFSConfig (SSHFSData {sshfsRemote = r, sshfsPassword = p}) -> + mountSSHFS m' p r + CIFSConfig + ( CIFSData + { cifsRemote = r + , cifsSudo = s + , cifsPassword = p + , cifsOpts = o + } + ) -> + mountCIFS s r m' o p + VeracryptConfig + ( VeracryptData + { vcPassword = p + , vcVolume = v + } + ) -> + mountVeracrypt m' p v mount DeviceConfig {deviceMount = m, deviceData = d} True = do m' <- getAbsMountpoint m runAndRemoveDir m' $ io $ case d of @@ -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 - -> (T.Text -> IO MountResult) - -> IO MountResult - -> IO MountResult + :: (HasLogFunc c, MonadReader c m, MonadUnliftIO m) + => Maybe PasswordConfig + -> (T.Text -> m 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 diff --git a/app/rofi-evpn.hs b/app/rofi-evpn.hs index 949cbc3..3d3590f 100644 --- a/app/rofi-evpn.hs +++ b/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 icon body = void $ spawnProcess "notify-send" $ args ++ [T.unpack body] +notify :: MonadIO m => NotifyIcon -> T.Text -> m () +notify icon body = liftIO $ void $ spawnProcess "notify-send" $ args ++ [T.unpack body] where args = ["-i", show icon, summary] summary = "ExpressVPN" diff --git a/lib/Bitwarden/Internal.hs b/lib/Bitwarden/Internal.hs index bdccb16..09a15b5 100644 --- a/lib/Bitwarden/Internal.hs +++ b/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 - , hash :: T.Text + { timestamp :: !UnixTime + , 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,35 +107,41 @@ 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 - defArgs (BWClientConf a) = a +instance HasRofiConf (BWClientConf c) where + defArgs = bwArgs -runClient :: [T.Text] -> IO () -runClient a = do - let c = BWClientConf a - runRofi c $ - emptyMenu - { groups = [untitledGroup $ toRofiActions ras] - , prompt = Just "Action" - } +instance HasLogFunc c => HasLogFunc (BWClientConf c) where + logFuncL = lens bwEnv (\x y -> x {bwEnv = y}) . logFuncL + +runClient :: HasLogFunc c => [T.Text] -> RIO c () +runClient a = + mapRIO (BWClientConf a) $ + selectAction $ + emptyMenu + { groups = [untitledGroup $ toRofiActions ras] + , prompt = Just "Action" + } where ras = [ ("Browse Logins", browseLogins) - , ("Sync Session", io callSyncSession) - , ("Lock Session", io callLockSession) + , ("Sync Session", callSyncSession) + , ("Lock Session", callLockSession) ] -browseLogins :: HasRofiConf c => RIO c () -browseLogins = io getItems >>= selectItem +browseLogins :: (HasLogFunc c, HasRofiConf c) => RIO c () +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 = - T.pack - <$> readProcess + getPwd = fmap T.pack . pr + pr s = + 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,24 +237,25 @@ 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 - TI.putStrLn "Started rofi bitwarden dbus client" - export - client - path - defaultInterface - { interfaceName = interface - , interfaceMethods = - [ autoMethod memGetSession $ getSession c ses - , autoMethod memLockSession $ lockSession ses - , autoMethod memSyncSession $ syncSession c ses - , autoMethod memGetPassword $ getItemPassword c ses - ] - } + _ <- liftIO $ requestName client busname flags + logInfo "Started rofi bitwarden dbus client" + withRunInIO $ \runIO -> + export + client + path + defaultInterface + { interfaceName = interface + , interfaceMethods = + [ autoMethod memGetSession $ runIO $ getSession c ses + , autoMethod memLockSession $ runIO $ lockSession ses + , autoMethod memSyncSession $ runIO $ syncSession c ses + , autoMethod memGetPassword $ runIO . getItemPassword c ses + ] + } busname :: BusName busname = "org.rofi.bitwarden" @@ -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 mc = do +callMethod :: MonadIO m => MethodCall -> m (Either MethodError [Variant]) +callMethod mc = liftIO $ do client <- connectSession reply <- call client mc {methodCallDestination = Just busname} disconnect client diff --git a/lib/Rofi/Command.hs b/lib/Rofi/Command.hs index 364c02b..8ede710 100644 --- a/lib/Rofi/Command.hs +++ b/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"]