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

50
app/pinentry-rofi.hs
View File

@ -1,7 +1,5 @@
{-# 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
@ -9,21 +7,20 @@
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 qualified RIO.Text as T
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.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)
@ -36,7 +33,7 @@ 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,19 +44,16 @@ 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
@ -67,40 +61,38 @@ 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"

28
app/rofi-autorandr.hs
View File

@ -1,20 +1,18 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | 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 qualified RIO.Text as T
import Rofi.Command 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
@ -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 $
selectAction $
emptyMenu
{ groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs] { groups = [mkGroup "Static" staticProfs, mkGroup "Virtual" virtProfs]
, prompt = Just "Select Profile" , 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]

58
app/rofi-bt.hs
View File

@ -1,23 +1,19 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | 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
import Data.List.Split import Data.List.Split
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe
import qualified Data.Text.IO as TI
import DBus import RIO
import DBus.Client import qualified RIO.List as L
import qualified RIO.Text as T
import Rofi.Command import Rofi.Command
import System.Environment import System.Environment
main :: IO () main :: IO ()
@ -33,15 +29,17 @@ 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) $
selectAction $
emptyMenu
{ groups = [untitledGroup $ toRofiActions ras] { groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Select Device" , prompt = Just "Select Device"
} }
@ -56,7 +54,9 @@ 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') ->
Just
( formatDeviceEntry c' n'
, powerAdapterMaybe client >> io (mkAction c') , powerAdapterMaybe client >> io (mkAction c')
) )
_ -> Nothing _ -> Nothing
@ -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"
@ -85,7 +85,7 @@ formatDeviceEntry connected name = unwords [prefix connected, name]
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
@ -127,7 +127,7 @@ pathIsDevice o = case splitPath o of
_ -> 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
@ -135,7 +135,7 @@ 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,14 +145,24 @@ 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) -- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
-- <$> call client (btMethodCall o i m) -- <$> call client (btMethodCall o i m)
getBTProperty :: IsVariant a => Client -> ObjectPath getBTProperty
-> InterfaceName -> MemberName -> IO (Maybe a) :: 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)

27
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
@ -19,30 +17,27 @@
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 Text.Read
import System.Directory
import System.Environment 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 =
TI.putStrLn $
T.pack $
joinNewline
[ "daemon mode: rofi-bw -d TIMEOUT" [ "daemon mode: rofi-bw -d TIMEOUT"
, "client mode: rofi-bw -c [ROFI-ARGS]" , "client mode: rofi-bw -c [ROFI-ARGS]"
] ]
@ -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

33
app/rofi-evpn.hs
View File

@ -1,17 +1,14 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | 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 (isPrefixOf)
import Data.List.Split import Data.List.Split
import Data.Maybe import Data.Maybe
import RIO
import Rofi.Command import Rofi.Command
import System.Environment import System.Environment
import System.Process import System.Process
@ -26,7 +23,9 @@ 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) $
selectAction $
emptyMenu
{ groups = { groups =
[ untitledGroup $ toRofiActions $ maybeToList d [ untitledGroup $ toRofiActions $ maybeToList d
, untitledGroup $ toRofiActions cs , untitledGroup $ toRofiActions cs
@ -75,13 +74,15 @@ getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
-- 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 (/= "") $
drop 1
-- super lame way of matching lines that start with "-----" -- super lame way of matching lines that start with "-----"
$ dropWhile (not . isPrefixOf "-----") $
$ 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
@ -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

24
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,13 +21,14 @@ 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 Data.Maybe
import Graphics.X11.Types import Graphics.X11.Types
import Graphics.X11.Xlib import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import Graphics.X11.Xrandr import Graphics.X11.Xrandr
import RIO hiding (Display)
import System.Environment import System.Environment
import System.Process import System.Process
@ -64,21 +63,28 @@ getDesktopViewports dpy root =
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
r
( Just
XRROutputInfo
{ xrr_oi_connection = 0
, xrr_oi_name = n , xrr_oi_name = n
, xrr_oi_crtc = c , xrr_oi_crtc = c
}) = do }
) = do
fmap (\i -> (toCoord i, n)) <$> xrrGetCrtcInfo dpy r c 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

84
lib/Bitwarden/Internal.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Bitwarden.Internal module Bitwarden.Internal
( Item (..) ( Item (..)
, Login (..) , Login (..)
@ -10,27 +6,24 @@ module Bitwarden.Internal
, runClient , runClient
, getItems , getItems
, callGetSession , 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
import DBus.Client import DBus.Client
import Data.Aeson
import Data.String
import qualified Data.Text.IO as TI
import Data.UnixTime
import GHC.Generics import GHC.Generics
import RIO hiding (timeout)
import qualified RIO.Text as T
import Rofi.Command import Rofi.Command
import System.Clipboard import System.Clipboard
import System.Process 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,7 +32,6 @@ 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
} }
@ -66,7 +58,8 @@ 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 =
let j = isJust res
in notifyStatus j $ if j then "sync succeeded" else "sync failed" in notifyStatus j $ if j then "sync succeeded" else "sync failed"
getSession' :: BWServerConf -> Session -> IO (Maybe String) getSession' :: BWServerConf -> Session -> IO (Maybe String)
@ -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 =
if succeeded
then "dialog-information-symbolic" then "dialog-information-symbolic"
else "dialog-error-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,12 +117,15 @@ 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 $
selectAction $
emptyMenu
{ groups = [untitledGroup $ toRofiActions ras] { groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Action" , prompt = Just "Action"
} }
where where
ras = [ ("Browse Logins", browseLogins) ras =
[ ("Browse Logins", browseLogins)
, ("Sync Session", io callSyncSession) , ("Sync Session", io callSyncSession)
, ("Lock Session", io callLockSession) , ("Lock Session", io callLockSession)
] ]
@ -144,8 +141,8 @@ 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
@ -155,7 +152,8 @@ data Item = Item
deriving (Show) deriving (Show)
instance FromJSON Item where instance FromJSON Item where
parseJSON (Object o) = Item parseJSON (Object o) =
Item
<$> o .: "name" <$> o .: "name"
<*> o .:? "login" .!= Login {username = Nothing, password = Nothing} <*> o .:? "login" .!= Login {username = Nothing, password = Nothing}
parseJSON _ = mzero parseJSON _ = mzero
@ -171,7 +169,9 @@ 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 =
selectAction $
emptyMenu
{ groups = [untitledGroup $ itemsToRofiActions items] { groups = [untitledGroup $ itemsToRofiActions items]
, prompt = Just "Login" , prompt = Just "Login"
} }
@ -180,7 +180,9 @@ 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 =
selectAction $
emptyMenu
{ groups = [untitledGroup $ loginToRofiActions l copy] { groups = [untitledGroup $ loginToRofiActions l copy]
, prompt = Just "Copy" , prompt = Just "Copy"
, hotkeys = [copyHotkey, backHotkey] , hotkeys = [copyHotkey, backHotkey]
@ -188,22 +190,24 @@ selectCopy l = selectAction $ emptyMenu
where where
copy = io . setClipboardString copy = io . setClipboardString
copyRepeat s = copy s >> selectCopy l copyRepeat s = copy s >> selectCopy l
copyHotkey = Hotkey copyHotkey =
Hotkey
{ keyCombo = "Alt+c" { keyCombo = "Alt+c"
, keyIndex = 1 , keyIndex = 1
, keyDescription = "Copy One" , keyDescription = "Copy One"
, keyActions = loginToRofiActions l copyRepeat , keyActions = loginToRofiActions l copyRepeat
} }
backHotkey = Hotkey backHotkey =
Hotkey
{ keyCombo = "Alt+q" { keyCombo = "Alt+q"
, keyIndex = 2 , keyIndex = 2
, keyDescription = "Back" , keyDescription = "Back"
-- TODO this is overly complicated, all entries do the same thing , -- TODO this is overly complicated, all entries do the same thing
-- TODO this is slow, we can cache the logins somehow... -- TODO this is slow, we can cache the logins somehow...
, keyActions = loginToRofiActions l (const browseLogins) 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
@ -219,19 +223,23 @@ 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
client
path
defaultInterface
{ interfaceName = interface { interfaceName = interface
, interfaceMethods = , interfaceMethods =
[ autoMethod memGetSession $ getSession c ses [ autoMethod memGetSession $ getSession c ses
@ -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 ()

61
lib/Rofi/Command.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Rofi.Command module Rofi.Command
( RofiConf (..) ( RofiConf (..)
, RofiMenu (..) , RofiMenu (..)
@ -24,17 +22,16 @@ 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 Data.List
import qualified Data.Map.Ordered as M import qualified Data.Map.Ordered as M
import Data.Maybe import Data.Maybe
import RIO
import System.Exit import qualified RIO.List as L
import System.Process import System.Process
class RofiConf c where class RofiConf c where
@ -57,8 +54,8 @@ 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
} }
@ -74,7 +71,7 @@ hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } =
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
@ -86,18 +83,15 @@ data RofiMenu c = RofiMenu
} }
emptyMenu :: RofiMenu c emptyMenu :: RofiMenu c
emptyMenu = RofiMenu emptyMenu =
RofiMenu
{ groups = [] { groups = []
, prompt = Nothing , prompt = Nothing
, hotkeys = [] , hotkeys = []
} }
newtype RofiIO c a = RofiIO (ReaderT c IO a) newtype RofiIO c a = RofiIO (ReaderT c IO a)
deriving (Functor, Monad, MonadIO, MonadReader c, MonadUnliftIO) deriving (Functor, Applicative, Monad, MonadIO, MonadReader c, MonadUnliftIO)
instance Applicative (RofiIO c) where
pure = return
(<*>) = ap
io :: MonadIO m => IO a -> m a io :: MonadIO m => IO a -> m a
io = liftIO io = liftIO
@ -122,10 +116,10 @@ groupEntries RofiGroup { actions = a, title = t }
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
@ -134,9 +128,10 @@ selectAction rm = do
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,27 +149,33 @@ 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 =
either (const Nothing) Just
<$> readCmdEither cmd args input <$> 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 =
resultToEither
<$> readProcessWithExitCode cmd args input <$> 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 =
resultToEither
<$> readCreateProcessWithExitCode p input <$> 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)
@ -181,7 +184,7 @@ 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