REF use rio and better flags
This commit is contained in:
parent
cfe0607e2e
commit
4265a5947c
|
|
@ -1,42 +1,39 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | rofi-pinentry - a simply pinentry proxy for bitwarden
|
||||
-- rofi-pinentry - a simply pinentry proxy for bitwarden
|
||||
--
|
||||
-- Rather than prompt the user like all the other pinentry programs, call the
|
||||
-- bitwarden deamon and prompt for a password there
|
||||
|
||||
module Main where
|
||||
|
||||
import Bitwarden.Internal
|
||||
|
||||
import Data.List
|
||||
import Data.Yaml
|
||||
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath.Posix
|
||||
import System.IO
|
||||
import System.Posix.Process
|
||||
import Bitwarden.Internal
|
||||
import qualified Data.Text.IO as TI
|
||||
import Data.Yaml
|
||||
import RIO
|
||||
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
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
hSetBuffering stdout LineBuffering
|
||||
putStrLn "OK Pleased to meet you"
|
||||
TI.putStrLn "OK Pleased to meet you"
|
||||
pinentryLoop =<< readPinConf
|
||||
|
||||
newtype PinConf = PinConf { pcBwName :: String } deriving (Eq, Show)
|
||||
newtype PinConf = PinConf {pcBwName :: String} deriving (Eq, Show)
|
||||
|
||||
instance FromJSON PinConf where
|
||||
parseJSON (Object o) = PinConf <$> o .:? "bitwarden-name" .!= "gnupg"
|
||||
parseJSON _ = fail "pinentry yaml parse error"
|
||||
parseJSON _ = fail "pinentry yaml parse error"
|
||||
|
||||
readPinConf :: IO PinConf
|
||||
readPinConf = do
|
||||
c <- decodeFileEither =<< pinConfDir
|
||||
case c of
|
||||
Left e -> print e >> exitWith (ExitFailure 1)
|
||||
Left e -> TI.putStrLn (T.pack $ show e) >> exitWith (ExitFailure 1)
|
||||
Right r -> return r
|
||||
|
||||
pinConfDir :: IO FilePath
|
||||
|
|
@ -47,60 +44,55 @@ pinConfDir = maybe defHome (return . (</> confname)) =<< lookupEnv "GNUPGHOME"
|
|||
|
||||
pinentryLoop :: PinConf -> IO ()
|
||||
pinentryLoop p = do
|
||||
processLine p . words =<< getLine
|
||||
processLine p . T.words =<< TI.getLine
|
||||
pinentryLoop p
|
||||
|
||||
processLine :: PinConf -> [String] -> IO ()
|
||||
processLine _ [] = noop
|
||||
processLine _ ["BYE"] = exitSuccess
|
||||
processLine p ["GETPIN"] = getPin p
|
||||
|
||||
processLine _ ["GETINFO", o] = processGetInfo o
|
||||
|
||||
processLine :: PinConf -> [T.Text] -> IO ()
|
||||
processLine _ [] = noop
|
||||
processLine _ ["BYE"] = exitSuccess
|
||||
processLine p ["GETPIN"] = getPin p
|
||||
processLine _ ["GETINFO", o] = processGetInfo o
|
||||
-- TODO this might be important
|
||||
processLine _ ["OPTION", o] = processOption o
|
||||
|
||||
processLine _ ["OPTION", o] = processOption o
|
||||
-- these should all do nothing
|
||||
processLine _ ("SETDESC":_) = noop
|
||||
processLine _ ("SETOK":_) = noop
|
||||
processLine _ ("SETNOTOK":_) = noop
|
||||
processLine _ ("SETCANCEL":_) = noop
|
||||
processLine _ ("SETPROMPT":_) = noop
|
||||
processLine _ ("SETERROR":_) = noop
|
||||
|
||||
processLine _ ("SETDESC" : _) = noop
|
||||
processLine _ ("SETOK" : _) = noop
|
||||
processLine _ ("SETNOTOK" : _) = noop
|
||||
processLine _ ("SETCANCEL" : _) = noop
|
||||
processLine _ ("SETPROMPT" : _) = noop
|
||||
processLine _ ("SETERROR" : _) = noop
|
||||
-- CONFIRM can take a flag
|
||||
processLine _ ["CONFIRM"] = noop
|
||||
processLine _ ["CONFIRM"] = noop
|
||||
processLine _ ["CONFIRM", "--one-button", _] = noop
|
||||
processLine _ ss = unknownCommand $ T.unwords ss
|
||||
|
||||
processLine _ ss = unknownCommand $ unwords ss
|
||||
|
||||
unknownCommand :: String -> IO ()
|
||||
unknownCommand c = putStrLn $ "ERR 275 Unknown command " ++ c
|
||||
unknownCommand :: T.Text -> IO ()
|
||||
unknownCommand c = TI.putStrLn $ T.append "ERR 275 Unknown command " c
|
||||
|
||||
getPin :: PinConf -> IO ()
|
||||
getPin p = do
|
||||
its <- getItems
|
||||
let w = (password . login) =<< find (\i -> pcBwName p == name i) its
|
||||
let w = (fmap T.pack . password . login) =<< L.find (\i -> pcBwName p == name i) its
|
||||
maybe err send w
|
||||
where
|
||||
err = putStrLn "ERR 83886179 Operation canceled <rofi>"
|
||||
err = TI.putStrLn "ERR 83886179 Operation canceled <rofi>"
|
||||
|
||||
-- these are the only supported options for GETINFO; anything else is an error
|
||||
processGetInfo :: String -> IO ()
|
||||
processGetInfo "pid" = send . show =<< getProcessID
|
||||
processGetInfo :: T.Text -> IO ()
|
||||
processGetInfo "pid" = send . T.pack . show =<< getProcessID
|
||||
processGetInfo "version" = noop
|
||||
processGetInfo "flavor" = noop
|
||||
processGetInfo "flavor" = noop
|
||||
processGetInfo "ttyinfo" = noop
|
||||
processGetInfo _ = putStrLn "ERR 83886360 IPC parameter error <rofi>"
|
||||
processGetInfo _ = TI.putStrLn "ERR 83886360 IPC parameter error <rofi>"
|
||||
|
||||
processOption :: String -> IO ()
|
||||
processOption :: T.Text -> IO ()
|
||||
processOption _ = noop
|
||||
|
||||
send :: String -> IO ()
|
||||
send s = putStrLn ("D " ++ s) >> ok
|
||||
send :: T.Text -> IO ()
|
||||
send s = TI.putStrLn (T.append "D " s) >> ok
|
||||
|
||||
noop :: IO ()
|
||||
noop = ok
|
||||
|
||||
ok :: IO ()
|
||||
ok = putStrLn "OK"
|
||||
ok = TI.putStrLn "OK"
|
||||
|
|
|
|||
|
|
@ -1,22 +1,20 @@
|
|||
--------------------------------------------------------------------------------
|
||||
-- | rofi-autorandr - a rofi prompt to select autorandr profiles
|
||||
-- rofi-autorandr - a rofi prompt to select autorandr profiles
|
||||
--
|
||||
-- Simple wrapper to select an autorandr profile.
|
||||
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
import Rofi.Command
|
||||
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath.Posix
|
||||
import System.Process
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
import qualified Data.Text.IO as TI
|
||||
import RIO
|
||||
import qualified RIO.Text as T
|
||||
import Rofi.Command
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath.Posix
|
||||
import System.Process
|
||||
|
||||
main :: IO ()
|
||||
main = runChecks >> getArgs >>= runPrompt
|
||||
|
|
@ -29,7 +27,7 @@ checkExe :: String -> IO ()
|
|||
checkExe cmd = do
|
||||
res <- findExecutable cmd
|
||||
unless (isJust res) $ do
|
||||
putStrLn $ "Could not find executable: " ++ cmd
|
||||
TI.putStrLn $ T.append "Could not find executable: " $ T.pack cmd
|
||||
exitWith $ ExitFailure 1
|
||||
|
||||
newtype ARClientConf = ARClientConf [String]
|
||||
|
|
@ -41,13 +39,17 @@ runPrompt :: [String] -> IO ()
|
|||
runPrompt a = do
|
||||
let c = ARClientConf a
|
||||
staticProfs <- getAutoRandrProfiles
|
||||
runRofiIO c $ selectAction $ emptyMenu
|
||||
{ groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs]
|
||||
, prompt = Just "Select Profile"
|
||||
}
|
||||
runRofiIO c $
|
||||
selectAction $
|
||||
emptyMenu
|
||||
{ groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs]
|
||||
, prompt = Just "Select Profile"
|
||||
}
|
||||
where
|
||||
mkGroup header = titledGroup header . toRofiActions
|
||||
. fmap (\s -> (" " ++ s, selectProfile s))
|
||||
mkGroup header =
|
||||
titledGroup header
|
||||
. toRofiActions
|
||||
. fmap (\s -> (" " ++ s, selectProfile $ T.pack s))
|
||||
|
||||
virtProfs :: [String]
|
||||
virtProfs = ["off", "common", "clone-largest", "horizontal", "vertical"]
|
||||
|
|
@ -67,7 +69,7 @@ getAutoRandrDir = do
|
|||
where
|
||||
appendToHome p = (</> p) <$> getHomeDirectory
|
||||
|
||||
selectProfile :: String -> RofiIO ARClientConf ()
|
||||
selectProfile :: T.Text -> RofiIO ARClientConf ()
|
||||
selectProfile name = do
|
||||
io $ putStrLn name
|
||||
io $ void $ spawnProcess "autorandr" ["--change", name]
|
||||
io $ TI.putStrLn name
|
||||
io $ void $ spawnProcess "autorandr" ["--change", T.unpack name]
|
||||
|
|
|
|||
|
|
@ -1,24 +1,20 @@
|
|||
--------------------------------------------------------------------------------
|
||||
-- | rofi-bt - a prompt to dicsonnect/connect devices
|
||||
-- rofi-bt - a prompt to dicsonnect/connect devices
|
||||
--
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
|
||||
import Data.List
|
||||
import Data.List.Split
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import Rofi.Command
|
||||
|
||||
import System.Environment
|
||||
import DBus
|
||||
import DBus.Client
|
||||
import Data.List.Split
|
||||
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
|
||||
|
||||
main :: IO ()
|
||||
main = getArgs >>= runPrompt
|
||||
|
|
@ -33,18 +29,20 @@ type BTAction = RofiAction RofiBTConf
|
|||
runPrompt :: [String] -> IO ()
|
||||
runPrompt args = do
|
||||
c <- getClient
|
||||
maybe (putStrLn "could not get DBus client") run c
|
||||
maybe (TI.putStrLn "could not get DBus client") run c
|
||||
where
|
||||
run client = do
|
||||
paths <- M.keys <$> getObjectTree client
|
||||
maybe (putStrLn "could not get DBus adapter") (actions client paths)
|
||||
$ getAdapter paths
|
||||
maybe (TI.putStrLn "could not get DBus adapter") (actions client paths) $
|
||||
getAdapter paths
|
||||
actions client paths adapter = do
|
||||
ras <- getRofiActions client paths
|
||||
runRofiIO (RofiBTConf args adapter) $ selectAction $ emptyMenu
|
||||
{ groups = [untitledGroup $ toRofiActions ras]
|
||||
, prompt = Just "Select Device"
|
||||
}
|
||||
runRofiIO (RofiBTConf args adapter) $
|
||||
selectAction $
|
||||
emptyMenu
|
||||
{ groups = [untitledGroup $ toRofiActions ras]
|
||||
, prompt = Just "Select Device"
|
||||
}
|
||||
|
||||
getRofiActions :: Client -> [ObjectPath] -> IO [BTAction]
|
||||
getRofiActions client os = do
|
||||
|
|
@ -56,12 +54,14 @@ deviceToRofiAction client dev = do
|
|||
c <- getDeviceConnected client dev
|
||||
n <- getDeviceName client dev
|
||||
return $ case (c, n) of
|
||||
(Just c', Just n') -> Just ( formatDeviceEntry c' n'
|
||||
, powerAdapterMaybe client >> io (mkAction c')
|
||||
)
|
||||
_ -> Nothing
|
||||
(Just c', Just n') ->
|
||||
Just
|
||||
( formatDeviceEntry c' n'
|
||||
, powerAdapterMaybe client >> io (mkAction c')
|
||||
)
|
||||
_ -> Nothing
|
||||
where
|
||||
mkAction True = callDeviceDisconnect client dev
|
||||
mkAction True = callDeviceDisconnect client dev
|
||||
mkAction False = callDeviceConnect client dev
|
||||
|
||||
powerAdapterMaybe :: Client -> RofiIO RofiBTConf ()
|
||||
|
|
@ -70,7 +70,7 @@ powerAdapterMaybe client = do
|
|||
let mc = btMethodCall adapter i m
|
||||
let powerOnMaybe = flip unless $ void $ setProperty client mc value
|
||||
powered <- io $ getBTProperty client adapter i m
|
||||
io $ maybe (putStrLn "could not get adapter powered status") powerOnMaybe powered
|
||||
io $ maybe (TI.putStrLn "could not get adapter powered status") powerOnMaybe powered
|
||||
where
|
||||
i = interfaceName_ "org.bluez.Adapter1"
|
||||
m = memberName_ "Powered"
|
||||
|
|
@ -81,11 +81,11 @@ powerAdapterMaybe client = do
|
|||
formatDeviceEntry :: Bool -> String -> String
|
||||
formatDeviceEntry connected name = unwords [prefix connected, name]
|
||||
where
|
||||
prefix True = "#"
|
||||
prefix True = "#"
|
||||
prefix False = " "
|
||||
|
||||
getAdapter :: [ObjectPath] -> Maybe ObjectPath
|
||||
getAdapter = find pathIsAdaptor
|
||||
getAdapter = L.find pathIsAdaptor
|
||||
|
||||
getDevices :: Client -> [ObjectPath] -> IO [ObjectPath]
|
||||
getDevices client = filterM (getDevicePaired client) . filter pathIsDevice
|
||||
|
|
@ -119,23 +119,23 @@ callDeviceDisconnect = callDevMethod "Disconnect"
|
|||
pathIsAdaptor :: ObjectPath -> Bool
|
||||
pathIsAdaptor o = case splitPath o of
|
||||
[a, b, c] -> pathIsAdaptorPrefix a b c
|
||||
_ -> False
|
||||
_ -> False
|
||||
|
||||
pathIsDevice :: ObjectPath -> Bool
|
||||
pathIsDevice o = case splitPath o of
|
||||
[a, b, c, _] -> pathIsAdaptorPrefix a b c
|
||||
_ -> False
|
||||
_ -> False
|
||||
|
||||
pathIsAdaptorPrefix :: String -> String -> String -> Bool
|
||||
pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `isPrefixOf` c
|
||||
pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `L.isPrefixOf` c
|
||||
|
||||
splitPath :: ObjectPath -> [String]
|
||||
splitPath =splitOn "/" . dropWhile (=='/') . formatObjectPath
|
||||
splitPath = splitOn "/" . dropWhile (== '/') . formatObjectPath
|
||||
|
||||
getClient :: IO (Maybe Client)
|
||||
getClient = either warn (return . Just) =<< try connectSystem
|
||||
where
|
||||
warn e = putStrLn (clientErrorMessage e) >> return Nothing
|
||||
warn e = TI.putStrLn (T.pack $ clientErrorMessage e) >> return Nothing
|
||||
|
||||
callDevMethod :: String -> Client -> ObjectPath -> IO ()
|
||||
callDevMethod mem client dev =
|
||||
|
|
@ -145,19 +145,29 @@ getDevProperty :: IsVariant a => String -> Client -> ObjectPath -> IO (Maybe a)
|
|||
getDevProperty mem client dev =
|
||||
getBTProperty client dev btDevInterface $ memberName_ mem
|
||||
|
||||
callBTMethod :: Client -> ObjectPath -> InterfaceName
|
||||
-> MemberName -> IO (Either MethodError MethodReturn)
|
||||
callBTMethod
|
||||
:: Client
|
||||
-> ObjectPath
|
||||
-> InterfaceName
|
||||
-> MemberName
|
||||
-> IO (Either MethodError MethodReturn)
|
||||
callBTMethod client o i m = call client (btMethodCall o i m)
|
||||
-- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
|
||||
-- <$> call client (btMethodCall o i m)
|
||||
|
||||
getBTProperty :: IsVariant a => Client -> ObjectPath
|
||||
-> InterfaceName -> MemberName -> IO (Maybe a)
|
||||
-- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
|
||||
-- <$> call client (btMethodCall o i m)
|
||||
|
||||
getBTProperty
|
||||
:: IsVariant a
|
||||
=> Client
|
||||
-> ObjectPath
|
||||
-> InterfaceName
|
||||
-> MemberName
|
||||
-> IO (Maybe a)
|
||||
getBTProperty client o i m =
|
||||
eitherMaybe fromVariant <$> getProperty client (btMethodCall o i m)
|
||||
|
||||
btMethodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall
|
||||
btMethodCall o i m = (methodCall o i m) { methodCallDestination = Just btBus }
|
||||
btMethodCall o i m = (methodCall o i m) {methodCallDestination = Just btBus}
|
||||
|
||||
eitherMaybe :: (b -> Maybe c) -> Either a b -> Maybe c
|
||||
eitherMaybe = either (const Nothing)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | rofi-bw - a rofi prompt for a bitwarden vault
|
||||
-- rofi-bw - a rofi prompt for a bitwarden vault
|
||||
--
|
||||
-- This is basically a wrapper around the 'bw' command, which is assumed to be
|
||||
-- properly configured before running this command. This shows a system of
|
||||
|
|
@ -18,34 +16,31 @@
|
|||
|
||||
module Main (main) where
|
||||
|
||||
import Bitwarden.Internal
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
import Rofi.Command
|
||||
|
||||
import Text.Read
|
||||
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
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
|
||||
|
||||
main :: IO ()
|
||||
main = runChecks >> getArgs >>= parse
|
||||
|
||||
-- TODO check if daemon is running when running client
|
||||
parse :: [String] -> IO ()
|
||||
parse ["-d", t] = case readMaybe t of { Just t' -> runDaemon t'; _ -> usage }
|
||||
parse ("-c":args) = runClient args
|
||||
parse _ = usage
|
||||
parse ["-d", t] = case readMaybe t of Just t' -> runDaemon t'; _ -> usage
|
||||
parse ("-c" : args) = runClient args
|
||||
parse _ = usage
|
||||
|
||||
usage :: IO ()
|
||||
usage = putStrLn $ joinNewline
|
||||
[ "daemon mode: rofi-bw -d TIMEOUT"
|
||||
, "client mode: rofi-bw -c [ROFI-ARGS]"
|
||||
]
|
||||
usage =
|
||||
TI.putStrLn $
|
||||
T.pack $
|
||||
joinNewline
|
||||
[ "daemon mode: rofi-bw -d TIMEOUT"
|
||||
, "client mode: rofi-bw -c [ROFI-ARGS]"
|
||||
]
|
||||
|
||||
runChecks :: IO ()
|
||||
runChecks = checkExe "bw" >> checkExe "rofi"
|
||||
|
|
@ -54,5 +49,5 @@ checkExe :: String -> IO ()
|
|||
checkExe cmd = do
|
||||
res <- findExecutable cmd
|
||||
unless (isJust res) $ do
|
||||
putStrLn $ "Could not find executable: " ++ cmd
|
||||
TI.putStrLn $ T.append "Could not find executable: " $ T.pack cmd
|
||||
exitWith $ ExitFailure 1
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- rofi-dev - a rofi prompt for mountable devices
|
||||
|
|
@ -14,35 +11,33 @@
|
|||
module Main (main) where
|
||||
|
||||
import Bitwarden.Internal
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Data.List
|
||||
import Data.List.Split (splitOn)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TI
|
||||
import Data.Typeable
|
||||
import qualified Data.Vector as V
|
||||
import Dhall hiding (maybe, sequence, void)
|
||||
import qualified Dhall.Map as DM
|
||||
import RIO
|
||||
import RIO.Directory
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.List.Partial as LP
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
import qualified RIO.Vector.Boxed as V
|
||||
import Rofi.Command
|
||||
import System.Console.GetOpt
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath.Posix
|
||||
import System.Posix.User (getEffectiveUserName)
|
||||
import System.Process
|
||||
import Text.Printf
|
||||
import UnliftIO.Exception
|
||||
|
||||
main :: IO ()
|
||||
main = getArgs >>= parse
|
||||
|
||||
parse :: [String] -> IO ()
|
||||
parse args = case getOpt Permute options args of
|
||||
(o, n, []) -> runMounts $ foldl (flip id) (defaultOpts n) o
|
||||
(_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options
|
||||
(o, n, []) -> runMounts $ L.foldl (flip id) (defaultOpts n) o
|
||||
(_, _, errs) -> TI.putStrLn $ T.pack $ concat errs ++ usageInfo h options
|
||||
where
|
||||
h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
|
||||
defaultOpts r =
|
||||
|
|
@ -109,7 +104,7 @@ parseStaticConfig :: FilePath -> IO (Maybe StaticConfig)
|
|||
parseStaticConfig p = do
|
||||
res <- try $ inputFileWithSettings es auto p
|
||||
case res of
|
||||
Left e -> print (e :: SomeException) >> return Nothing
|
||||
Left e -> TI.putStrLn (T.pack $ show (e :: SomeException)) >> return Nothing
|
||||
Right c -> return $ Just (c :: StaticConfig)
|
||||
where
|
||||
es = over substitutions (DM.union vars) defaultEvaluateSettings
|
||||
|
|
@ -130,7 +125,7 @@ parseStaticConfig p = do
|
|||
, toVar (auto :: Decoder MountConfig)
|
||||
]
|
||||
toVar a =
|
||||
fmap (\n -> (T.pack $ show n, maximum $ expected a)) $
|
||||
fmap (\n -> (T.pack $ show n, LP.maximum $ expected a)) $
|
||||
listToMaybe $
|
||||
snd $
|
||||
splitTyConApp $
|
||||
|
|
@ -150,8 +145,8 @@ getGroups = do
|
|||
return $
|
||||
(++ [metaActions]) $
|
||||
mapMaybe mkGroup $
|
||||
groupBy (\(hx, _) (hy, _) -> hx == hy) $
|
||||
sortBy (\(hx, _) (hy, _) -> compare hx hy) $
|
||||
L.groupBy (\(hx, _) (hy, _) -> hx == hy) $
|
||||
L.sortBy (\(hx, _) (hy, _) -> compare hx hy) $
|
||||
concat actions
|
||||
where
|
||||
metaActions =
|
||||
|
|
@ -185,14 +180,14 @@ alignSep = " | "
|
|||
alignEntries :: [ProtoAction [String]] -> [(String, RofiMountIO ())]
|
||||
alignEntries ps = zip (align es) as
|
||||
where
|
||||
(es, as) = unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
|
||||
(es, as) = L.unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
|
||||
align =
|
||||
fmap (intercalate alignSep)
|
||||
. transpose
|
||||
fmap (L.intercalate alignSep)
|
||||
. L.transpose
|
||||
. mapToLast pad
|
||||
. transpose
|
||||
pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs
|
||||
getMax = maximum . fmap length
|
||||
. L.transpose
|
||||
pad xs = let m = getMax xs in fmap (\x -> take m (x ++ L.repeat ' ')) xs
|
||||
getMax = LP.maximum . fmap length
|
||||
mapToLast _ [] = []
|
||||
mapToLast _ [x] = [x]
|
||||
mapToLast f (x : xs) = f x : mapToLast f xs
|
||||
|
|
@ -528,7 +523,7 @@ mountCIFS useSudo remote mountpoint opts pwdConfig =
|
|||
args = [remote, mountpoint] ++ maybe [] (\o -> ["-o", fromCIFSOpts o]) opts
|
||||
|
||||
fromCIFSOpts :: CIFSOpts -> String
|
||||
fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs
|
||||
fromCIFSOpts o = L.intercalate "," $ mapMaybe concatMaybe fs
|
||||
where
|
||||
fs =
|
||||
[ ("username", cifsoptsUsername)
|
||||
|
|
@ -589,7 +584,7 @@ runSecret kvs = readCmdSuccess "secret-tool" ("lookup" : kvs') ""
|
|||
|
||||
runBitwarden :: String -> PasswordGetter
|
||||
runBitwarden pname =
|
||||
((password . login) <=< find (\i -> name i == pname))
|
||||
((password . login) <=< L.find (\i -> name i == pname))
|
||||
<$> getItems
|
||||
|
||||
runPromptLoop :: Integer -> PasswordGetter -> PasswordGetter
|
||||
|
|
@ -667,7 +662,7 @@ instance Actionable Removable where
|
|||
-- reported by 'lsblk'. If the LABEL does not exist on the filesystem, the
|
||||
-- label shown on the prompt will be 'SIZE Volume' where size is the size of
|
||||
-- the device
|
||||
getRemovableDevices :: RofiConf c => RofiIO c [Removable]
|
||||
getRemovableDevices :: RofiIO c [Removable]
|
||||
getRemovableDevices =
|
||||
fromLines toDev . lines
|
||||
<$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "")
|
||||
|
|
@ -727,7 +722,7 @@ getMTPDevices = do
|
|||
return $ fromLines (toDev dir) $ toDevList res
|
||||
toDevList =
|
||||
reverse
|
||||
. takeWhile (not . isPrefixOf "Available devices")
|
||||
. takeWhile (not . L.isPrefixOf "Available devices")
|
||||
. reverse
|
||||
. lines
|
||||
toDev dir s = case splitOn ", " s of
|
||||
|
|
@ -788,12 +783,12 @@ notify icon summary body =
|
|||
data MountResult = MountSuccess | MountError String deriving (Show, Eq)
|
||||
|
||||
runMount :: String -> [String] -> String -> IO MountResult
|
||||
runMount cmd args stdin = eitherToMountResult <$> readCmdEither cmd args stdin
|
||||
runMount cmd args stdin_ = eitherToMountResult <$> readCmdEither cmd args stdin_
|
||||
|
||||
runMount' :: String -> [String] -> String -> [(String, String)] -> IO MountResult
|
||||
runMount' cmd args stdin environ =
|
||||
runMount' cmd args stdin_ environ =
|
||||
eitherToMountResult
|
||||
<$> readCmdEither' cmd args stdin environ
|
||||
<$> readCmdEither' cmd args stdin_ environ
|
||||
|
||||
runMountSudoMaybe :: Bool -> String -> [String] -> IO MountResult
|
||||
runMountSudoMaybe useSudo cmd args =
|
||||
|
|
@ -825,11 +820,11 @@ eitherToMountResult (Left (_, _, e)) = MountError e
|
|||
|
||||
mountMap :: IO (M.Map FilePath String)
|
||||
mountMap = do
|
||||
parseFile <$> readFile "/proc/mounts"
|
||||
parseFile <$> readFileUtf8 "/proc/mounts"
|
||||
where
|
||||
parseFile = M.fromList . mapMaybe (parseLine . words) . lines
|
||||
parseFile = M.fromList . mapMaybe (parseLine . T.words) . T.lines
|
||||
-- none of these should fail since this file format will never change
|
||||
parseLine [spec, mountpoint, _, _, _, _] = Just (mountpoint, spec)
|
||||
parseLine [spec, mountpoint, _, _, _, _] = Just (T.unpack mountpoint, T.unpack spec)
|
||||
parseLine _ = Nothing
|
||||
|
||||
curDeviceSpecs :: IO [String]
|
||||
|
|
@ -884,7 +879,7 @@ rmDirMaybe fp =
|
|||
whenInMountDir :: FilePath -> RofiMountIO () -> RofiMountIO ()
|
||||
whenInMountDir fp f = do
|
||||
mDir <- asks mountconfVolatilePath
|
||||
when (mDir `isPrefixOf` fp) f
|
||||
when (mDir `L.isPrefixOf` fp) f
|
||||
|
||||
unlessMountpoint :: MonadIO m => FilePath -> m () -> m ()
|
||||
unlessMountpoint fp f = do
|
||||
|
|
|
|||
|
|
@ -1,19 +1,16 @@
|
|||
--------------------------------------------------------------------------------
|
||||
-- | rofi-evpn - a prompt to dicsonnect/connect with express VPN
|
||||
-- rofi-evpn - a prompt to dicsonnect/connect with express VPN
|
||||
--
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.List.Split
|
||||
import Data.Maybe
|
||||
|
||||
import Rofi.Command
|
||||
|
||||
import System.Environment
|
||||
import System.Process
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.List.Split
|
||||
import Data.Maybe
|
||||
import RIO
|
||||
import Rofi.Command
|
||||
import System.Environment
|
||||
import System.Process
|
||||
|
||||
main :: IO ()
|
||||
main = getArgs >>= runPrompt
|
||||
|
|
@ -26,13 +23,15 @@ runPrompt args = do
|
|||
run (VPNStatus connected servers) = do
|
||||
let d = getDisconnectAction <$> connected
|
||||
let cs = fmap (getConnectAction connected) servers
|
||||
runRofiIO (RofiVPNConf args) $ selectAction $ emptyMenu
|
||||
{ groups =
|
||||
[ untitledGroup $ toRofiActions $ maybeToList d
|
||||
, untitledGroup $ toRofiActions cs
|
||||
]
|
||||
, prompt = Just "Select Action"
|
||||
}
|
||||
runRofiIO (RofiVPNConf args) $
|
||||
selectAction $
|
||||
emptyMenu
|
||||
{ groups =
|
||||
[ untitledGroup $ toRofiActions $ maybeToList d
|
||||
, untitledGroup $ toRofiActions cs
|
||||
]
|
||||
, prompt = Just "Select Action"
|
||||
}
|
||||
|
||||
newtype RofiVPNConf = RofiVPNConf [String]
|
||||
|
||||
|
|
@ -63,34 +62,36 @@ getConnectedServer = (procStatus =<<) <$> readCmdSuccess eVPN ["status"] ""
|
|||
procStatus = listToMaybe . mapMaybe procLine . lines
|
||||
procLine l = case words l of
|
||||
-- the output is green...
|
||||
("\ESC[1;32;49mConnected":"to":server) -> Just $ unwords server
|
||||
_ -> Nothing
|
||||
("\ESC[1;32;49mConnected" : "to" : server) -> Just $ unwords server
|
||||
_ -> Nothing
|
||||
|
||||
getAvailableServers :: IO [VPNServer]
|
||||
getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
|
||||
where
|
||||
procOut Nothing = do
|
||||
procOut Nothing = do
|
||||
notify IconError "failed to get list of servers"
|
||||
return []
|
||||
-- ASSUME the output has a useless header that ends in a line that starts
|
||||
-- with "-----", after which is the stuff we care about, which is followed
|
||||
-- by a blank line, after which there is more stuff I don't care about
|
||||
procOut (Just ls) = return
|
||||
$ mapMaybe (matchLine . splitOn "\t")
|
||||
$ takeWhile (/= "")
|
||||
$ drop 1
|
||||
-- super lame way of matching lines that start with "-----"
|
||||
$ dropWhile (not . isPrefixOf "-----")
|
||||
$ lines ls
|
||||
procOut (Just ls) =
|
||||
return $
|
||||
mapMaybe (matchLine . splitOn "\t") $
|
||||
takeWhile (/= "") $
|
||||
drop 1
|
||||
-- super lame way of matching lines that start with "-----"
|
||||
$
|
||||
dropWhile (not . isPrefixOf "-----") $
|
||||
lines ls
|
||||
-- The output of this command is very strange; it is delimited (kinda) by
|
||||
-- tabs but some lines are long enough that they don't have a tab. In
|
||||
-- whatever case, splitting by tabs leads to variable length lists, and the
|
||||
-- id is always at the front and the location is always at the end. These
|
||||
-- should handle all cases.
|
||||
matchLine [i, _, l] = Just (i, l)
|
||||
matchLine [i, _, _, l] = Just (i, l)
|
||||
matchLine [i, _, l] = Just (i, l)
|
||||
matchLine [i, _, _, l] = Just (i, l)
|
||||
matchLine [i, _, _, _, l] = Just (i, l)
|
||||
matchLine _ = Nothing
|
||||
matchLine _ = Nothing
|
||||
|
||||
daemonIsRunning :: IO Bool
|
||||
daemonIsRunning = isJust <$> readCmdSuccess "pgrep" [eVPND] ""
|
||||
|
|
@ -123,13 +124,17 @@ eVPND = "expressvpnd"
|
|||
connect :: VPNServer -> IO ()
|
||||
connect (sid, sname) = do
|
||||
res <- readCmdSuccess' eVPN ["connect", sid]
|
||||
notifyIf res ("connected to " ++ sname)
|
||||
notifyIf
|
||||
res
|
||||
("connected to " ++ sname)
|
||||
("failed to connect to " ++ sname)
|
||||
|
||||
disconnect :: String -> IO Bool
|
||||
disconnect server = do
|
||||
res <- readCmdSuccess' eVPN ["disconnect"]
|
||||
notifyIf res ("disconnected from " ++ server)
|
||||
notifyIf
|
||||
res
|
||||
("disconnected from " ++ server)
|
||||
("failed to disconnect from " ++ server)
|
||||
return res
|
||||
|
||||
|
|
@ -141,10 +146,10 @@ data NotifyIcon = IconError | IconInfo
|
|||
|
||||
instance Show NotifyIcon where
|
||||
show IconError = "dialog-error-symbolic"
|
||||
show IconInfo = "dialog-information-symbolic"
|
||||
show IconInfo = "dialog-information-symbolic"
|
||||
|
||||
notifyIf :: Bool -> String -> String -> IO ()
|
||||
notifyIf True s _ = notify IconInfo s
|
||||
notifyIf True s _ = notify IconInfo s
|
||||
notifyIf False _ s = notify IconError s
|
||||
|
||||
notify :: NotifyIcon -> String -> IO ()
|
||||
|
|
|
|||
50
app/rofi.hs
50
app/rofi.hs
|
|
@ -1,7 +1,5 @@
|
|||
module Main (main) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Run rofi (and display on the correct screen)
|
||||
-- Run rofi (and display on the correct screen)
|
||||
--
|
||||
-- Since this seems random, the reason for this is that I want rofi to appear
|
||||
-- over the current xmonad workspace, and rofi has no concept of what an
|
||||
|
|
@ -23,15 +21,16 @@ module Main (main) where
|
|||
-- 3) Find the name of the xrandr output whose position matches that from (2)
|
||||
-- 4) Call rofi with the '-m' flag to override the default monitor placement
|
||||
|
||||
import Data.Maybe
|
||||
module Main (main) where
|
||||
|
||||
import Graphics.X11.Types
|
||||
import Graphics.X11.Xlib
|
||||
import Graphics.X11.Xlib.Extras
|
||||
import Graphics.X11.Xrandr
|
||||
|
||||
import System.Environment
|
||||
import System.Process
|
||||
import Data.Maybe
|
||||
import Graphics.X11.Types
|
||||
import Graphics.X11.Xlib
|
||||
import Graphics.X11.Xlib.Extras
|
||||
import Graphics.X11.Xrandr
|
||||
import RIO hiding (Display)
|
||||
import System.Environment
|
||||
import System.Process
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
|
@ -60,29 +59,36 @@ getDesktopViewports dpy root =
|
|||
pairs <$> getAtom32 dpy root "_NET_DESKTOP_VIEWPORT"
|
||||
where
|
||||
pairs = reverse . pairs' []
|
||||
pairs' acc (x1:x2:xs) = pairs' (Coord x1 x2 : acc) xs
|
||||
pairs' acc _ = acc
|
||||
pairs' acc (x1 : x2 : xs) = pairs' (Coord x1 x2 : acc) xs
|
||||
pairs' acc _ = acc
|
||||
|
||||
getOutputs :: Display -> Window -> IO [(Coord, String)]
|
||||
getOutputs dpy root = xrrGetScreenResourcesCurrent dpy root >>=
|
||||
maybe (return []) resourcesToCells
|
||||
getOutputs dpy root =
|
||||
xrrGetScreenResourcesCurrent dpy root
|
||||
>>= maybe (return []) resourcesToCells
|
||||
where
|
||||
resourcesToCells r = catMaybes <$> mapM (outputToCell r) (xrr_sr_outputs r)
|
||||
outputToCell r o = xrrGetOutputInfo dpy r o >>= infoToCell r
|
||||
-- connection: 0 == connected, 1 == disconnected
|
||||
infoToCell r (Just XRROutputInfo { xrr_oi_connection = 0
|
||||
, xrr_oi_name = n
|
||||
, xrr_oi_crtc = c
|
||||
}) = do
|
||||
fmap (\i -> (toCoord i, n)) <$> xrrGetCrtcInfo dpy r c
|
||||
infoToCell
|
||||
r
|
||||
( Just
|
||||
XRROutputInfo
|
||||
{ xrr_oi_connection = 0
|
||||
, xrr_oi_name = n
|
||||
, xrr_oi_crtc = c
|
||||
}
|
||||
) = do
|
||||
fmap (\i -> (toCoord i, n)) <$> xrrGetCrtcInfo dpy r c
|
||||
infoToCell _ _ = return Nothing
|
||||
toCoord c = Coord (fromIntegral $ xrr_ci_x c) (fromIntegral $ xrr_ci_y c)
|
||||
|
||||
infix 9 !!?
|
||||
|
||||
(!!?) :: [a] -> Int -> Maybe a
|
||||
(!!?) xs i
|
||||
| i < 0 = Nothing
|
||||
| otherwise = listToMaybe $ drop i xs
|
||||
| i < 0 = Nothing
|
||||
| otherwise = listToMaybe $ drop i xs
|
||||
|
||||
getAtom32 :: Display -> Window -> String -> IO [Int]
|
||||
getAtom32 dpy root str = do
|
||||
|
|
|
|||
|
|
@ -1,36 +1,29 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Bitwarden.Internal
|
||||
( Item(..)
|
||||
, Login(..)
|
||||
( Item (..)
|
||||
, Login (..)
|
||||
, Session
|
||||
, runDaemon
|
||||
, runClient
|
||||
, getItems
|
||||
, callGetSession
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Maybe
|
||||
import Data.String
|
||||
import Data.UnixTime
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
||||
import GHC.Generics
|
||||
|
||||
import Rofi.Command
|
||||
|
||||
import System.Clipboard
|
||||
import System.Process
|
||||
import DBus
|
||||
import DBus.Client
|
||||
import Data.Aeson
|
||||
import Data.String
|
||||
import qualified Data.Text.IO as TI
|
||||
import Data.UnixTime
|
||||
import GHC.Generics
|
||||
import RIO hiding (timeout)
|
||||
import qualified RIO.Text as T
|
||||
import Rofi.Command
|
||||
import System.Clipboard
|
||||
import System.Process
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Daemon
|
||||
--
|
||||
-- Daemon will export an interface on DBus with two methods:
|
||||
|
|
@ -39,23 +32,22 @@ import System.Process
|
|||
-- * lock session - destroy the current session id if active
|
||||
--
|
||||
-- The session ID will be valid only as long as TIMEOUT
|
||||
|
||||
newtype BWServerConf = BWServerConf
|
||||
{ timeout :: UnixDiffTime
|
||||
}
|
||||
{ timeout :: UnixDiffTime
|
||||
}
|
||||
|
||||
-- TODO add a cache so the browse list will load faster
|
||||
data CurrentSession = CurrentSession
|
||||
{ timestamp :: UnixTime
|
||||
, hash :: String
|
||||
}
|
||||
{ timestamp :: UnixTime
|
||||
, hash :: String
|
||||
}
|
||||
|
||||
type Session = MVar (Maybe CurrentSession)
|
||||
|
||||
runDaemon :: Int -> IO ()
|
||||
runDaemon t = do
|
||||
ses <- newMVar Nothing
|
||||
let c = BWServerConf { timeout = UnixDiffTime (fromIntegral t) 0 }
|
||||
let c = BWServerConf {timeout = UnixDiffTime (fromIntegral t) 0}
|
||||
startService c ses
|
||||
forever $ threadDelay 1000000
|
||||
|
||||
|
|
@ -66,24 +58,25 @@ syncSession :: BWServerConf -> Session -> IO ()
|
|||
syncSession conf ses = notify =<< fmap join . mapM cmd =<< getSession' conf ses
|
||||
where
|
||||
cmd h = readCmdSuccess "bw" ["sync", "--session", h] ""
|
||||
notify res = let j = isJust res
|
||||
in notifyStatus j $ if j then "sync succeeded" else "sync failed"
|
||||
notify res =
|
||||
let j = isJust res
|
||||
in notifyStatus j $ if j then "sync succeeded" else "sync failed"
|
||||
|
||||
getSession' :: BWServerConf -> Session -> IO (Maybe String)
|
||||
getSession' BWServerConf { timeout = t } ses = do
|
||||
getSession' BWServerConf {timeout = t} ses = do
|
||||
ut <- getUnixTime
|
||||
modifyMVar ses $ \s -> case s of
|
||||
Just CurrentSession { timestamp = ts, hash = h } ->
|
||||
Just CurrentSession {timestamp = ts, hash = h} ->
|
||||
if diffUnixTime ut ts > t then getNewSession else return (s, Just h)
|
||||
Nothing -> getNewSession
|
||||
where
|
||||
getNewSession = do
|
||||
pwd <- readPassword' "Bitwarden Password"
|
||||
newHash <- join <$> mapM readSession pwd
|
||||
(, newHash) <$> mapM newSession newHash
|
||||
(,newHash) <$> mapM newSession newHash
|
||||
newSession h = do
|
||||
ut <- getUnixTime
|
||||
return CurrentSession { timestamp = ut, hash = h }
|
||||
return CurrentSession {timestamp = ut, hash = h}
|
||||
|
||||
getSession :: BWServerConf -> Session -> IO String
|
||||
getSession conf ses = fromMaybe "" <$> getSession' conf ses
|
||||
|
|
@ -95,11 +88,13 @@ notifyStatus :: Bool -> String -> IO ()
|
|||
notifyStatus succeeded msg =
|
||||
void $ spawnProcess "notify-send" ["-i", i, msg]
|
||||
where
|
||||
i = if succeeded
|
||||
then "dialog-information-symbolic"
|
||||
else "dialog-error-symbolic"
|
||||
i =
|
||||
if succeeded
|
||||
then "dialog-information-symbolic"
|
||||
else "dialog-error-symbolic"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Client
|
||||
--
|
||||
-- The client will get the current session from the daemon (if it can) and then
|
||||
|
|
@ -114,7 +109,6 @@ 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 [String]
|
||||
|
||||
instance RofiConf BWClientConf where
|
||||
|
|
@ -123,15 +117,18 @@ instance RofiConf BWClientConf where
|
|||
runClient :: [String] -> IO ()
|
||||
runClient a = do
|
||||
let c = BWClientConf a
|
||||
runRofiIO c $ selectAction $ emptyMenu
|
||||
{ groups = [untitledGroup $ toRofiActions ras]
|
||||
, prompt = Just "Action"
|
||||
}
|
||||
runRofiIO c $
|
||||
selectAction $
|
||||
emptyMenu
|
||||
{ groups = [untitledGroup $ toRofiActions ras]
|
||||
, prompt = Just "Action"
|
||||
}
|
||||
where
|
||||
ras = [ ("Browse Logins", browseLogins)
|
||||
, ("Sync Session", io callSyncSession)
|
||||
, ("Lock Session", io callLockSession)
|
||||
]
|
||||
ras =
|
||||
[ ("Browse Logins", browseLogins)
|
||||
, ("Sync Session", io callSyncSession)
|
||||
, ("Lock Session", io callLockSession)
|
||||
]
|
||||
|
||||
browseLogins :: RofiConf c => RofiIO c ()
|
||||
browseLogins = io getItems >>= selectItem
|
||||
|
|
@ -144,67 +141,74 @@ getItems' session = do
|
|||
items <- io $ readProcess "bw" ["list", "items", "--session", session] ""
|
||||
return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
|
||||
where
|
||||
notEmpty Item { login = Login { username = Nothing, password = Nothing } }
|
||||
= False
|
||||
notEmpty Item {login = Login {username = Nothing, password = Nothing}} =
|
||||
False
|
||||
notEmpty _ = True
|
||||
|
||||
data Item = Item
|
||||
{ name :: String
|
||||
, login :: Login
|
||||
}
|
||||
deriving (Show)
|
||||
{ name :: String
|
||||
, login :: Login
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance FromJSON Item where
|
||||
parseJSON (Object o) = Item
|
||||
<$> o .: "name"
|
||||
<*> o .:? "login" .!= Login { username = Nothing, password = Nothing }
|
||||
parseJSON (Object o) =
|
||||
Item
|
||||
<$> o .: "name"
|
||||
<*> o .:? "login" .!= Login {username = Nothing, password = Nothing}
|
||||
parseJSON _ = mzero
|
||||
|
||||
data Login = Login
|
||||
{ username :: Maybe String
|
||||
, password :: Maybe String
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
{ username :: Maybe String
|
||||
, password :: Maybe String
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance FromJSON Login
|
||||
|
||||
-- TODO make menu buttons here to go back and to copy without leaving
|
||||
-- the current menu
|
||||
selectItem :: RofiConf c => [Item] -> RofiIO c ()
|
||||
selectItem items = selectAction $ emptyMenu
|
||||
{ groups = [untitledGroup $ itemsToRofiActions items]
|
||||
, prompt = Just "Login"
|
||||
}
|
||||
selectItem items =
|
||||
selectAction $
|
||||
emptyMenu
|
||||
{ groups = [untitledGroup $ itemsToRofiActions items]
|
||||
, prompt = Just "Login"
|
||||
}
|
||||
|
||||
itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c
|
||||
itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
|
||||
|
||||
selectCopy :: RofiConf c => Login -> RofiIO c ()
|
||||
selectCopy l = selectAction $ emptyMenu
|
||||
{ groups = [untitledGroup $ loginToRofiActions l copy]
|
||||
, prompt = Just "Copy"
|
||||
, hotkeys = [copyHotkey, backHotkey]
|
||||
}
|
||||
selectCopy l =
|
||||
selectAction $
|
||||
emptyMenu
|
||||
{ groups = [untitledGroup $ loginToRofiActions l copy]
|
||||
, prompt = Just "Copy"
|
||||
, hotkeys = [copyHotkey, backHotkey]
|
||||
}
|
||||
where
|
||||
copy = io . setClipboardString
|
||||
copyRepeat s = copy s >> selectCopy l
|
||||
copyHotkey = Hotkey
|
||||
{ keyCombo = "Alt+c"
|
||||
, keyIndex = 1
|
||||
, keyDescription = "Copy One"
|
||||
, keyActions = loginToRofiActions l copyRepeat
|
||||
}
|
||||
backHotkey = Hotkey
|
||||
{ keyCombo = "Alt+q"
|
||||
, keyIndex = 2
|
||||
, keyDescription = "Back"
|
||||
-- TODO this is overly complicated, all entries do the same thing
|
||||
-- TODO this is slow, we can cache the logins somehow...
|
||||
, keyActions = loginToRofiActions l (const browseLogins)
|
||||
}
|
||||
copyHotkey =
|
||||
Hotkey
|
||||
{ keyCombo = "Alt+c"
|
||||
, keyIndex = 1
|
||||
, keyDescription = "Copy One"
|
||||
, keyActions = loginToRofiActions l copyRepeat
|
||||
}
|
||||
backHotkey =
|
||||
Hotkey
|
||||
{ keyCombo = "Alt+q"
|
||||
, keyIndex = 2
|
||||
, keyDescription = "Back"
|
||||
, -- TODO this is overly complicated, all entries do the same thing
|
||||
-- TODO this is slow, we can cache the logins somehow...
|
||||
keyActions = loginToRofiActions l (const browseLogins)
|
||||
}
|
||||
|
||||
loginToRofiActions :: RofiConf c => Login -> (String -> RofiIO c ()) -> RofiActions c
|
||||
loginToRofiActions Login { username = u, password = p } a =
|
||||
loginToRofiActions :: Login -> (String -> RofiIO c ()) -> RofiActions c
|
||||
loginToRofiActions Login {username = u, password = p} a =
|
||||
toRofiActions $ catMaybes [user, pwd]
|
||||
where
|
||||
copyIfJust f = fmap $ liftM2 (,) f a
|
||||
|
|
@ -219,27 +223,31 @@ getItemPassword' conf session item = mapM getPwd =<< getSession' conf session
|
|||
getPwd s = readProcess "bw" ["get", "password", item, "--session", s] ""
|
||||
|
||||
getItemPassword :: BWServerConf -> Session -> String -> IO String
|
||||
getItemPassword conf session item = fromMaybe "" <$>
|
||||
getItemPassword' conf session item
|
||||
getItemPassword conf session item =
|
||||
fromMaybe ""
|
||||
<$> getItemPassword' conf session item
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | DBus
|
||||
|
||||
-- | DBus
|
||||
startService :: BWServerConf -> Session -> IO ()
|
||||
startService c ses = do
|
||||
client <- connectSession
|
||||
let flags = [nameAllowReplacement, nameReplaceExisting]
|
||||
_ <- requestName client busname flags
|
||||
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
|
||||
]
|
||||
}
|
||||
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
|
||||
]
|
||||
}
|
||||
|
||||
busname :: BusName
|
||||
busname = "org.rofi.bitwarden"
|
||||
|
|
@ -266,7 +274,7 @@ callMember :: MemberName -> IO [Variant]
|
|||
callMember m = do
|
||||
reply <- callMethod $ methodCall path interface m
|
||||
case reply of
|
||||
Left err -> putStrLn (methodErrorMessage err) >> return []
|
||||
Left err -> TI.putStrLn (T.pack (methodErrorMessage err)) >> return []
|
||||
Right body -> return body
|
||||
|
||||
callLockSession :: IO ()
|
||||
|
|
@ -283,12 +291,12 @@ callGetSession = getBodyString <$> callMember memGetSession
|
|||
getBodyString :: [Variant] -> Maybe String
|
||||
getBodyString [b] = case fromVariant b :: Maybe String of
|
||||
Just "" -> Nothing
|
||||
s -> s
|
||||
s -> s
|
||||
getBodyString _ = Nothing
|
||||
|
||||
callMethod :: MethodCall -> IO (Either MethodError [Variant])
|
||||
callMethod mc = do
|
||||
client <- connectSession
|
||||
reply <- call client mc { methodCallDestination = Just busname }
|
||||
reply <- call client mc {methodCallDestination = Just busname}
|
||||
disconnect client
|
||||
return $ methodReturnBody <$> reply
|
||||
|
|
|
|||
|
|
@ -1,13 +1,11 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Rofi.Command
|
||||
( RofiConf(..)
|
||||
, RofiMenu(..)
|
||||
( RofiConf (..)
|
||||
, RofiMenu (..)
|
||||
, RofiAction
|
||||
, RofiActions
|
||||
, RofiIO
|
||||
, RofiGroup
|
||||
, Hotkey(..)
|
||||
, Hotkey (..)
|
||||
, io
|
||||
, emptyMenu
|
||||
, runRofiIO
|
||||
|
|
@ -24,18 +22,17 @@ module Rofi.Command
|
|||
, dmenuArgs
|
||||
, joinNewline
|
||||
, stripWS
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import qualified Data.Map.Ordered as M
|
||||
import Data.Maybe
|
||||
|
||||
import System.Exit
|
||||
import System.Process
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.Char
|
||||
import qualified Data.Map.Ordered as M
|
||||
import Data.Maybe
|
||||
import RIO
|
||||
import qualified RIO.List as L
|
||||
import System.Process
|
||||
|
||||
class RofiConf c where
|
||||
defArgs :: c -> [String]
|
||||
|
|
@ -45,59 +42,56 @@ type RofiAction c = (String, RofiIO c ())
|
|||
type RofiActions c = M.OMap String (RofiIO c ())
|
||||
|
||||
data RofiGroup c = RofiGroup
|
||||
{ actions :: RofiActions c
|
||||
, title :: Maybe String
|
||||
}
|
||||
{ actions :: RofiActions c
|
||||
, title :: Maybe String
|
||||
}
|
||||
|
||||
untitledGroup :: RofiActions c -> RofiGroup c
|
||||
untitledGroup a = RofiGroup { actions = a, title = Nothing }
|
||||
untitledGroup a = RofiGroup {actions = a, title = Nothing}
|
||||
|
||||
titledGroup :: String -> RofiActions c -> RofiGroup c
|
||||
titledGroup t a = (untitledGroup a) { title = Just t }
|
||||
titledGroup t a = (untitledGroup a) {title = Just t}
|
||||
|
||||
data Hotkey c = Hotkey
|
||||
{ keyCombo :: String
|
||||
-- only 1-10 are valid
|
||||
, keyIndex :: Int
|
||||
, keyDescription :: String
|
||||
, keyActions :: RofiActions c
|
||||
}
|
||||
{ keyCombo :: String
|
||||
, -- only 1-10 are valid
|
||||
keyIndex :: Int
|
||||
, keyDescription :: String
|
||||
, keyActions :: RofiActions c
|
||||
}
|
||||
|
||||
hotkeyBinding :: Hotkey c -> [String]
|
||||
hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c]
|
||||
hotkeyBinding Hotkey {keyIndex = e, keyCombo = c} = [k, c]
|
||||
where
|
||||
k = "-kb-custom-" ++ show e
|
||||
|
||||
hotkeyMsg1 :: Hotkey c -> String
|
||||
hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } =
|
||||
hotkeyMsg1 Hotkey {keyCombo = c, keyDescription = d} =
|
||||
c ++ ": <i>" ++ d ++ "</i>"
|
||||
|
||||
hotkeyMsg :: [Hotkey c] -> [String]
|
||||
hotkeyMsg [] = []
|
||||
hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs]
|
||||
hotkeyMsg hs = ["-mesg", L.intercalate " | " $ fmap hotkeyMsg1 hs]
|
||||
|
||||
hotkeyArgs :: [Hotkey c] -> [String]
|
||||
hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
|
||||
|
||||
data RofiMenu c = RofiMenu
|
||||
{ groups :: [RofiGroup c]
|
||||
, prompt :: Maybe String
|
||||
, hotkeys :: [Hotkey c]
|
||||
}
|
||||
|
||||
emptyMenu :: RofiMenu c
|
||||
emptyMenu = RofiMenu
|
||||
{ groups = []
|
||||
, prompt = Nothing
|
||||
, hotkeys = []
|
||||
{ groups :: [RofiGroup c]
|
||||
, prompt :: Maybe String
|
||||
, hotkeys :: [Hotkey c]
|
||||
}
|
||||
|
||||
newtype RofiIO c a = RofiIO (ReaderT c IO a)
|
||||
deriving (Functor, Monad, MonadIO, MonadReader c, MonadUnliftIO)
|
||||
emptyMenu :: RofiMenu c
|
||||
emptyMenu =
|
||||
RofiMenu
|
||||
{ groups = []
|
||||
, prompt = Nothing
|
||||
, hotkeys = []
|
||||
}
|
||||
|
||||
instance Applicative (RofiIO c) where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
newtype RofiIO c a = RofiIO (ReaderT c IO a)
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadReader c, MonadUnliftIO)
|
||||
|
||||
io :: MonadIO m => IO a -> m a
|
||||
io = liftIO
|
||||
|
|
@ -115,17 +109,17 @@ lookupRofiAction :: String -> RofiActions c -> RofiIO c ()
|
|||
lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
|
||||
|
||||
groupEntries :: RofiGroup c -> String
|
||||
groupEntries RofiGroup { actions = a, title = t }
|
||||
groupEntries RofiGroup {actions = a, title = t}
|
||||
| null a = ""
|
||||
| otherwise = title' ++ rofiActionKeys a
|
||||
where
|
||||
title' = maybe "" (++ "\n") t
|
||||
|
||||
menuActions :: RofiMenu c -> RofiActions c
|
||||
menuActions = foldr1 (M.<>|) . fmap actions . groups
|
||||
menuActions = L.foldr (M.<>|) M.empty . fmap actions . groups
|
||||
|
||||
menuEntries :: RofiMenu c -> String
|
||||
menuEntries = intercalate "\n\n" . filter (not . null) . fmap groupEntries . groups
|
||||
menuEntries = L.intercalate "\n\n" . filter (not . null) . fmap groupEntries . groups
|
||||
|
||||
selectAction :: RofiConf c => RofiMenu c -> RofiIO c ()
|
||||
selectAction rm = do
|
||||
|
|
@ -133,10 +127,11 @@ selectAction rm = do
|
|||
let hArgs = hotkeyArgs $ hotkeys rm
|
||||
res <- readRofi (p ++ hArgs) $ menuEntries rm
|
||||
case res of
|
||||
Right key -> lookupRofiAction key $ menuActions rm
|
||||
Left (n, key, _) -> mapM_ (lookupRofiAction key . keyActions)
|
||||
$ find ((==) n . (+ 9) . keyIndex)
|
||||
$ hotkeys rm
|
||||
Right key -> lookupRofiAction key $ menuActions rm
|
||||
Left (n, key, _) ->
|
||||
mapM_ (lookupRofiAction key . keyActions) $
|
||||
L.find ((==) n . (+ 9) . keyIndex) $
|
||||
hotkeys rm
|
||||
|
||||
maybeOption :: String -> Maybe String -> [String]
|
||||
maybeOption switch = maybe [] (\o -> [switch, o])
|
||||
|
|
@ -144,7 +139,9 @@ maybeOption switch = maybe [] (\o -> [switch, o])
|
|||
dmenuArgs :: [String]
|
||||
dmenuArgs = ["-dmenu"]
|
||||
|
||||
readRofi :: RofiConf c => [String]
|
||||
readRofi
|
||||
:: RofiConf c
|
||||
=> [String]
|
||||
-> String
|
||||
-> RofiIO c (Either (Int, String, String) String)
|
||||
readRofi uargs input = do
|
||||
|
|
@ -152,36 +149,42 @@ readRofi uargs input = do
|
|||
io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
|
||||
|
||||
readCmdSuccess :: String -> [String] -> String -> IO (Maybe String)
|
||||
readCmdSuccess cmd args input = either (const Nothing) Just
|
||||
<$> readCmdEither cmd args input
|
||||
readCmdSuccess cmd args input =
|
||||
either (const Nothing) Just
|
||||
<$> readCmdEither cmd args input
|
||||
|
||||
readCmdEither :: String
|
||||
readCmdEither
|
||||
:: String
|
||||
-> [String]
|
||||
-> String
|
||||
-> IO (Either (Int, String, String) String)
|
||||
readCmdEither cmd args input = resultToEither
|
||||
<$> readProcessWithExitCode cmd args input
|
||||
readCmdEither cmd args input =
|
||||
resultToEither
|
||||
<$> readProcessWithExitCode cmd args input
|
||||
|
||||
readCmdEither' :: String
|
||||
readCmdEither'
|
||||
:: String
|
||||
-> [String]
|
||||
-> String
|
||||
-> [(String, String)]
|
||||
-> IO (Either (Int, String, String) String)
|
||||
readCmdEither' cmd args input environ = resultToEither
|
||||
<$> readCreateProcessWithExitCode p input
|
||||
readCmdEither' cmd args input environ =
|
||||
resultToEither
|
||||
<$> readCreateProcessWithExitCode p input
|
||||
where
|
||||
p = (proc cmd args) { env = Just environ }
|
||||
p = (proc cmd args) {env = Just environ}
|
||||
|
||||
resultToEither :: (ExitCode, String, String)
|
||||
resultToEither
|
||||
:: (ExitCode, String, String)
|
||||
-> Either (Int, String, String) String
|
||||
resultToEither (ExitSuccess, out, _) = Right $ stripWS out
|
||||
resultToEither (ExitSuccess, out, _) = Right $ stripWS out
|
||||
resultToEither (ExitFailure n, out, err) = Left (n, stripWS out, stripWS err)
|
||||
|
||||
stripWS :: String -> String
|
||||
stripWS = reverse . dropWhile isSpace . reverse
|
||||
|
||||
joinNewline :: [String] -> String
|
||||
joinNewline = intercalate "\n"
|
||||
joinNewline = L.intercalate "\n"
|
||||
|
||||
readPassword :: IO (Maybe String)
|
||||
readPassword = readPassword' "Password"
|
||||
|
|
|
|||
82
package.yaml
82
package.yaml
|
|
@ -9,15 +9,56 @@ copyright: "2020 Nathan Dwarshuis"
|
|||
extra-source-files:
|
||||
- README.md
|
||||
|
||||
# Metadata used when publishing your package
|
||||
# synopsis: Short description of your package
|
||||
# category: Web
|
||||
|
||||
# To avoid duplicated efforts in documentation and dealing with the
|
||||
# complications of embedding Haddock markup inside cabal files, it is
|
||||
# common to point users to the README.md file.
|
||||
description: Please see the README on GitHub at <https://github.com/ndwarshuis/rofi-extras#readme>
|
||||
|
||||
default-extensions:
|
||||
- OverloadedStrings
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- InstanceSigs
|
||||
- MultiParamTypeClasses
|
||||
- EmptyCase
|
||||
- LambdaCase
|
||||
- MultiWayIf
|
||||
- NamedFieldPuns
|
||||
- TupleSections
|
||||
- DeriveFoldable
|
||||
- DeriveFunctor
|
||||
- DeriveGeneric
|
||||
- DeriveLift
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- DeriveDataTypeable
|
||||
- EmptyDataDecls
|
||||
- PartialTypeSignatures
|
||||
- GeneralizedNewtypeDeriving
|
||||
- StandaloneDeriving
|
||||
- BangPatterns
|
||||
- TypeOperators
|
||||
- ScopedTypeVariables
|
||||
- TypeApplications
|
||||
- ConstraintKinds
|
||||
- RankNTypes
|
||||
- GADTs
|
||||
- DefaultSignatures
|
||||
- NoImplicitPrelude
|
||||
- FunctionalDependencies
|
||||
- DataKinds
|
||||
- TypeFamilies
|
||||
- BinaryLiterals
|
||||
- ViewPatterns
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wpartial-fields
|
||||
- -Werror
|
||||
- -O2
|
||||
|
||||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- process >= 1.6.5.0
|
||||
|
|
@ -42,14 +83,10 @@ dependencies:
|
|||
- bimap >= 0.2.4
|
||||
- dhall >= 1.40.2
|
||||
- lens >= 5.0.1
|
||||
- rio
|
||||
|
||||
library:
|
||||
source-dirs: lib/
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wpartial-fields
|
||||
exposed-modules:
|
||||
- Bitwarden.Internal
|
||||
- Rofi.Command
|
||||
|
|
@ -59,10 +96,7 @@ executables:
|
|||
main: pinentry-rofi.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wpartial-fields
|
||||
dependencies:
|
||||
- rofi-extras
|
||||
|
||||
|
|
@ -70,10 +104,7 @@ executables:
|
|||
main: rofi-autorandr.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wpartial-fields
|
||||
dependencies:
|
||||
- rofi-extras
|
||||
|
||||
|
|
@ -81,10 +112,7 @@ executables:
|
|||
main: rofi-bw.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wpartial-fields
|
||||
dependencies:
|
||||
- rofi-extras
|
||||
|
||||
|
|
@ -92,10 +120,7 @@ executables:
|
|||
main: rofi-bt.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wpartial-fields
|
||||
dependencies:
|
||||
- rofi-extras
|
||||
|
||||
|
|
@ -103,10 +128,7 @@ executables:
|
|||
main: rofi-dev.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wpartial-fields
|
||||
dependencies:
|
||||
- rofi-extras
|
||||
|
||||
|
|
@ -114,10 +136,7 @@ executables:
|
|||
main: rofi-evpn.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wpartial-fields
|
||||
dependencies:
|
||||
- rofi-extras
|
||||
|
||||
|
|
@ -125,9 +144,6 @@ executables:
|
|||
main: rofi.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -threaded
|
||||
- -Wpartial-fields
|
||||
dependencies:
|
||||
- rofi-extras
|
||||
|
|
|
|||
Loading…
Reference in New Issue