REF wrap everything in simpleapp
This commit is contained in:
parent
05ecda045e
commit
c3fc38d785
|
|
@ -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 <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 "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 <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 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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
181
app/rofi-dev.hs
181
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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue