ndwarshuis
/
rofi-extras
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF use rio and better flags

This commit is contained in:
Nathan Dwarshuis 2023-02-13 22:19:49 -05:00
parent cfe0607e2e
commit 4265a5947c
10 changed files with 467 additions and 435 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
app/pinentry-rofi.hs
View File

@ -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 -- Rather than prompt the user like all the other pinentry programs, call the
-- bitwarden deamon and prompt for a password there -- bitwarden deamon and prompt for a password there
module Main where module Main where
import Bitwarden.Internal import Bitwarden.Internal
import qualified Data.Text.IO as TI
import Data.List import Data.Yaml
import Data.Yaml import RIO
import qualified RIO.List as L
import System.Directory import qualified RIO.Text as T
import System.Environment import System.Directory
import System.Exit import System.Environment
import System.FilePath.Posix import System.FilePath.Posix
import System.IO import System.Posix.Process
import System.Posix.Process
main :: IO () main :: IO ()
main = do main = do
hSetBuffering stdout LineBuffering hSetBuffering stdout LineBuffering
putStrLn "OK Pleased to meet you" TI.putStrLn "OK Pleased to meet you"
pinentryLoop =<< readPinConf pinentryLoop =<< readPinConf
newtype PinConf = PinConf { pcBwName :: String } deriving (Eq, Show) newtype PinConf = PinConf {pcBwName :: String} deriving (Eq, Show)
instance FromJSON PinConf where instance FromJSON PinConf where
parseJSON (Object o) = PinConf <$> o .:? "bitwarden-name" .!= "gnupg" parseJSON (Object o) = PinConf <$> o .:? "bitwarden-name" .!= "gnupg"
parseJSON _ = fail "pinentry yaml parse error" parseJSON _ = fail "pinentry yaml parse error"
readPinConf :: IO PinConf readPinConf :: IO PinConf
readPinConf = do readPinConf = do
c <- decodeFileEither =<< pinConfDir c <- decodeFileEither =<< pinConfDir
case c of 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 Right r -> return r
pinConfDir :: IO FilePath pinConfDir :: IO FilePath
@ -47,60 +44,55 @@ pinConfDir = maybe defHome (return . (</> confname)) =<< lookupEnv "GNUPGHOME"
pinentryLoop :: PinConf -> IO () pinentryLoop :: PinConf -> IO ()
pinentryLoop p = do pinentryLoop p = do
processLine p . words =<< getLine processLine p . T.words =<< TI.getLine
pinentryLoop p pinentryLoop p
processLine :: PinConf -> [String] -> IO () processLine :: PinConf -> [T.Text] -> IO ()
processLine _ [] = noop processLine _ [] = noop
processLine _ ["BYE"] = exitSuccess processLine _ ["BYE"] = exitSuccess
processLine p ["GETPIN"] = getPin p processLine p ["GETPIN"] = getPin p
processLine _ ["GETINFO", o] = processGetInfo o
processLine _ ["GETINFO", o] = processGetInfo o
-- TODO this might be important -- TODO this might be important
processLine _ ["OPTION", o] = processOption o processLine _ ["OPTION", o] = processOption o
-- these should all do nothing -- these should all do nothing
processLine _ ("SETDESC":_) = noop processLine _ ("SETDESC" : _) = noop
processLine _ ("SETOK":_) = noop processLine _ ("SETOK" : _) = noop
processLine _ ("SETNOTOK":_) = noop processLine _ ("SETNOTOK" : _) = noop
processLine _ ("SETCANCEL":_) = noop processLine _ ("SETCANCEL" : _) = noop
processLine _ ("SETPROMPT":_) = noop processLine _ ("SETPROMPT" : _) = noop
processLine _ ("SETERROR":_) = noop processLine _ ("SETERROR" : _) = noop
-- CONFIRM can take a flag -- CONFIRM can take a flag
processLine _ ["CONFIRM"] = noop processLine _ ["CONFIRM"] = noop
processLine _ ["CONFIRM", "--one-button", _] = noop processLine _ ["CONFIRM", "--one-button", _] = noop
processLine _ ss = unknownCommand $ T.unwords ss
processLine _ ss = unknownCommand $ unwords ss unknownCommand :: T.Text -> IO ()
unknownCommand c = TI.putStrLn $ T.append "ERR 275 Unknown command " c
unknownCommand :: String -> IO ()
unknownCommand c = putStrLn $ "ERR 275 Unknown command " ++ c
getPin :: PinConf -> IO () getPin :: PinConf -> IO ()
getPin p = do getPin p = do
its <- getItems 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 maybe err send w
where 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 -- these are the only supported options for GETINFO; anything else is an error
processGetInfo :: String -> IO () processGetInfo :: T.Text -> IO ()
processGetInfo "pid" = send . show =<< getProcessID processGetInfo "pid" = send . T.pack . show =<< getProcessID
processGetInfo "version" = noop processGetInfo "version" = noop
processGetInfo "flavor" = noop processGetInfo "flavor" = noop
processGetInfo "ttyinfo" = 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 processOption _ = noop
send :: String -> IO () send :: T.Text -> IO ()
send s = putStrLn ("D " ++ s) >> ok send s = TI.putStrLn (T.append "D " s) >> ok
noop :: IO () noop :: IO ()
noop = ok noop = ok
ok :: IO () ok :: IO ()
ok = putStrLn "OK" ok = TI.putStrLn "OK"

48
app/rofi-autorandr.hs
View File

@ -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. -- Simple wrapper to select an autorandr profile.
module Main (main) where module Main (main) where
import Control.Monad import Control.Monad
import Data.Maybe
import Data.Maybe import qualified Data.Text.IO as TI
import RIO
import Rofi.Command import qualified RIO.Text as T
import Rofi.Command
import System.Directory import System.Directory
import System.Environment import System.Environment
import System.Exit import System.FilePath.Posix
import System.FilePath.Posix import System.Process
import System.Process
main :: IO () main :: IO ()
main = runChecks >> getArgs >>= runPrompt main = runChecks >> getArgs >>= runPrompt
@ -29,7 +27,7 @@ checkExe :: String -> IO ()
checkExe cmd = do checkExe cmd = do
res <- findExecutable cmd res <- findExecutable cmd
unless (isJust res) $ do unless (isJust res) $ do
putStrLn $ "Could not find executable: " ++ cmd TI.putStrLn $ T.append "Could not find executable: " $ T.pack cmd
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1
newtype ARClientConf = ARClientConf [String] newtype ARClientConf = ARClientConf [String]
@ -41,13 +39,17 @@ runPrompt :: [String] -> IO ()
runPrompt a = do runPrompt a = do
let c = ARClientConf a let c = ARClientConf a
staticProfs <- getAutoRandrProfiles staticProfs <- getAutoRandrProfiles
runRofiIO c $ selectAction $ emptyMenu runRofiIO c $
{ groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs] selectAction $
, prompt = Just "Select Profile" emptyMenu
} { groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs]
, prompt = Just "Select Profile"
}
where where
mkGroup header = titledGroup header . toRofiActions mkGroup header =
. fmap (\s -> (" " ++ s, selectProfile s)) titledGroup header
. toRofiActions
. fmap (\s -> (" " ++ s, selectProfile $ T.pack s))
virtProfs :: [String] virtProfs :: [String]
virtProfs = ["off", "common", "clone-largest", "horizontal", "vertical"] virtProfs = ["off", "common", "clone-largest", "horizontal", "vertical"]
@ -67,7 +69,7 @@ getAutoRandrDir = do
where where
appendToHome p = (</> p) <$> getHomeDirectory appendToHome p = (</> p) <$> getHomeDirectory
selectProfile :: String -> RofiIO ARClientConf () selectProfile :: T.Text -> RofiIO ARClientConf ()
selectProfile name = do selectProfile name = do
io $ putStrLn name io $ TI.putStrLn name
io $ void $ spawnProcess "autorandr" ["--change", name] io $ void $ spawnProcess "autorandr" ["--change", T.unpack name]

96
app/rofi-bt.hs
View File

@ -1,24 +1,20 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | rofi-bt - a prompt to dicsonnect/connect devices -- rofi-bt - a prompt to dicsonnect/connect devices
-- --
module Main (main) where module Main (main) where
import Control.Exception import DBus
import Control.Monad import DBus.Client
import Control.Monad.Reader import Data.List.Split
import qualified Data.Map as M
import Data.List import Data.Maybe
import Data.List.Split import qualified Data.Text.IO as TI
import qualified Data.Map as M import RIO
import Data.Maybe import qualified RIO.List as L
import qualified RIO.Text as T
import DBus import Rofi.Command
import DBus.Client import System.Environment
import Rofi.Command
import System.Environment
main :: IO () main :: IO ()
main = getArgs >>= runPrompt main = getArgs >>= runPrompt
@ -33,18 +29,20 @@ type BTAction = RofiAction RofiBTConf
runPrompt :: [String] -> IO () runPrompt :: [String] -> IO ()
runPrompt args = do runPrompt args = do
c <- getClient c <- getClient
maybe (putStrLn "could not get DBus client") run c maybe (TI.putStrLn "could not get DBus client") run c
where where
run client = do run client = do
paths <- M.keys <$> getObjectTree client paths <- M.keys <$> getObjectTree client
maybe (putStrLn "could not get DBus adapter") (actions client paths) maybe (TI.putStrLn "could not get DBus adapter") (actions client paths) $
$ getAdapter paths getAdapter paths
actions client paths adapter = do actions client paths adapter = do
ras <- getRofiActions client paths ras <- getRofiActions client paths
runRofiIO (RofiBTConf args adapter) $ selectAction $ emptyMenu runRofiIO (RofiBTConf args adapter) $
{ groups = [untitledGroup $ toRofiActions ras] selectAction $
, prompt = Just "Select Device" emptyMenu
} { groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Select Device"
}
getRofiActions :: Client -> [ObjectPath] -> IO [BTAction] getRofiActions :: Client -> [ObjectPath] -> IO [BTAction]
getRofiActions client os = do getRofiActions client os = do
@ -56,12 +54,14 @@ deviceToRofiAction client dev = do
c <- getDeviceConnected client dev c <- getDeviceConnected client dev
n <- getDeviceName client dev n <- getDeviceName client dev
return $ case (c, n) of return $ case (c, n) of
(Just c', Just n') -> Just ( formatDeviceEntry c' n' (Just c', Just n') ->
, powerAdapterMaybe client >> io (mkAction c') Just
) ( formatDeviceEntry c' n'
_ -> Nothing , powerAdapterMaybe client >> io (mkAction c')
)
_ -> Nothing
where where
mkAction True = callDeviceDisconnect client dev mkAction True = callDeviceDisconnect client dev
mkAction False = callDeviceConnect client dev mkAction False = callDeviceConnect client dev
powerAdapterMaybe :: Client -> RofiIO RofiBTConf () powerAdapterMaybe :: Client -> RofiIO RofiBTConf ()
@ -70,7 +70,7 @@ powerAdapterMaybe client = do
let mc = btMethodCall adapter i m let mc = btMethodCall adapter i m
let powerOnMaybe = flip unless $ void $ setProperty client mc value let powerOnMaybe = flip unless $ void $ setProperty client mc value
powered <- io $ getBTProperty client adapter i m 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 where
i = interfaceName_ "org.bluez.Adapter1" i = interfaceName_ "org.bluez.Adapter1"
m = memberName_ "Powered" m = memberName_ "Powered"
@ -81,11 +81,11 @@ powerAdapterMaybe client = do
formatDeviceEntry :: Bool -> String -> String formatDeviceEntry :: Bool -> String -> String
formatDeviceEntry connected name = unwords [prefix connected, name] formatDeviceEntry connected name = unwords [prefix connected, name]
where where
prefix True = "#" prefix True = "#"
prefix False = " " prefix False = " "
getAdapter :: [ObjectPath] -> Maybe ObjectPath getAdapter :: [ObjectPath] -> Maybe ObjectPath
getAdapter = find pathIsAdaptor getAdapter = L.find pathIsAdaptor
getDevices :: Client -> [ObjectPath] -> IO [ObjectPath] getDevices :: Client -> [ObjectPath] -> IO [ObjectPath]
getDevices client = filterM (getDevicePaired client) . filter pathIsDevice getDevices client = filterM (getDevicePaired client) . filter pathIsDevice
@ -119,23 +119,23 @@ callDeviceDisconnect = callDevMethod "Disconnect"
pathIsAdaptor :: ObjectPath -> Bool pathIsAdaptor :: ObjectPath -> Bool
pathIsAdaptor o = case splitPath o of pathIsAdaptor o = case splitPath o of
[a, b, c] -> pathIsAdaptorPrefix a b c [a, b, c] -> pathIsAdaptorPrefix a b c
_ -> False _ -> False
pathIsDevice :: ObjectPath -> Bool pathIsDevice :: ObjectPath -> Bool
pathIsDevice o = case splitPath o of pathIsDevice o = case splitPath o of
[a, b, c, _] -> pathIsAdaptorPrefix a b c [a, b, c, _] -> pathIsAdaptorPrefix a b c
_ -> False _ -> False
pathIsAdaptorPrefix :: String -> String -> String -> Bool 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 :: ObjectPath -> [String]
splitPath =splitOn "/" . dropWhile (=='/') . formatObjectPath splitPath = splitOn "/" . dropWhile (== '/') . formatObjectPath
getClient :: IO (Maybe Client) getClient :: IO (Maybe Client)
getClient = either warn (return . Just) =<< try connectSystem getClient = either warn (return . Just) =<< try connectSystem
where where
warn e = putStrLn (clientErrorMessage e) >> return Nothing warn e = TI.putStrLn (T.pack $ clientErrorMessage e) >> return Nothing
callDevMethod :: String -> Client -> ObjectPath -> IO () callDevMethod :: String -> Client -> ObjectPath -> IO ()
callDevMethod mem client dev = callDevMethod mem client dev =
@ -145,19 +145,29 @@ getDevProperty :: IsVariant a => String -> Client -> ObjectPath -> IO (Maybe a)
getDevProperty mem client dev = getDevProperty mem client dev =
getBTProperty client dev btDevInterface $ memberName_ mem getBTProperty client dev btDevInterface $ memberName_ mem
callBTMethod :: Client -> ObjectPath -> InterfaceName callBTMethod
-> MemberName -> IO (Either MethodError MethodReturn) :: Client
-> ObjectPath
-> InterfaceName
-> MemberName
-> IO (Either MethodError MethodReturn)
callBTMethod client o i m = call client (btMethodCall o i m) 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 -- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
-> InterfaceName -> MemberName -> IO (Maybe a) -- <$> call client (btMethodCall o i m)
getBTProperty
:: IsVariant a
=> Client
-> ObjectPath
-> InterfaceName
-> MemberName
-> IO (Maybe a)
getBTProperty client o i m = getBTProperty client o i m =
eitherMaybe fromVariant <$> getProperty client (btMethodCall o i m) eitherMaybe fromVariant <$> getProperty client (btMethodCall o i m)
btMethodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall 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 :: (b -> Maybe c) -> Either a b -> Maybe c
eitherMaybe = either (const Nothing) eitherMaybe = either (const Nothing)

43
app/rofi-bw.hs
View File

@ -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 -- 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 -- properly configured before running this command. This shows a system of
@ -18,34 +16,31 @@
module Main (main) where module Main (main) where
import Bitwarden.Internal import Bitwarden.Internal
import qualified Data.Text.IO as TI
import Control.Monad import RIO
import RIO.Directory
import Data.Maybe import qualified RIO.Text as T
import Rofi.Command
import Rofi.Command import System.Environment
import Text.Read
import System.Directory
import System.Environment
import System.Exit
main :: IO () main :: IO ()
main = runChecks >> getArgs >>= parse main = runChecks >> getArgs >>= parse
-- TODO check if daemon is running when running client -- TODO check if daemon is running when running client
parse :: [String] -> IO () parse :: [String] -> IO ()
parse ["-d", t] = case readMaybe t of { Just t' -> runDaemon t'; _ -> usage } parse ["-d", t] = case readMaybe t of Just t' -> runDaemon t'; _ -> usage
parse ("-c":args) = runClient args parse ("-c" : args) = runClient args
parse _ = usage parse _ = usage
usage :: IO () usage :: IO ()
usage = putStrLn $ joinNewline usage =
[ "daemon mode: rofi-bw -d TIMEOUT" TI.putStrLn $
, "client mode: rofi-bw -c [ROFI-ARGS]" T.pack $
] joinNewline
[ "daemon mode: rofi-bw -d TIMEOUT"
, "client mode: rofi-bw -c [ROFI-ARGS]"
]
runChecks :: IO () runChecks :: IO ()
runChecks = checkExe "bw" >> checkExe "rofi" runChecks = checkExe "bw" >> checkExe "rofi"
@ -54,5 +49,5 @@ checkExe :: String -> IO ()
checkExe cmd = do checkExe cmd = do
res <- findExecutable cmd res <- findExecutable cmd
unless (isJust res) $ do unless (isJust res) $ do
putStrLn $ "Could not find executable: " ++ cmd TI.putStrLn $ T.append "Could not find executable: " $ T.pack cmd
exitWith $ ExitFailure 1 exitWith $ ExitFailure 1

69
app/rofi-dev.hs
View File

@ -1,8 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- rofi-dev - a rofi prompt for mountable devices -- rofi-dev - a rofi prompt for mountable devices
@ -14,35 +11,33 @@
module Main (main) where module Main (main) where
import Bitwarden.Internal import Bitwarden.Internal
import Control.Lens
import Control.Monad
import Control.Monad.Reader
import Data.List
import Data.List.Split (splitOn) import Data.List.Split (splitOn)
import qualified Data.Map as M import qualified Data.Text.IO as TI
import Data.Maybe
import qualified Data.Text as T
import Data.Typeable import Data.Typeable
import qualified Data.Vector as V
import Dhall hiding (maybe, sequence, void) import Dhall hiding (maybe, sequence, void)
import qualified Dhall.Map as DM 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 Rofi.Command
import System.Console.GetOpt import System.Console.GetOpt
import System.Directory
import System.Environment import System.Environment
import System.FilePath.Posix import System.FilePath.Posix
import System.Posix.User (getEffectiveUserName) import System.Posix.User (getEffectiveUserName)
import System.Process import System.Process
import Text.Printf import Text.Printf
import UnliftIO.Exception
main :: IO () main :: IO ()
main = getArgs >>= parse main = getArgs >>= parse
parse :: [String] -> IO () parse :: [String] -> IO ()
parse args = case getOpt Permute options args of parse args = case getOpt Permute options args of
(o, n, []) -> runMounts $ foldl (flip id) (defaultOpts n) o (o, n, []) -> runMounts $ L.foldl (flip id) (defaultOpts n) o
(_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options (_, _, errs) -> TI.putStrLn $ T.pack $ concat errs ++ usageInfo h options
where where
h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]" h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
defaultOpts r = defaultOpts r =
@ -109,7 +104,7 @@ parseStaticConfig :: FilePath -> IO (Maybe StaticConfig)
parseStaticConfig p = do parseStaticConfig p = do
res <- try $ inputFileWithSettings es auto p res <- try $ inputFileWithSettings es auto p
case res of 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) Right c -> return $ Just (c :: StaticConfig)
where where
es = over substitutions (DM.union vars) defaultEvaluateSettings es = over substitutions (DM.union vars) defaultEvaluateSettings
@ -130,7 +125,7 @@ parseStaticConfig p = do
, toVar (auto :: Decoder MountConfig) , toVar (auto :: Decoder MountConfig)
] ]
toVar a = toVar a =
fmap (\n -> (T.pack $ show n, maximum $ expected a)) $ fmap (\n -> (T.pack $ show n, LP.maximum $ expected a)) $
listToMaybe $ listToMaybe $
snd $ snd $
splitTyConApp $ splitTyConApp $
@ -150,8 +145,8 @@ getGroups = do
return $ return $
(++ [metaActions]) $ (++ [metaActions]) $
mapMaybe mkGroup $ mapMaybe mkGroup $
groupBy (\(hx, _) (hy, _) -> hx == hy) $ L.groupBy (\(hx, _) (hy, _) -> hx == hy) $
sortBy (\(hx, _) (hy, _) -> compare hx hy) $ L.sortBy (\(hx, _) (hy, _) -> compare hx hy) $
concat actions concat actions
where where
metaActions = metaActions =
@ -185,14 +180,14 @@ alignSep = " | "
alignEntries :: [ProtoAction [String]] -> [(String, RofiMountIO ())] alignEntries :: [ProtoAction [String]] -> [(String, RofiMountIO ())]
alignEntries ps = zip (align es) as alignEntries ps = zip (align es) as
where where
(es, as) = unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps (es, as) = L.unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
align = align =
fmap (intercalate alignSep) fmap (L.intercalate alignSep)
. transpose . L.transpose
. mapToLast pad . mapToLast pad
. transpose . L.transpose
pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs pad xs = let m = getMax xs in fmap (\x -> take m (x ++ L.repeat ' ')) xs
getMax = maximum . fmap length getMax = LP.maximum . fmap length
mapToLast _ [] = [] mapToLast _ [] = []
mapToLast _ [x] = [x] mapToLast _ [x] = [x]
mapToLast f (x : xs) = f x : mapToLast f xs 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 args = [remote, mountpoint] ++ maybe [] (\o -> ["-o", fromCIFSOpts o]) opts
fromCIFSOpts :: CIFSOpts -> String fromCIFSOpts :: CIFSOpts -> String
fromCIFSOpts o = intercalate "," $ mapMaybe concatMaybe fs fromCIFSOpts o = L.intercalate "," $ mapMaybe concatMaybe fs
where where
fs = fs =
[ ("username", cifsoptsUsername) [ ("username", cifsoptsUsername)
@ -589,7 +584,7 @@ runSecret kvs = readCmdSuccess "secret-tool" ("lookup" : kvs') ""
runBitwarden :: String -> PasswordGetter runBitwarden :: String -> PasswordGetter
runBitwarden pname = runBitwarden pname =
((password . login) <=< find (\i -> name i == pname)) ((password . login) <=< L.find (\i -> name i == pname))
<$> getItems <$> getItems
runPromptLoop :: Integer -> PasswordGetter -> PasswordGetter 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 -- 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 -- label shown on the prompt will be 'SIZE Volume' where size is the size of
-- the device -- the device
getRemovableDevices :: RofiConf c => RofiIO c [Removable] getRemovableDevices :: RofiIO c [Removable]
getRemovableDevices = getRemovableDevices =
fromLines toDev . lines fromLines toDev . lines
<$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "") <$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "")
@ -727,7 +722,7 @@ getMTPDevices = do
return $ fromLines (toDev dir) $ toDevList res return $ fromLines (toDev dir) $ toDevList res
toDevList = toDevList =
reverse reverse
. takeWhile (not . isPrefixOf "Available devices") . takeWhile (not . L.isPrefixOf "Available devices")
. reverse . reverse
. lines . lines
toDev dir s = case splitOn ", " s of toDev dir s = case splitOn ", " s of
@ -788,12 +783,12 @@ notify icon summary body =
data MountResult = MountSuccess | MountError String deriving (Show, Eq) data MountResult = MountSuccess | MountError String deriving (Show, Eq)
runMount :: String -> [String] -> String -> IO MountResult 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' :: String -> [String] -> String -> [(String, String)] -> IO MountResult
runMount' cmd args stdin environ = runMount' cmd args stdin_ environ =
eitherToMountResult eitherToMountResult
<$> readCmdEither' cmd args stdin environ <$> readCmdEither' cmd args stdin_ environ
runMountSudoMaybe :: Bool -> String -> [String] -> IO MountResult runMountSudoMaybe :: Bool -> String -> [String] -> IO MountResult
runMountSudoMaybe useSudo cmd args = runMountSudoMaybe useSudo cmd args =
@ -825,11 +820,11 @@ eitherToMountResult (Left (_, _, e)) = MountError e
mountMap :: IO (M.Map FilePath String) mountMap :: IO (M.Map FilePath String)
mountMap = do mountMap = do
parseFile <$> readFile "/proc/mounts" parseFile <$> readFileUtf8 "/proc/mounts"
where 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 -- 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 parseLine _ = Nothing
curDeviceSpecs :: IO [String] curDeviceSpecs :: IO [String]
@ -884,7 +879,7 @@ rmDirMaybe fp =
whenInMountDir :: FilePath -> RofiMountIO () -> RofiMountIO () whenInMountDir :: FilePath -> RofiMountIO () -> RofiMountIO ()
whenInMountDir fp f = do whenInMountDir fp f = do
mDir <- asks mountconfVolatilePath mDir <- asks mountconfVolatilePath
when (mDir `isPrefixOf` fp) f when (mDir `L.isPrefixOf` fp) f
unlessMountpoint :: MonadIO m => FilePath -> m () -> m () unlessMountpoint :: MonadIO m => FilePath -> m () -> m ()
unlessMountpoint fp f = do unlessMountpoint fp f = do

75
app/rofi-evpn.hs
View File

@ -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 module Main (main) where
import Control.Monad import Data.List (isPrefixOf)
import Data.List.Split
import Data.List (isPrefixOf) import Data.Maybe
import Data.List.Split import RIO
import Data.Maybe import Rofi.Command
import System.Environment
import Rofi.Command import System.Process
import System.Environment
import System.Process
main :: IO () main :: IO ()
main = getArgs >>= runPrompt main = getArgs >>= runPrompt
@ -26,13 +23,15 @@ runPrompt args = do
run (VPNStatus connected servers) = do run (VPNStatus connected servers) = do
let d = getDisconnectAction <$> connected let d = getDisconnectAction <$> connected
let cs = fmap (getConnectAction connected) servers let cs = fmap (getConnectAction connected) servers
runRofiIO (RofiVPNConf args) $ selectAction $ emptyMenu runRofiIO (RofiVPNConf args) $
{ groups = selectAction $
[ untitledGroup $ toRofiActions $ maybeToList d emptyMenu
, untitledGroup $ toRofiActions cs { groups =
] [ untitledGroup $ toRofiActions $ maybeToList d
, prompt = Just "Select Action" , untitledGroup $ toRofiActions cs
} ]
, prompt = Just "Select Action"
}
newtype RofiVPNConf = RofiVPNConf [String] newtype RofiVPNConf = RofiVPNConf [String]
@ -63,34 +62,36 @@ getConnectedServer = (procStatus =<<) <$> readCmdSuccess eVPN ["status"] ""
procStatus = listToMaybe . mapMaybe procLine . lines procStatus = listToMaybe . mapMaybe procLine . lines
procLine l = case words l of procLine l = case words l of
-- the output is green... -- the output is green...
("\ESC[1;32;49mConnected":"to":server) -> Just $ unwords server ("\ESC[1;32;49mConnected" : "to" : server) -> Just $ unwords server
_ -> Nothing _ -> Nothing
getAvailableServers :: IO [VPNServer] getAvailableServers :: IO [VPNServer]
getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] "" getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
where where
procOut Nothing = do procOut Nothing = do
notify IconError "failed to get list of servers" notify IconError "failed to get list of servers"
return [] return []
-- ASSUME the output has a useless header that ends in a line that starts -- 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 -- 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 -- by a blank line, after which there is more stuff I don't care about
procOut (Just ls) = return procOut (Just ls) =
$ mapMaybe (matchLine . splitOn "\t") return $
$ takeWhile (/= "") mapMaybe (matchLine . splitOn "\t") $
$ drop 1 takeWhile (/= "") $
-- super lame way of matching lines that start with "-----" drop 1
$ dropWhile (not . isPrefixOf "-----") -- super lame way of matching lines that start with "-----"
$ lines ls $
dropWhile (not . isPrefixOf "-----") $
lines ls
-- The output of this command is very strange; it is delimited (kinda) by -- 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 -- 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 -- 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 -- id is always at the front and the location is always at the end. These
-- should handle all cases. -- 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 [i, _, _, _, l] = Just (i, l)
matchLine _ = Nothing matchLine _ = Nothing
daemonIsRunning :: IO Bool daemonIsRunning :: IO Bool
daemonIsRunning = isJust <$> readCmdSuccess "pgrep" [eVPND] "" daemonIsRunning = isJust <$> readCmdSuccess "pgrep" [eVPND] ""
@ -123,13 +124,17 @@ eVPND = "expressvpnd"
connect :: VPNServer -> IO () connect :: VPNServer -> IO ()
connect (sid, sname) = do connect (sid, sname) = do
res <- readCmdSuccess' eVPN ["connect", sid] res <- readCmdSuccess' eVPN ["connect", sid]
notifyIf res ("connected to " ++ sname) notifyIf
res
("connected to " ++ sname)
("failed to connect to " ++ sname) ("failed to connect to " ++ sname)
disconnect :: String -> IO Bool disconnect :: String -> IO Bool
disconnect server = do disconnect server = do
res <- readCmdSuccess' eVPN ["disconnect"] res <- readCmdSuccess' eVPN ["disconnect"]
notifyIf res ("disconnected from " ++ server) notifyIf
res
("disconnected from " ++ server)
("failed to disconnect from " ++ server) ("failed to disconnect from " ++ server)
return res return res
@ -141,10 +146,10 @@ data NotifyIcon = IconError | IconInfo
instance Show NotifyIcon where instance Show NotifyIcon where
show IconError = "dialog-error-symbolic" show IconError = "dialog-error-symbolic"
show IconInfo = "dialog-information-symbolic" show IconInfo = "dialog-information-symbolic"
notifyIf :: Bool -> String -> String -> IO () notifyIf :: Bool -> String -> String -> IO ()
notifyIf True s _ = notify IconInfo s notifyIf True s _ = notify IconInfo s
notifyIf False _ s = notify IconError s notifyIf False _ s = notify IconError s
notify :: NotifyIcon -> String -> IO () notify :: NotifyIcon -> String -> IO ()

50
app/rofi.hs
View File

@ -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 -- 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 -- 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) -- 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 -- 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 Data.Maybe
import Graphics.X11.Xlib import Graphics.X11.Types
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib
import Graphics.X11.Xrandr import Graphics.X11.Xlib.Extras
import Graphics.X11.Xrandr
import System.Environment import RIO hiding (Display)
import System.Process import System.Environment
import System.Process
main :: IO () main :: IO ()
main = do main = do
@ -60,29 +59,36 @@ getDesktopViewports dpy root =
pairs <$> getAtom32 dpy root "_NET_DESKTOP_VIEWPORT" pairs <$> getAtom32 dpy root "_NET_DESKTOP_VIEWPORT"
where where
pairs = reverse . pairs' [] pairs = reverse . pairs' []
pairs' acc (x1:x2:xs) = pairs' (Coord x1 x2 : acc) xs pairs' acc (x1 : x2 : xs) = pairs' (Coord x1 x2 : acc) xs
pairs' acc _ = acc pairs' acc _ = acc
getOutputs :: Display -> Window -> IO [(Coord, String)] getOutputs :: Display -> Window -> IO [(Coord, String)]
getOutputs dpy root = xrrGetScreenResourcesCurrent dpy root >>= getOutputs dpy root =
maybe (return []) resourcesToCells xrrGetScreenResourcesCurrent dpy root
>>= maybe (return []) resourcesToCells
where where
resourcesToCells r = catMaybes <$> mapM (outputToCell r) (xrr_sr_outputs r) resourcesToCells r = catMaybes <$> mapM (outputToCell r) (xrr_sr_outputs r)
outputToCell r o = xrrGetOutputInfo dpy r o >>= infoToCell r outputToCell r o = xrrGetOutputInfo dpy r o >>= infoToCell r
-- connection: 0 == connected, 1 == disconnected -- connection: 0 == connected, 1 == disconnected
infoToCell r (Just XRROutputInfo { xrr_oi_connection = 0 infoToCell
, xrr_oi_name = n r
, xrr_oi_crtc = c ( Just
}) = do XRROutputInfo
fmap (\i -> (toCoord i, n)) <$> xrrGetCrtcInfo dpy r c { 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 infoToCell _ _ = return Nothing
toCoord c = Coord (fromIntegral $ xrr_ci_x c) (fromIntegral $ xrr_ci_y c) toCoord c = Coord (fromIntegral $ xrr_ci_x c) (fromIntegral $ xrr_ci_y c)
infix 9 !!? infix 9 !!?
(!!?) :: [a] -> Int -> Maybe a (!!?) :: [a] -> Int -> Maybe a
(!!?) xs i (!!?) xs i
| i < 0 = Nothing | i < 0 = Nothing
| otherwise = listToMaybe $ drop i xs | otherwise = listToMaybe $ drop i xs
getAtom32 :: Display -> Window -> String -> IO [Int] getAtom32 :: Display -> Window -> String -> IO [Int]
getAtom32 dpy root str = do getAtom32 dpy root str = do

214
lib/Bitwarden/Internal.hs
View File

@ -1,36 +1,29 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Bitwarden.Internal module Bitwarden.Internal
( Item(..) ( Item (..)
, Login(..) , Login (..)
, Session , Session
, runDaemon , runDaemon
, runClient , runClient
, getItems , getItems
, callGetSession , callGetSession
) where )
where
import Control.Concurrent import DBus
import Control.Monad import DBus.Client
import Data.Aeson
import Data.Aeson import Data.String
import Data.Maybe import qualified Data.Text.IO as TI
import Data.String import Data.UnixTime
import Data.UnixTime import GHC.Generics
import RIO hiding (timeout)
import DBus import qualified RIO.Text as T
import DBus.Client import Rofi.Command
import System.Clipboard
import GHC.Generics import System.Process
import Rofi.Command
import System.Clipboard
import System.Process
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Daemon -- | Daemon
-- --
-- Daemon will export an interface on DBus with two methods: -- 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 -- * lock session - destroy the current session id if active
-- --
-- The session ID will be valid only as long as TIMEOUT -- The session ID will be valid only as long as TIMEOUT
newtype BWServerConf = BWServerConf newtype BWServerConf = BWServerConf
{ timeout :: UnixDiffTime { timeout :: UnixDiffTime
} }
-- TODO add a cache so the browse list will load faster -- TODO add a cache so the browse list will load faster
data CurrentSession = CurrentSession data CurrentSession = CurrentSession
{ timestamp :: UnixTime { timestamp :: UnixTime
, hash :: String , hash :: String
} }
type Session = MVar (Maybe CurrentSession) type Session = MVar (Maybe CurrentSession)
runDaemon :: Int -> IO () runDaemon :: Int -> IO ()
runDaemon t = do runDaemon t = do
ses <- newMVar Nothing ses <- newMVar Nothing
let c = BWServerConf { timeout = UnixDiffTime (fromIntegral t) 0 } let c = BWServerConf {timeout = UnixDiffTime (fromIntegral t) 0}
startService c ses startService c ses
forever $ threadDelay 1000000 forever $ threadDelay 1000000
@ -66,24 +58,25 @@ syncSession :: BWServerConf -> Session -> IO ()
syncSession conf ses = notify =<< fmap join . mapM cmd =<< getSession' conf ses syncSession conf ses = notify =<< fmap join . mapM cmd =<< getSession' conf ses
where where
cmd h = readCmdSuccess "bw" ["sync", "--session", h] "" cmd h = readCmdSuccess "bw" ["sync", "--session", h] ""
notify res = let j = isJust res notify res =
in notifyStatus j $ if j then "sync succeeded" else "sync failed" let j = isJust res
in notifyStatus j $ if j then "sync succeeded" else "sync failed"
getSession' :: BWServerConf -> Session -> IO (Maybe String) getSession' :: BWServerConf -> Session -> IO (Maybe String)
getSession' BWServerConf { timeout = t } ses = do getSession' BWServerConf {timeout = t} ses = do
ut <- getUnixTime ut <- getUnixTime
modifyMVar ses $ \s -> case s of 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) if diffUnixTime ut ts > t then getNewSession else return (s, Just h)
Nothing -> getNewSession Nothing -> getNewSession
where where
getNewSession = do getNewSession = do
pwd <- readPassword' "Bitwarden Password" pwd <- readPassword' "Bitwarden Password"
newHash <- join <$> mapM readSession pwd newHash <- join <$> mapM readSession pwd
(, newHash) <$> mapM newSession newHash (,newHash) <$> mapM newSession newHash
newSession h = do newSession h = do
ut <- getUnixTime ut <- getUnixTime
return CurrentSession { timestamp = ut, hash = h } return CurrentSession {timestamp = ut, hash = h}
getSession :: BWServerConf -> Session -> IO String getSession :: BWServerConf -> Session -> IO String
getSession conf ses = fromMaybe "" <$> getSession' conf ses getSession conf ses = fromMaybe "" <$> getSession' conf ses
@ -95,11 +88,13 @@ notifyStatus :: Bool -> String -> IO ()
notifyStatus succeeded msg = notifyStatus succeeded msg =
void $ spawnProcess "notify-send" ["-i", i, msg] void $ spawnProcess "notify-send" ["-i", i, msg]
where where
i = if succeeded i =
then "dialog-information-symbolic" if succeeded
else "dialog-error-symbolic" then "dialog-information-symbolic"
else "dialog-error-symbolic"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Client -- | Client
-- --
-- The client will get the current session from the daemon (if it can) and then -- 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 -- - username (if applicable) -> copy to clipboard
-- - password (if applicable) -> copy to clipboard -- - password (if applicable) -> copy to clipboard
-- - anything else (notes and such) -> copy to clipboard -- - anything else (notes and such) -> copy to clipboard
newtype BWClientConf = BWClientConf [String] newtype BWClientConf = BWClientConf [String]
instance RofiConf BWClientConf where instance RofiConf BWClientConf where
@ -123,15 +117,18 @@ instance RofiConf BWClientConf where
runClient :: [String] -> IO () runClient :: [String] -> IO ()
runClient a = do runClient a = do
let c = BWClientConf a let c = BWClientConf a
runRofiIO c $ selectAction $ emptyMenu runRofiIO c $
{ groups = [untitledGroup $ toRofiActions ras] selectAction $
, prompt = Just "Action" emptyMenu
} { groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Action"
}
where where
ras = [ ("Browse Logins", browseLogins) ras =
, ("Sync Session", io callSyncSession) [ ("Browse Logins", browseLogins)
, ("Lock Session", io callLockSession) , ("Sync Session", io callSyncSession)
] , ("Lock Session", io callLockSession)
]
browseLogins :: RofiConf c => RofiIO c () browseLogins :: RofiConf c => RofiIO c ()
browseLogins = io getItems >>= selectItem browseLogins = io getItems >>= selectItem
@ -144,67 +141,74 @@ getItems' session = do
items <- io $ readProcess "bw" ["list", "items", "--session", session] "" items <- io $ readProcess "bw" ["list", "items", "--session", session] ""
return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
where where
notEmpty Item { login = Login { username = Nothing, password = Nothing } } notEmpty Item {login = Login {username = Nothing, password = Nothing}} =
= False False
notEmpty _ = True notEmpty _ = True
data Item = Item data Item = Item
{ name :: String { name :: String
, login :: Login , login :: Login
} }
deriving (Show) deriving (Show)
instance FromJSON Item where instance FromJSON Item where
parseJSON (Object o) = Item parseJSON (Object o) =
<$> o .: "name" Item
<*> o .:? "login" .!= Login { username = Nothing, password = Nothing } <$> o .: "name"
<*> o .:? "login" .!= Login {username = Nothing, password = Nothing}
parseJSON _ = mzero parseJSON _ = mzero
data Login = Login data Login = Login
{ username :: Maybe String { username :: Maybe String
, password :: Maybe String , password :: Maybe String
} }
deriving (Show, Generic) deriving (Show, Generic)
instance FromJSON Login instance FromJSON Login
-- TODO make menu buttons here to go back and to copy without leaving -- TODO make menu buttons here to go back and to copy without leaving
-- the current menu -- the current menu
selectItem :: RofiConf c => [Item] -> RofiIO c () selectItem :: RofiConf c => [Item] -> RofiIO c ()
selectItem items = selectAction $ emptyMenu selectItem items =
{ groups = [untitledGroup $ itemsToRofiActions items] selectAction $
, prompt = Just "Login" emptyMenu
} { groups = [untitledGroup $ itemsToRofiActions items]
, prompt = Just "Login"
}
itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c
itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i)) itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
selectCopy :: RofiConf c => Login -> RofiIO c () selectCopy :: RofiConf c => Login -> RofiIO c ()
selectCopy l = selectAction $ emptyMenu selectCopy l =
{ groups = [untitledGroup $ loginToRofiActions l copy] selectAction $
, prompt = Just "Copy" emptyMenu
, hotkeys = [copyHotkey, backHotkey] { groups = [untitledGroup $ loginToRofiActions l copy]
} , prompt = Just "Copy"
, hotkeys = [copyHotkey, backHotkey]
}
where where
copy = io . setClipboardString copy = io . setClipboardString
copyRepeat s = copy s >> selectCopy l copyRepeat s = copy s >> selectCopy l
copyHotkey = Hotkey copyHotkey =
{ keyCombo = "Alt+c" Hotkey
, keyIndex = 1 { keyCombo = "Alt+c"
, keyDescription = "Copy One" , keyIndex = 1
, keyActions = loginToRofiActions l copyRepeat , keyDescription = "Copy One"
} , keyActions = loginToRofiActions l copyRepeat
backHotkey = Hotkey }
{ keyCombo = "Alt+q" backHotkey =
, keyIndex = 2 Hotkey
, keyDescription = "Back" { keyCombo = "Alt+q"
-- TODO this is overly complicated, all entries do the same thing , keyIndex = 2
-- TODO this is slow, we can cache the logins somehow... , keyDescription = "Back"
, keyActions = loginToRofiActions l (const browseLogins) , -- 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 -> (String -> RofiIO c ()) -> RofiActions c
loginToRofiActions Login { username = u, password = p } a = loginToRofiActions Login {username = u, password = p} a =
toRofiActions $ catMaybes [user, pwd] toRofiActions $ catMaybes [user, pwd]
where where
copyIfJust f = fmap $ liftM2 (,) f a 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] "" getPwd s = readProcess "bw" ["get", "password", item, "--session", s] ""
getItemPassword :: BWServerConf -> Session -> String -> IO String 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 :: BWServerConf -> Session -> IO ()
startService c ses = do startService c ses = do
client <- connectSession client <- connectSession
let flags = [nameAllowReplacement, nameReplaceExisting] let flags = [nameAllowReplacement, nameReplaceExisting]
_ <- requestName client busname flags _ <- requestName client busname flags
putStrLn "Started rofi bitwarden dbus client" TI.putStrLn "Started rofi bitwarden dbus client"
export client path defaultInterface export
{ interfaceName = interface client
, interfaceMethods = path
[ autoMethod memGetSession $ getSession c ses defaultInterface
, autoMethod memLockSession $ lockSession ses { interfaceName = interface
, autoMethod memSyncSession $ syncSession c ses , interfaceMethods =
, autoMethod memGetPassword $ getItemPassword c ses [ autoMethod memGetSession $ getSession c ses
] , autoMethod memLockSession $ lockSession ses
} , autoMethod memSyncSession $ syncSession c ses
, autoMethod memGetPassword $ getItemPassword c ses
]
}
busname :: BusName busname :: BusName
busname = "org.rofi.bitwarden" busname = "org.rofi.bitwarden"
@ -266,7 +274,7 @@ callMember :: MemberName -> IO [Variant]
callMember m = do callMember m = do
reply <- callMethod $ methodCall path interface m reply <- callMethod $ methodCall path interface m
case reply of case reply of
Left err -> putStrLn (methodErrorMessage err) >> return [] Left err -> TI.putStrLn (T.pack (methodErrorMessage err)) >> return []
Right body -> return body Right body -> return body
callLockSession :: IO () callLockSession :: IO ()
@ -283,12 +291,12 @@ callGetSession = getBodyString <$> callMember memGetSession
getBodyString :: [Variant] -> Maybe String getBodyString :: [Variant] -> Maybe String
getBodyString [b] = case fromVariant b :: Maybe String of getBodyString [b] = case fromVariant b :: Maybe String of
Just "" -> Nothing Just "" -> Nothing
s -> s s -> s
getBodyString _ = Nothing getBodyString _ = Nothing
callMethod :: MethodCall -> IO (Either MethodError [Variant]) callMethod :: MethodCall -> IO (Either MethodError [Variant])
callMethod mc = do callMethod mc = do
client <- connectSession client <- connectSession
reply <- call client mc { methodCallDestination = Just busname } reply <- call client mc {methodCallDestination = Just busname}
disconnect client disconnect client
return $ methodReturnBody <$> reply return $ methodReturnBody <$> reply

133
lib/Rofi/Command.hs
View File

@ -1,13 +1,11 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Rofi.Command module Rofi.Command
( RofiConf(..) ( RofiConf (..)
, RofiMenu(..) , RofiMenu (..)
, RofiAction , RofiAction
, RofiActions , RofiActions
, RofiIO , RofiIO
, RofiGroup , RofiGroup
, Hotkey(..) , Hotkey (..)
, io , io
, emptyMenu , emptyMenu
, runRofiIO , runRofiIO
@ -24,18 +22,17 @@ module Rofi.Command
, dmenuArgs , dmenuArgs
, joinNewline , joinNewline
, stripWS , stripWS
) where )
where
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
import Control.Monad.Reader import Control.Monad.Reader
import Data.Char
import Data.Char import qualified Data.Map.Ordered as M
import Data.List import Data.Maybe
import qualified Data.Map.Ordered as M import RIO
import Data.Maybe import qualified RIO.List as L
import System.Process
import System.Exit
import System.Process
class RofiConf c where class RofiConf c where
defArgs :: c -> [String] defArgs :: c -> [String]
@ -45,59 +42,56 @@ type RofiAction c = (String, RofiIO c ())
type RofiActions c = M.OMap String (RofiIO c ()) type RofiActions c = M.OMap String (RofiIO c ())
data RofiGroup c = RofiGroup data RofiGroup c = RofiGroup
{ actions :: RofiActions c { actions :: RofiActions c
, title :: Maybe String , title :: Maybe String
} }
untitledGroup :: RofiActions c -> RofiGroup c 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 :: 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 data Hotkey c = Hotkey
{ keyCombo :: String { keyCombo :: String
-- only 1-10 are valid , -- only 1-10 are valid
, keyIndex :: Int keyIndex :: Int
, keyDescription :: String , keyDescription :: String
, keyActions :: RofiActions c , keyActions :: RofiActions c
} }
hotkeyBinding :: Hotkey c -> [String] hotkeyBinding :: Hotkey c -> [String]
hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c] hotkeyBinding Hotkey {keyIndex = e, keyCombo = c} = [k, c]
where where
k = "-kb-custom-" ++ show e k = "-kb-custom-" ++ show e
hotkeyMsg1 :: Hotkey c -> String hotkeyMsg1 :: Hotkey c -> String
hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } = hotkeyMsg1 Hotkey {keyCombo = c, keyDescription = d} =
c ++ ": <i>" ++ d ++ "</i>" c ++ ": <i>" ++ d ++ "</i>"
hotkeyMsg :: [Hotkey c] -> [String] hotkeyMsg :: [Hotkey c] -> [String]
hotkeyMsg [] = [] hotkeyMsg [] = []
hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs] hotkeyMsg hs = ["-mesg", L.intercalate " | " $ fmap hotkeyMsg1 hs]
hotkeyArgs :: [Hotkey c] -> [String] hotkeyArgs :: [Hotkey c] -> [String]
hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
data RofiMenu c = RofiMenu data RofiMenu c = RofiMenu
{ groups :: [RofiGroup c] { groups :: [RofiGroup c]
, prompt :: Maybe String , prompt :: Maybe String
, hotkeys :: [Hotkey c] , hotkeys :: [Hotkey c]
}
emptyMenu :: RofiMenu c
emptyMenu = RofiMenu
{ groups = []
, prompt = Nothing
, hotkeys = []
} }
newtype RofiIO c a = RofiIO (ReaderT c IO a) emptyMenu :: RofiMenu c
deriving (Functor, Monad, MonadIO, MonadReader c, MonadUnliftIO) emptyMenu =
RofiMenu
{ groups = []
, prompt = Nothing
, hotkeys = []
}
instance Applicative (RofiIO c) where newtype RofiIO c a = RofiIO (ReaderT c IO a)
pure = return deriving (Functor, Applicative, Monad, MonadIO, MonadReader c, MonadUnliftIO)
(<*>) = ap
io :: MonadIO m => IO a -> m a io :: MonadIO m => IO a -> m a
io = liftIO io = liftIO
@ -115,17 +109,17 @@ lookupRofiAction :: String -> RofiActions c -> RofiIO c ()
lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
groupEntries :: RofiGroup c -> String groupEntries :: RofiGroup c -> String
groupEntries RofiGroup { actions = a, title = t } groupEntries RofiGroup {actions = a, title = t}
| null a = "" | null a = ""
| otherwise = title' ++ rofiActionKeys a | otherwise = title' ++ rofiActionKeys a
where where
title' = maybe "" (++ "\n") t title' = maybe "" (++ "\n") t
menuActions :: RofiMenu c -> RofiActions c 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 :: 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 :: RofiConf c => RofiMenu c -> RofiIO c ()
selectAction rm = do selectAction rm = do
@ -133,10 +127,11 @@ selectAction rm = do
let hArgs = hotkeyArgs $ hotkeys rm let hArgs = hotkeyArgs $ hotkeys rm
res <- readRofi (p ++ hArgs) $ menuEntries rm res <- readRofi (p ++ hArgs) $ menuEntries rm
case res of case res of
Right key -> lookupRofiAction key $ menuActions rm Right key -> lookupRofiAction key $ menuActions rm
Left (n, key, _) -> mapM_ (lookupRofiAction key . keyActions) Left (n, key, _) ->
$ find ((==) n . (+ 9) . keyIndex) mapM_ (lookupRofiAction key . keyActions) $
$ hotkeys rm L.find ((==) n . (+ 9) . keyIndex) $
hotkeys rm
maybeOption :: String -> Maybe String -> [String] maybeOption :: String -> Maybe String -> [String]
maybeOption switch = maybe [] (\o -> [switch, o]) maybeOption switch = maybe [] (\o -> [switch, o])
@ -144,7 +139,9 @@ maybeOption switch = maybe [] (\o -> [switch, o])
dmenuArgs :: [String] dmenuArgs :: [String]
dmenuArgs = ["-dmenu"] dmenuArgs = ["-dmenu"]
readRofi :: RofiConf c => [String] readRofi
:: RofiConf c
=> [String]
-> String -> String
-> RofiIO c (Either (Int, String, String) String) -> RofiIO c (Either (Int, String, String) String)
readRofi uargs input = do readRofi uargs input = do
@ -152,36 +149,42 @@ readRofi uargs input = do
io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
readCmdSuccess :: String -> [String] -> String -> IO (Maybe String) readCmdSuccess :: String -> [String] -> String -> IO (Maybe String)
readCmdSuccess cmd args input = either (const Nothing) Just readCmdSuccess cmd args input =
<$> readCmdEither cmd args input either (const Nothing) Just
<$> readCmdEither cmd args input
readCmdEither :: String readCmdEither
:: String
-> [String] -> [String]
-> String -> String
-> IO (Either (Int, String, String) String) -> IO (Either (Int, String, String) String)
readCmdEither cmd args input = resultToEither readCmdEither cmd args input =
<$> readProcessWithExitCode cmd args input resultToEither
<$> readProcessWithExitCode cmd args input
readCmdEither' :: String readCmdEither'
:: String
-> [String] -> [String]
-> String -> String
-> [(String, String)] -> [(String, String)]
-> IO (Either (Int, String, String) String) -> IO (Either (Int, String, String) String)
readCmdEither' cmd args input environ = resultToEither readCmdEither' cmd args input environ =
<$> readCreateProcessWithExitCode p input resultToEither
<$> readCreateProcessWithExitCode p input
where 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 -> 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) resultToEither (ExitFailure n, out, err) = Left (n, stripWS out, stripWS err)
stripWS :: String -> String stripWS :: String -> String
stripWS = reverse . dropWhile isSpace . reverse stripWS = reverse . dropWhile isSpace . reverse
joinNewline :: [String] -> String joinNewline :: [String] -> String
joinNewline = intercalate "\n" joinNewline = L.intercalate "\n"
readPassword :: IO (Maybe String) readPassword :: IO (Maybe String)
readPassword = readPassword' "Password" readPassword = readPassword' "Password"

82
package.yaml
View File

@ -9,15 +9,56 @@ copyright: "2020 Nathan Dwarshuis"
extra-source-files: extra-source-files:
- README.md - 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> 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: dependencies:
- base >= 4.7 && < 5 - base >= 4.7 && < 5
- process >= 1.6.5.0 - process >= 1.6.5.0
@ -42,14 +83,10 @@ dependencies:
- bimap >= 0.2.4 - bimap >= 0.2.4
- dhall >= 1.40.2 - dhall >= 1.40.2
- lens >= 5.0.1 - lens >= 5.0.1
- rio
library: library:
source-dirs: lib/ source-dirs: lib/
ghc-options:
- -Wall
- -Werror
- -threaded
- -Wpartial-fields
exposed-modules: exposed-modules:
- Bitwarden.Internal - Bitwarden.Internal
- Rofi.Command - Rofi.Command
@ -59,10 +96,7 @@ executables:
main: pinentry-rofi.hs main: pinentry-rofi.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
- -Wpartial-fields
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -70,10 +104,7 @@ executables:
main: rofi-autorandr.hs main: rofi-autorandr.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
- -Wpartial-fields
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -81,10 +112,7 @@ executables:
main: rofi-bw.hs main: rofi-bw.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
- -Wpartial-fields
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -92,10 +120,7 @@ executables:
main: rofi-bt.hs main: rofi-bt.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
- -Wpartial-fields
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -103,10 +128,7 @@ executables:
main: rofi-dev.hs main: rofi-dev.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
- -Wpartial-fields
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -114,10 +136,7 @@ executables:
main: rofi-evpn.hs main: rofi-evpn.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
- -Wpartial-fields
dependencies: dependencies:
- rofi-extras - rofi-extras
@ -125,9 +144,6 @@ executables:
main: rofi.hs main: rofi.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:
- -Wall
- -Werror
- -threaded - -threaded
- -Wpartial-fields
dependencies: dependencies:
- rofi-extras - rofi-extras