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

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

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

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

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

69
app/rofi-dev.hs
View File

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

35
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
import Control.Monad
import Data.List (isPrefixOf)
import Data.List.Split
import Data.Maybe
import RIO
import Rofi.Command
import System.Environment
import System.Process
@ -26,7 +23,9 @@ runPrompt args = do
run (VPNStatus connected servers) = do
let d = getDisconnectAction <$> connected
let cs = fmap (getConnectAction connected) servers
runRofiIO (RofiVPNConf args) $ selectAction $ emptyMenu
runRofiIO (RofiVPNConf args) $
selectAction $
emptyMenu
{ groups =
[ untitledGroup $ toRofiActions $ maybeToList d
, untitledGroup $ toRofiActions cs
@ -63,7 +62,7 @@ getConnectedServer = (procStatus =<<) <$> readCmdSuccess eVPN ["status"] ""
procStatus = listToMaybe . mapMaybe procLine . lines
procLine l = case words l of
-- the output is green...
("\ESC[1;32;49mConnected":"to":server) -> Just $ unwords server
("\ESC[1;32;49mConnected" : "to" : server) -> Just $ unwords server
_ -> Nothing
getAvailableServers :: IO [VPNServer]
@ -75,13 +74,15 @@ getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
-- ASSUME the output has a useless header that ends in a line that starts
-- with "-----", after which is the stuff we care about, which is followed
-- by a blank line, after which there is more stuff I don't care about
procOut (Just ls) = return
$ mapMaybe (matchLine . splitOn "\t")
$ takeWhile (/= "")
$ drop 1
procOut (Just ls) =
return $
mapMaybe (matchLine . splitOn "\t") $
takeWhile (/= "") $
drop 1
-- super lame way of matching lines that start with "-----"
$ dropWhile (not . isPrefixOf "-----")
$ lines ls
$
dropWhile (not . isPrefixOf "-----") $
lines ls
-- The output of this command is very strange; it is delimited (kinda) by
-- tabs but some lines are long enough that they don't have a tab. In
-- whatever case, splitting by tabs leads to variable length lists, and the
@ -123,13 +124,17 @@ eVPND = "expressvpnd"
connect :: VPNServer -> IO ()
connect (sid, sname) = do
res <- readCmdSuccess' eVPN ["connect", sid]
notifyIf res ("connected to " ++ sname)
notifyIf
res
("connected to " ++ sname)
("failed to connect to " ++ sname)
disconnect :: String -> IO Bool
disconnect server = do
res <- readCmdSuccess' eVPN ["disconnect"]
notifyIf res ("disconnected from " ++ server)
notifyIf
res
("disconnected from " ++ server)
("failed to disconnect from " ++ server)
return res

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

104
lib/Bitwarden/Internal.hs
View File

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

79
lib/Rofi/Command.hs
View File

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

82
package.yaml
View File

@ -9,15 +9,56 @@ copyright: "2020 Nathan Dwarshuis"
extra-source-files:
- README.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/ndwarshuis/rofi-extras#readme>
default-extensions:
- OverloadedStrings
- FlexibleContexts
- FlexibleInstances
- InstanceSigs
- MultiParamTypeClasses
- EmptyCase
- LambdaCase
- MultiWayIf
- NamedFieldPuns
- TupleSections
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveLift
- DeriveTraversable
- DerivingStrategies
- DeriveDataTypeable
- EmptyDataDecls
- PartialTypeSignatures
- GeneralizedNewtypeDeriving
- StandaloneDeriving
- BangPatterns
- TypeOperators
- ScopedTypeVariables
- TypeApplications
- ConstraintKinds
- RankNTypes
- GADTs
- DefaultSignatures
- NoImplicitPrelude
- FunctionalDependencies
- DataKinds
- TypeFamilies
- BinaryLiterals
- ViewPatterns
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wpartial-fields
- -Werror
- -O2
dependencies:
- base >= 4.7 && < 5
- process >= 1.6.5.0
@ -42,14 +83,10 @@ dependencies:
- bimap >= 0.2.4
- dhall >= 1.40.2
- lens >= 5.0.1
- rio
library:
source-dirs: lib/
ghc-options:
- -Wall
- -Werror
- -threaded
- -Wpartial-fields
exposed-modules:
- Bitwarden.Internal
- Rofi.Command
@ -59,10 +96,7 @@ executables:
main: pinentry-rofi.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
- -Wpartial-fields
dependencies:
- rofi-extras
@ -70,10 +104,7 @@ executables:
main: rofi-autorandr.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
- -Wpartial-fields
dependencies:
- rofi-extras
@ -81,10 +112,7 @@ executables:
main: rofi-bw.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
- -Wpartial-fields
dependencies:
- rofi-extras
@ -92,10 +120,7 @@ executables:
main: rofi-bt.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
- -Wpartial-fields
dependencies:
- rofi-extras
@ -103,10 +128,7 @@ executables:
main: rofi-dev.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
- -Wpartial-fields
dependencies:
- rofi-extras
@ -114,10 +136,7 @@ executables:
main: rofi-evpn.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
- -Wpartial-fields
dependencies:
- rofi-extras
@ -125,9 +144,6 @@ executables:
main: rofi.hs
source-dirs: app
ghc-options:
- -Wall
- -Werror
- -threaded
- -Wpartial-fields
dependencies:
- rofi-extras