REF use text everywhere

This commit is contained in:
Nathan Dwarshuis 2023-02-13 23:31:50 -05:00
parent 4265a5947c
commit 09ce10a942
9 changed files with 261 additions and 259 deletions

View File

@ -23,7 +23,7 @@ main = do
TI.putStrLn "OK Pleased to meet you"
pinentryLoop =<< readPinConf
newtype PinConf = PinConf {pcBwName :: String} deriving (Eq, Show)
newtype PinConf = PinConf {pcBwName :: T.Text} deriving (Eq, Show)
instance FromJSON PinConf where
parseJSON (Object o) = PinConf <$> o .:? "bitwarden-name" .!= "gnupg"
@ -72,7 +72,7 @@ unknownCommand c = TI.putStrLn $ T.append "ERR 275 Unknown command " c
getPin :: PinConf -> IO ()
getPin p = do
its <- getItems
let w = (fmap T.pack . password . login) =<< L.find (\i -> pcBwName p == name i) its
let w = (password . login) =<< L.find (\i -> pcBwName p == name i) its
maybe err send w
where
err = TI.putStrLn "ERR 83886179 Operation canceled <rofi>"

View File

@ -30,14 +30,14 @@ checkExe cmd = do
TI.putStrLn $ T.append "Could not find executable: " $ T.pack cmd
exitWith $ ExitFailure 1
newtype ARClientConf = ARClientConf [String]
newtype ARClientConf = ARClientConf [T.Text]
instance RofiConf ARClientConf where
defArgs (ARClientConf a) = a
runPrompt :: [String] -> IO ()
runPrompt a = do
let c = ARClientConf a
let c = ARClientConf $ fmap T.pack a
staticProfs <- getAutoRandrProfiles
runRofiIO c $
selectAction $
@ -49,19 +49,19 @@ runPrompt a = do
mkGroup header =
titledGroup header
. toRofiActions
. fmap (\s -> (" " ++ s, selectProfile $ T.pack s))
. fmap (\s -> (T.append " " s, selectProfile s))
virtProfs :: [String]
virtProfs :: [T.Text]
virtProfs = ["off", "common", "clone-largest", "horizontal", "vertical"]
-- TODO filter profiles based on which xrandr outputs are actually connected
getAutoRandrProfiles :: IO [String]
getAutoRandrProfiles :: IO [T.Text]
getAutoRandrProfiles = do
dir <- getAutoRandrDir
contents <- listDirectory dir
filterM (doesDirectoryExist . (dir </>)) contents
(fmap T.pack) <$> filterM (doesDirectoryExist . (dir </>)) contents
getAutoRandrDir :: IO String
getAutoRandrDir :: IO FilePath
getAutoRandrDir = do
c <- getXdgDirectory XdgConfig "autorandr"
e <- doesDirectoryExist c
@ -70,6 +70,6 @@ getAutoRandrDir = do
appendToHome p = (</> p) <$> getHomeDirectory
selectProfile :: T.Text -> RofiIO ARClientConf ()
selectProfile name = do
io $ TI.putStrLn name
io $ void $ spawnProcess "autorandr" ["--change", T.unpack name]
selectProfile name = liftIO $ do
TI.putStrLn name
void $ spawnProcess "autorandr" ["--change", T.unpack name]

View File

@ -6,7 +6,6 @@ module Main (main) where
import DBus
import DBus.Client
import Data.List.Split
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text.IO as TI
@ -19,7 +18,7 @@ import System.Environment
main :: IO ()
main = getArgs >>= runPrompt
data RofiBTConf = RofiBTConf [String] ObjectPath
data RofiBTConf = RofiBTConf [T.Text] ObjectPath
instance RofiConf RofiBTConf where
defArgs (RofiBTConf as _) = as
@ -37,7 +36,7 @@ runPrompt args = do
getAdapter paths
actions client paths adapter = do
ras <- getRofiActions client paths
runRofiIO (RofiBTConf args adapter) $
runRofiIO (RofiBTConf (fmap T.pack args) adapter) $
selectAction $
emptyMenu
{ groups = [untitledGroup $ toRofiActions ras]
@ -78,8 +77,8 @@ powerAdapterMaybe client = do
-- the 'Set' method
value = toVariant $ toVariant True
formatDeviceEntry :: Bool -> String -> String
formatDeviceEntry connected name = unwords [prefix connected, name]
formatDeviceEntry :: Bool -> T.Text -> T.Text
formatDeviceEntry connected name = T.unwords [prefix connected, name]
where
prefix True = "#"
prefix False = " "
@ -90,7 +89,7 @@ getAdapter = L.find pathIsAdaptor
getDevices :: Client -> [ObjectPath] -> IO [ObjectPath]
getDevices client = filterM (getDevicePaired client) . filter pathIsDevice
type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant))
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
getObjectTree :: Client -> IO ObjectTree
getObjectTree client =
@ -104,7 +103,7 @@ getObjectTree client =
getDeviceConnected :: Client -> ObjectPath -> IO (Maybe Bool)
getDeviceConnected = getDevProperty "Connected"
getDeviceName :: Client -> ObjectPath -> IO (Maybe String)
getDeviceName :: Client -> ObjectPath -> IO (Maybe T.Text)
getDeviceName = getDevProperty "Name"
getDevicePaired :: Client -> ObjectPath -> IO Bool
@ -126,24 +125,24 @@ pathIsDevice o = case splitPath o of
[a, b, c, _] -> pathIsAdaptorPrefix a b c
_ -> False
pathIsAdaptorPrefix :: String -> String -> String -> Bool
pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `L.isPrefixOf` c
pathIsAdaptorPrefix :: T.Text -> T.Text -> T.Text -> Bool
pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `T.isPrefixOf` c
splitPath :: ObjectPath -> [String]
splitPath = splitOn "/" . dropWhile (== '/') . formatObjectPath
splitPath :: ObjectPath -> [T.Text]
splitPath = T.split (== '/') . T.dropWhile (== '/') . T.pack . formatObjectPath
getClient :: IO (Maybe Client)
getClient = either warn (return . Just) =<< try connectSystem
where
warn e = TI.putStrLn (T.pack $ clientErrorMessage e) >> return Nothing
callDevMethod :: String -> Client -> ObjectPath -> IO ()
callDevMethod :: T.Text -> Client -> ObjectPath -> IO ()
callDevMethod mem client dev =
void $ callBTMethod client dev btDevInterface $ memberName_ mem
void $ callBTMethod client dev btDevInterface $ memberName_ $ T.unpack mem
getDevProperty :: IsVariant a => String -> Client -> ObjectPath -> IO (Maybe a)
getDevProperty :: IsVariant a => T.Text -> Client -> ObjectPath -> IO (Maybe a)
getDevProperty mem client dev =
getBTProperty client dev btDevInterface $ memberName_ mem
getBTProperty client dev btDevInterface $ memberName_ $ T.unpack mem
callBTMethod
:: Client

View File

@ -30,13 +30,12 @@ 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 ("-c" : args) = runClient $ fmap T.pack args
parse _ = usage
usage :: IO ()
usage =
TI.putStrLn $
T.pack $
joinNewline
[ "daemon mode: rofi-bw -d TIMEOUT"
, "client mode: rofi-bw -c [ROFI-ARGS]"

View File

@ -11,7 +11,6 @@
module Main (main) where
import Bitwarden.Internal
import Data.List.Split (splitOn)
import qualified Data.Text.IO as TI
import Data.Typeable
import Dhall hiding (maybe, sequence, void)
@ -29,14 +28,13 @@ import System.Environment
import System.FilePath.Posix
import System.Posix.User (getEffectiveUserName)
import System.Process
import Text.Printf
main :: IO ()
main = getArgs >>= parse
parse :: [String] -> IO ()
parse args = case getOpt Permute options args of
(o, n, []) -> runMounts $ L.foldl (flip id) (defaultOpts n) o
(o, n, []) -> runMounts $ L.foldl (flip id) (defaultOpts (fmap T.pack n)) o
(_, _, errs) -> TI.putStrLn $ T.pack $ concat errs ++ usageInfo h options
where
h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
@ -58,7 +56,7 @@ options =
, Option
['m']
["mount"]
(ReqArg (\s m -> m {optsAlias = Just s}) "ALIAS")
(ReqArg (\s m -> m {optsAlias = Just $ T.pack s}) "ALIAS")
"Mount the device specified by ALIAS directly"
, Option
['u']
@ -69,9 +67,9 @@ options =
data Opts = Opts
{ optsConfig :: Maybe FilePath
, optsAlias :: Maybe String
, optsAlias :: Maybe T.Text
, optsUnmount :: Bool
, optsRofiArgs :: [String]
, optsRofiArgs :: [T.Text]
}
deriving (Show)
@ -163,31 +161,31 @@ dismountAll = do
umount :: Mountable a => [a] -> RofiMountIO ()
umount = mapM_ (`mountMaybe` True)
mountByAlias :: Bool -> String -> RofiMountIO ()
mountByAlias :: Bool -> T.Text -> RofiMountIO ()
mountByAlias unmountFlag alias = do
static <- asks mountconfStaticDevs
mapM_ (`mountMaybe` unmountFlag) $ configToTree static <$> M.lookup alias static
mkGroup :: [(Header, ProtoAction [String])] -> Maybe (RofiGroup MountConf)
mkGroup :: [(Header, ProtoAction [T.Text])] -> Maybe (RofiGroup MountConf)
mkGroup [] = Nothing
mkGroup as =
let ((h, _) : _) = as
in Just $ titledGroup (show h) $ toRofiActions $ alignEntries $ fmap snd as
in Just $ titledGroup (T.pack $ show h) $ toRofiActions $ alignEntries $ fmap snd as
alignSep :: String
alignSep :: T.Text
alignSep = " | "
alignEntries :: [ProtoAction [String]] -> [(String, RofiMountIO ())]
alignEntries :: [ProtoAction [T.Text]] -> [(T.Text, RofiMountIO ())]
alignEntries ps = zip (align es) as
where
(es, as) = L.unzip $ fmap (\(ProtoAction e a) -> (e, a)) ps
align =
fmap (L.intercalate alignSep)
fmap (T.intercalate alignSep)
. L.transpose
. mapToLast pad
. L.transpose
pad xs = let m = getMax xs in fmap (\x -> take m (x ++ L.repeat ' ')) xs
getMax = LP.maximum . fmap length
pad xs = let m = getMax xs in fmap (\x -> T.append x (T.replicate (m - T.length x) " ")) xs
getMax = LP.maximum . fmap T.length
mapToLast _ [] = []
mapToLast _ [x] = [x]
mapToLast f (x : xs) = f x : mapToLast f xs
@ -197,8 +195,8 @@ alignEntries ps = zip (align es) as
data MountConf = MountConf
{ mountconfVolatilePath :: FilePath
, mountconfRofiArgs :: [String]
, mountconfStaticDevs :: M.Map String TreeConfig
, mountconfRofiArgs :: [T.Text]
, mountconfStaticDevs :: M.Map T.Text TreeConfig
, mountconfVerbose :: Bool
}
deriving (Show)
@ -229,13 +227,13 @@ class Mountable a where
then (io . notifyMountResult mounted (getLabel dev)) =<< mount dev mountFlag
else when verbose notify'
where
notify' = io $ notify IconInfo (getLabel dev ++ " already mounted") Nothing
notify' = io $ notify IconInfo (T.append (getLabel dev) " already mounted") Nothing
-- | Check if the mounting utilities are present
allInstalled :: a -> RofiMountIO Bool
-- | Return a string representing the label of the device
getLabel :: a -> String
getLabel :: a -> T.Text
-- | Determine if the given type is mounted or not
isMounted :: a -> RofiMountIO Bool
@ -254,21 +252,21 @@ class Mountable a where
class Mountable a => Actionable a where
-- | Return a string to go in the Rofi menu for the given type
fmtEntry :: a -> [String]
fmtEntry :: a -> [T.Text]
fmtEntry d = [getLabel d]
groupHeader :: a -> Header
-- | Given a mountable type, return a rofi action (string to go in the
-- Rofi prompt and an action to perform when it is selected)
mkAction :: a -> RofiMountIO (Header, ProtoAction [String])
mkAction :: a -> RofiMountIO (Header, ProtoAction [T.Text])
mkAction dev = do
m <- mountState dev
i <- allInstalled dev
let h = groupHeader dev
let action = when i $ mountMaybe dev $ mountedState m
let entry = case fmtEntry dev of
(e : es) -> (mountedPrefix m i ++ e) : es
(e : es) -> (T.append (mountedPrefix m i) e) : es
_ -> []
return (h, ProtoAction entry action)
where
@ -280,7 +278,7 @@ class Mountable a => Actionable a where
mountableToAction
:: Actionable a
=> RofiMountIO [a]
-> RofiMountIO [(Header, ProtoAction [String])]
-> RofiMountIO [(Header, ProtoAction [T.Text])]
mountableToAction ms = mapM mkAction =<< ms
type RofiMountIO a = RofiIO MountConf a
@ -314,18 +312,18 @@ data ProtoAction a = ProtoAction a (RofiMountIO ())
data MountConfig = MountConfig
{ mpPath :: FilePath
, mpLabel :: Maybe String
, mpLabel :: Maybe T.Text
}
deriving (Show, Generic, FromDhall)
data BitwardenConfig = BitwardenConfig
{ bwKey :: String
{ bwKey :: T.Text
, bwTries :: Integer
}
deriving (Show, Generic, FromDhall)
newtype SecretConfig = SecretConfig
{secretAttributes :: M.Map String String}
{secretAttributes :: M.Map T.Text T.Text}
deriving (Show, Generic, FromDhall)
newtype PromptConfig = PromptConfig
@ -339,11 +337,11 @@ data PasswordConfig
deriving (Show, Generic, FromDhall)
data CIFSOpts = CIFSOpts
{ cifsoptsUsername :: Maybe String
, cifsoptsWorkgroup :: Maybe String
{ cifsoptsUsername :: Maybe T.Text
, cifsoptsWorkgroup :: Maybe T.Text
, cifsoptsUID :: Maybe Integer
, cifsoptsGID :: Maybe Integer
, cifsoptsIocharset :: Maybe String
, cifsoptsIocharset :: Maybe T.Text
}
deriving (Show, Generic, FromDhall)
@ -354,19 +352,19 @@ data DataConfig
deriving (Show, Generic, FromDhall)
data VeracryptData = VeracryptData
{ vcVolume :: String
{ vcVolume :: T.Text
, vcPassword :: Maybe PasswordConfig
}
deriving (Show, Generic, FromDhall)
data SSHFSData = SSHFSData
{ sshfsRemote :: String
{ sshfsRemote :: T.Text
, sshfsPassword :: Maybe PasswordConfig
}
deriving (Show, Generic, FromDhall)
data CIFSData = CIFSData
{ cifsRemote :: String
{ cifsRemote :: T.Text
, cifsSudo :: Bool
, cifsPassword :: Maybe PasswordConfig
, cifsOpts :: Maybe CIFSOpts
@ -381,14 +379,14 @@ data DeviceConfig = DeviceConfig
data TreeConfig = TreeConfig
{ tcParent :: DeviceConfig
, tcChildren :: V.Vector String
, tcChildren :: V.Vector T.Text
}
deriving (Show, Generic, FromDhall)
data StaticConfig = StaticConfig
{ scTmpPath :: Maybe String
{ scTmpPath :: Maybe FilePath
, scVerbose :: Maybe Bool
, scDevices :: M.Map String TreeConfig
, scDevices :: M.Map T.Text TreeConfig
}
deriving (Show, Generic, FromDhall)
@ -430,10 +428,10 @@ instance Actionable (Tree DeviceConfig) where
SSHFSConfig {} -> SSHFSHeader
VeracryptConfig {} -> VeracryptHeader
configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
configToTree' :: M.Map T.Text TreeConfig -> [StaticConfigTree]
configToTree' devMap = configToTree devMap <$> M.elems devMap
configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree
configToTree :: M.Map T.Text TreeConfig -> TreeConfig -> StaticConfigTree
configToTree devMap TreeConfig {tcParent = p, tcChildren = c} =
Tree p $ fmap go V.toList c
where
@ -476,9 +474,9 @@ instance Mountable DeviceConfig where
mount DeviceConfig {deviceMount = m, deviceData = d} True = do
m' <- getAbsMountpoint m
runAndRemoveDir m' $ io $ case d of
CIFSConfig (CIFSData {cifsSudo = s}) -> runMountSudoMaybe s "umount" [m']
VeracryptConfig _ -> runVeraCrypt ["-d", m'] ""
_ -> runMount "umount" [m'] ""
CIFSConfig (CIFSData {cifsSudo = s}) -> runMountSudoMaybe s "umount" [T.pack m']
VeracryptConfig _ -> runVeraCrypt ["-d", T.pack m'] ""
_ -> runMount "umount" [T.pack m'] ""
allInstalled DeviceConfig {deviceData = devData} =
io $
@ -500,17 +498,17 @@ instance Mountable DeviceConfig where
getLabel
DeviceConfig
{ deviceMount = MountConfig {mpPath = p, mpLabel = l}
} = fromMaybe (takeFileName p) l
} = fromMaybe (T.pack $ takeFileName p) l
mountSSHFS :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
mountSSHFS :: FilePath -> Maybe PasswordConfig -> T.Text -> IO MountResult
mountSSHFS mountpoint pwdConfig remote =
withPasswordGetter pwdConfig (run ["-o", "password_stdin"]) $ run [] ""
where
run other = runMount "sshfs" (other ++ [remote, mountpoint])
run other = runMount "sshfs" (other ++ [remote, T.pack mountpoint])
mountCIFS
:: Bool
-> String
-> T.Text
-> FilePath
-> Maybe CIFSOpts
-> Maybe PasswordConfig
@ -520,30 +518,30 @@ mountCIFS useSudo remote mountpoint opts pwdConfig =
where
run = runMountSudoMaybe useSudo "mount.cifs" args
runPwd p = runMountSudoMaybe' useSudo "mount.cifs" args [("PASSWD", p)]
args = [remote, mountpoint] ++ maybe [] (\o -> ["-o", fromCIFSOpts o]) opts
args = [remote, T.pack mountpoint] ++ maybe [] (\o -> ["-o", fromCIFSOpts o]) opts
fromCIFSOpts :: CIFSOpts -> String
fromCIFSOpts o = L.intercalate "," $ mapMaybe concatMaybe fs
fromCIFSOpts :: CIFSOpts -> T.Text
fromCIFSOpts o = T.intercalate "," $ mapMaybe concatMaybe fs
where
fs =
[ ("username", cifsoptsUsername)
, ("workgroup", cifsoptsWorkgroup)
, ("uid", fmap show . cifsoptsUID)
, ("gid", fmap show . cifsoptsGID)
, ("uid", fmap (T.pack . show) . cifsoptsUID)
, ("gid", fmap (T.pack . show) . cifsoptsGID)
, ("iocharset", cifsoptsIocharset)
]
concatMaybe (k, f) = (\v -> k ++ "=" ++ v) <$> f o
concatMaybe (k, f) = (\v -> T.concat [k, "=", v]) <$> f o
mountVeracrypt :: FilePath -> Maybe PasswordConfig -> String -> IO MountResult
mountVeracrypt :: FilePath -> Maybe PasswordConfig -> T.Text -> IO MountResult
mountVeracrypt mountpoint pwdConfig volume =
withPasswordGetter pwdConfig (runVeraCrypt (args ++ ["--stdin"])) $
runVeraCrypt args ""
where
args = [volume, mountpoint]
args = [volume, T.pack mountpoint]
-- NOTE: the user is assumed to have added themselves to the sudoers file so
-- that this command will work
runVeraCrypt :: [String] -> String -> IO MountResult
runVeraCrypt :: [T.Text] -> T.Text -> IO MountResult
runVeraCrypt args = runMount "sudo" (defaultArgs ++ args)
where
defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]
@ -560,29 +558,29 @@ veracryptMountState mc = do
where
-- TODO don't hardcode the tmp directory
auxPath = fmap (\i -> "/tmp/.veracrypt_aux_mnt" ++ [i]) . vcIndex
vcIndex spec = case reverse spec of
vcIndex spec = case T.uncons $ T.reverse spec of
-- TODO what if I have more than one digit?
(i : _) -> if i `elem` ['0' .. '9'] then Just i else Nothing
Just (i, _) -> if i `elem` ['0' .. '9'] then Just i else Nothing
_ -> Nothing
getAbsMountpoint :: MountConfig -> RofiMountIO FilePath
getAbsMountpoint MountConfig {mpPath = m} =
asks $ flip appendRoot m . mountconfVolatilePath
getStaticActions :: RofiMountIO [(Header, ProtoAction [String])]
getStaticActions :: RofiMountIO [(Header, ProtoAction [T.Text])]
getStaticActions = mountableToAction $ asks $ configToTree' . mountconfStaticDevs
--------------------------------------------------------------------------------
-- Password-getting functions for static devices
type PasswordGetter = IO (Maybe String)
type PasswordGetter = IO (Maybe T.Text)
runSecret :: M.Map String String -> PasswordGetter
runSecret :: M.Map T.Text T.Text -> PasswordGetter
runSecret kvs = readCmdSuccess "secret-tool" ("lookup" : kvs') ""
where
kvs' = concatMap (\(k, v) -> [k, v]) $ M.toList kvs
runBitwarden :: String -> PasswordGetter
runBitwarden :: T.Text -> PasswordGetter
runBitwarden pname =
((password . login) <=< L.find (\i -> name i == pname))
<$> getItems
@ -617,7 +615,7 @@ configToPwd (PwdPr p) = flip runPromptLoop readPassword $ promptTries p
withPasswordGetter
:: Maybe PasswordConfig
-> (String -> IO MountResult)
-> (T.Text -> IO MountResult)
-> IO MountResult
-> IO MountResult
withPasswordGetter (Just pwdConfig) runPwd _ =
@ -633,8 +631,8 @@ withPasswordGetter Nothing _ run = run
-- addresses (eg in /dev) and labels.
data Removable = Removable
{ removablePath :: String
, removableLabel :: String
{ removablePath :: T.Text
, removableLabel :: T.Text
}
deriving (Eq, Show)
@ -664,42 +662,42 @@ instance Actionable Removable where
-- the device
getRemovableDevices :: RofiIO c [Removable]
getRemovableDevices =
fromLines toDev . lines
fromLines toDev . T.lines . T.pack
<$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "")
where
columns = "FSTYPE,HOTPLUG,PATH,LABEL,SIZE"
-- can't use 'words' here since it will drop spaces in the front
toDev line = case splitBy ' ' line of
toDev line = case T.split (== ' ') line of
("" : _) -> Nothing
[_, "1", d, "", s] -> mk d $ s ++ " Volume"
[_, "1", d, "", s] -> mk d $ T.append s " Volume"
[_, "1", d, l, _] -> mk d l
_ -> Nothing
mk d l = Just $ Removable {removablePath = d, removableLabel = l}
getRemovableActions :: RofiMountIO [(Header, ProtoAction [String])]
getRemovableActions :: RofiMountIO [(Header, ProtoAction [T.Text])]
getRemovableActions = mountableToAction getRemovableDevices
--------------------------------------------------------------------------------
-- MTP devices
mtpExe :: String
mtpExe :: FilePath
mtpExe = "jmtpfs"
data MTPFS = MTPFS
{ mtpfsBus :: String
, mtpfsDevice :: String
{ mtpfsBus :: T.Text
, mtpfsDevice :: T.Text
, mtpfsMountpoint :: FilePath
, mtpfsDescription :: String
, mtpfsDescription :: T.Text
}
deriving (Eq, Show)
instance Mountable MTPFS where
mount MTPFS {mtpfsBus = b, mtpfsDevice = n, mtpfsMountpoint = m} False = do
-- TODO add autodismount to options
let dev = "-device=" ++ b ++ "," ++ n
withTmpMountDir m $ io $ runMount mtpExe [dev, m] ""
let dev = T.concat ["-device=", b, ",", n]
withTmpMountDir m $ io $ runMount (T.pack mtpExe) [dev, T.pack m] ""
mount MTPFS {mtpfsMountpoint = m} True =
runAndRemoveDir m $ io $ runMount "umount" [m] ""
runAndRemoveDir m $ io $ runMount "umount" [T.pack m] ""
-- \| return True always since the list won't even show without jmtpfs
allInstalled _ = return True
@ -719,30 +717,30 @@ getMTPDevices = do
go = do
dir <- asks mountconfVolatilePath
res <- io $ readProcess mtpExe ["-l"] ""
return $ fromLines (toDev dir) $ toDevList res
return $ fromLines (toDev dir) $ toDevList $ T.pack res
toDevList =
reverse
. takeWhile (not . L.isPrefixOf "Available devices")
. reverse
. lines
toDev dir s = case splitOn ", " s of
. L.takeWhile (not . T.isPrefixOf "Available devices")
. L.reverse
. T.lines
toDev dir s = case L.filter (== " ") $ T.split (== ',') s of
[busNum, devNum, _, _, desc, vendor] ->
let d = unwords [vendor, desc]
let d = T.unwords [vendor, desc]
in Just $
MTPFS
{ mtpfsBus = busNum
, mtpfsDevice = devNum
, mtpfsMountpoint = dir </> canonicalize d
, mtpfsMountpoint = dir </> canonicalize (T.unpack d)
, mtpfsDescription = d
}
_ -> Nothing
canonicalize = mapMaybe repl
repl c
| c `elem` ("\"*/:<>?\\|" :: String) = Nothing
| c `elem` ("\"*/:<>?\\|" :: [Char]) = Nothing
| c == ' ' = Just '-'
| otherwise = Just c
getMTPActions :: RofiMountIO [(Header, ProtoAction [String])]
getMTPActions :: RofiMountIO [(Header, ProtoAction [T.Text])]
getMTPActions = mountableToAction getMTPDevices
mtpExeInstalled :: IO Bool
@ -762,39 +760,40 @@ instance Show NotifyIcon where
show IconError = "dialog-error-symbolic"
show IconInfo = "dialog-information-symbolic"
notifyMountResult :: Bool -> String -> MountResult -> IO ()
notifyMountResult :: Bool -> T.Text -> MountResult -> IO ()
notifyMountResult mounted label result = case result of
MountError e -> notify IconError (printf "Failed to %s %s" verb label) $ Just e
MountSuccess -> notify IconInfo (printf "Successfully %sed %s" verb label) Nothing
MountError e -> notify IconError (T.unwords ["Failed", "to", verb, label]) $ Just e
MountSuccess -> notify IconInfo (T.concat ["Successfully ", verb, "ed ", label]) Nothing
where
verb = if mounted then "unmount" else "mount" :: String
verb = if mounted then "unmount" else "mount" :: T.Text
notify :: NotifyIcon -> String -> Maybe String -> IO ()
notify :: NotifyIcon -> T.Text -> Maybe T.Text -> IO ()
notify icon summary body =
void $
spawnProcess "notify-send" $
maybe args (\b -> args ++ [b]) body
maybe args (\b -> args ++ [b]) $
fmap T.unpack body
where
args = ["-i", show icon, summary]
args = ["-i", show icon, T.unpack summary]
--------------------------------------------------------------------------------
-- Mount commands
data MountResult = MountSuccess | MountError String deriving (Show, Eq)
data MountResult = MountSuccess | MountError T.Text deriving (Show, Eq)
runMount :: String -> [String] -> String -> IO MountResult
runMount :: T.Text -> [T.Text] -> T.Text -> IO MountResult
runMount cmd args stdin_ = eitherToMountResult <$> readCmdEither cmd args stdin_
runMount' :: String -> [String] -> String -> [(String, String)] -> IO MountResult
runMount' :: T.Text -> [T.Text] -> T.Text -> [(T.Text, T.Text)] -> IO MountResult
runMount' cmd args stdin_ environ =
eitherToMountResult
<$> readCmdEither' cmd args stdin_ environ
runMountSudoMaybe :: Bool -> String -> [String] -> IO MountResult
runMountSudoMaybe :: Bool -> T.Text -> [T.Text] -> IO MountResult
runMountSudoMaybe useSudo cmd args =
runMountSudoMaybe' useSudo cmd args []
runMountSudoMaybe' :: Bool -> String -> [String] -> [(String, String)] -> IO MountResult
runMountSudoMaybe' :: Bool -> T.Text -> [T.Text] -> [(T.Text, T.Text)] -> IO MountResult
runMountSudoMaybe' useSudo cmd args environ =
maybe
(runMount' cmd args "" environ)
@ -802,38 +801,38 @@ runMountSudoMaybe' useSudo cmd args environ =
=<< if useSudo then readPassword' "Sudo Password" else return Nothing
-- TODO untested
-- runSudoMount :: String -> String -> [String] -> String -> IO MountResult
-- runSudoMount :: T.Text -> T.Text -> [T.Text] -> T.Text -> IO MountResult
-- runSudoMount rootpass cmd args stdin = runSudoMount' rootpass cmd args stdin []
runSudoMount' :: String -> String -> [String] -> [(String, String)] -> IO MountResult
runSudoMount' :: T.Text -> T.Text -> [T.Text] -> [(T.Text, T.Text)] -> IO MountResult
runSudoMount' rootpass cmd args environ = runMount "sudo" args' rootpass
where
args' = ["-S"] ++ environ' ++ [cmd] ++ args
environ' = fmap (\(k, v) -> k ++ "=" ++ v) environ
environ' = fmap (\(k, v) -> T.concat [k, "=", v]) environ
eitherToMountResult :: Either (Int, String, String) String -> MountResult
eitherToMountResult :: Either (Int, T.Text, T.Text) T.Text -> MountResult
eitherToMountResult (Right _) = MountSuccess
eitherToMountResult (Left (_, _, e)) = MountError e
--------------------------------------------------------------------------------
-- Low-level mount functions
mountMap :: IO (M.Map FilePath String)
mountMap :: IO (M.Map FilePath T.Text)
mountMap = do
parseFile <$> readFileUtf8 "/proc/mounts"
where
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 (T.unpack mountpoint, T.unpack spec)
parseLine [spec, mountpoint, _, _, _, _] = Just (T.unpack mountpoint, spec)
parseLine _ = Nothing
curDeviceSpecs :: IO [String]
curDeviceSpecs :: IO [T.Text]
curDeviceSpecs = M.elems <$> mountMap
curMountpoints :: IO [String]
curMountpoints :: IO [FilePath]
curMountpoints = M.keys <$> mountMap
lookupSpec :: FilePath -> IO (Maybe String)
lookupSpec :: FilePath -> IO (Maybe T.Text)
lookupSpec mountpoint = M.lookup mountpoint <$> mountMap
-- ASSUME the base mount path will always be created because
@ -859,7 +858,7 @@ withTmpMountDir m =
-- | Run an unmount command and remove the mountpoint if no errors occur
runAndRemoveDir :: FilePath -> RofiMountIO MountResult -> RofiMountIO MountResult
runAndRemoveDir m f = do
res <- catch f (return . MountError . (displayException :: SomeException -> String))
res <- catch f (return . MountError . (T.pack . displayException :: SomeException -> T.Text))
when (res == MountSuccess) $ rmDirMaybe m
return res
@ -892,17 +891,17 @@ isDirMounted fp = elem fp <$> curMountpoints
--------------------------------------------------------------------------------
-- Other functions
fromLines :: (String -> Maybe a) -> [String] -> [a]
fromLines :: (T.Text -> Maybe a) -> [T.Text] -> [a]
fromLines f = mapMaybe (f . stripWS)
-- TODO this exists somewhere...
splitBy :: Char -> String -> [String]
splitBy delimiter = foldr f [[]]
where
f _ [] = []
f c l@(x : xs)
| c == delimiter = [] : l
| otherwise = (c : x) : xs
-- splitBy :: Char -> T.Text -> [T.Text]
-- splitBy delimiter = T.foldr f [[]]
-- where
-- f _ [] = []
-- f c l@(x : xs)
-- | c == delimiter = [] : l
-- | otherwise = (c : x) : xs
appendRoot :: FilePath -> FilePath -> FilePath
appendRoot root path = if isRelative path then root </> path else path

View File

@ -4,10 +4,9 @@
module Main (main) where
import Data.List (isPrefixOf)
import Data.List.Split
import Data.Maybe
import RIO
import qualified RIO.Text as T
import Rofi.Command
import System.Environment
import System.Process
@ -23,7 +22,7 @@ runPrompt args = do
run (VPNStatus connected servers) = do
let d = getDisconnectAction <$> connected
let cs = fmap (getConnectAction connected) servers
runRofiIO (RofiVPNConf args) $
runRofiIO (RofiVPNConf $ fmap T.pack args) $
selectAction $
emptyMenu
{ groups =
@ -33,16 +32,16 @@ runPrompt args = do
, prompt = Just "Select Action"
}
newtype RofiVPNConf = RofiVPNConf [String]
newtype RofiVPNConf = RofiVPNConf [T.Text]
instance RofiConf RofiVPNConf where
defArgs (RofiVPNConf as) = as
type VPNAction = RofiAction RofiVPNConf
type VPNServer = (String, String)
type VPNServer = (T.Text, T.Text)
data VPNStatus = VPNStatus (Maybe String) [VPNServer] deriving (Show)
data VPNStatus = VPNStatus (Maybe T.Text) [VPNServer] deriving (Show)
getServers :: IO (Maybe VPNStatus)
getServers = do
@ -56,13 +55,13 @@ getStatus = do
connected <- getConnectedServer
VPNStatus connected <$> getAvailableServers
getConnectedServer :: IO (Maybe String)
getConnectedServer :: IO (Maybe T.Text)
getConnectedServer = (procStatus =<<) <$> readCmdSuccess eVPN ["status"] ""
where
procStatus = listToMaybe . mapMaybe procLine . lines
procLine l = case words l of
procStatus = listToMaybe . mapMaybe procLine . T.lines
procLine l = case T.words l of
-- the output is green...
("\ESC[1;32;49mConnected" : "to" : server) -> Just $ unwords server
("\ESC[1;32;49mConnected" : "to" : server) -> Just $ T.unwords server
_ -> Nothing
getAvailableServers :: IO [VPNServer]
@ -76,13 +75,13 @@ getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
-- by a blank line, after which there is more stuff I don't care about
procOut (Just ls) =
return $
mapMaybe (matchLine . splitOn "\t") $
mapMaybe (matchLine . T.split (== '\t')) $
takeWhile (/= "") $
drop 1
-- super lame way of matching lines that start with "-----"
$
dropWhile (not . isPrefixOf "-----") $
lines ls
dropWhile (not . T.isPrefixOf "-----") $
T.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
@ -96,11 +95,11 @@ getAvailableServers = procOut =<< readCmdSuccess eVPN ["ls"] ""
daemonIsRunning :: IO Bool
daemonIsRunning = isJust <$> readCmdSuccess "pgrep" [eVPND] ""
getDisconnectAction :: String -> VPNAction
getDisconnectAction :: T.Text -> VPNAction
getDisconnectAction server =
("Disconnect from " ++ server, io $ void $ disconnect server)
(T.append "Disconnect from " server, io $ void $ disconnect server)
getConnectAction :: Maybe String -> VPNServer -> VPNAction
getConnectAction :: Maybe T.Text -> VPNServer -> VPNAction
getConnectAction connected server =
(formatServerLine server, io $ go connected)
where
@ -110,15 +109,15 @@ getConnectAction connected server =
go _ = con
con = connect server
formatServerLine :: VPNServer -> String
formatServerLine (sid, sname) = pad sid ++ " | " ++ sname
formatServerLine :: VPNServer -> T.Text
formatServerLine (sid, sname) = T.concat [pad sid, " | ", sname]
where
pad s = s ++ replicate (10 - length s) ' '
pad s = T.append s $ T.replicate (10 - T.length s) " "
eVPN :: String
eVPN :: T.Text
eVPN = "expressvpn"
eVPND :: String
eVPND :: T.Text
eVPND = "expressvpnd"
connect :: VPNServer -> IO ()
@ -126,19 +125,19 @@ connect (sid, sname) = do
res <- readCmdSuccess' eVPN ["connect", sid]
notifyIf
res
("connected to " ++ sname)
("failed to connect to " ++ sname)
(T.append "connected to " sname)
(T.append "failed to connect to " sname)
disconnect :: String -> IO Bool
disconnect :: T.Text -> IO Bool
disconnect server = do
res <- readCmdSuccess' eVPN ["disconnect"]
notifyIf
res
("disconnected from " ++ server)
("failed to disconnect from " ++ server)
(T.append "disconnected from " server)
(T.append "failed to disconnect from " server)
return res
readCmdSuccess' :: String -> [String] -> IO Bool
readCmdSuccess' :: T.Text -> [T.Text] -> IO Bool
readCmdSuccess' cmd args = isJust <$> readCmdSuccess cmd args ""
-- TODO not DRY
@ -148,12 +147,12 @@ instance Show NotifyIcon where
show IconError = "dialog-error-symbolic"
show IconInfo = "dialog-information-symbolic"
notifyIf :: Bool -> String -> String -> IO ()
notifyIf :: Bool -> T.Text -> T.Text -> IO ()
notifyIf True s _ = notify IconInfo s
notifyIf False _ s = notify IconError s
notify :: NotifyIcon -> String -> IO ()
notify icon body = void $ spawnProcess "notify-send" $ args ++ [body]
notify :: NotifyIcon -> T.Text -> IO ()
notify icon body = void $ spawnProcess "notify-send" $ args ++ [T.unpack body]
where
args = ["-i", show icon, summary]
summary = "ExpressVPN"

View File

@ -23,12 +23,12 @@
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 qualified RIO.Text as T
import System.Environment
import System.Process
@ -37,11 +37,11 @@ main = do
r <- getMonitorName
let pre = maybe [] (\n -> ["-m", n]) r
args <- getArgs
callProcess "/usr/bin/rofi" $ pre ++ args
callProcess "/usr/bin/rofi" $ (fmap T.unpack pre) ++ args
data Coord = Coord Int Int deriving (Eq, Show)
getMonitorName :: IO (Maybe String)
getMonitorName :: IO (Maybe T.Text)
getMonitorName = do
dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy
@ -62,7 +62,7 @@ getDesktopViewports dpy root =
pairs' acc (x1 : x2 : xs) = pairs' (Coord x1 x2 : acc) xs
pairs' acc _ = acc
getOutputs :: Display -> Window -> IO [(Coord, String)]
getOutputs :: Display -> Window -> IO [(Coord, T.Text)]
getOutputs dpy root =
xrrGetScreenResourcesCurrent dpy root
>>= maybe (return []) resourcesToCells
@ -79,7 +79,7 @@ getOutputs dpy root =
, xrr_oi_crtc = c
}
) = do
fmap (\i -> (toCoord i, n)) <$> xrrGetCrtcInfo dpy r c
fmap (\i -> (toCoord i, T.pack n)) <$> xrrGetCrtcInfo dpy r c
infoToCell _ _ = return Nothing
toCoord c = Coord (fromIntegral $ xrr_ci_x c) (fromIntegral $ xrr_ci_y c)
@ -90,8 +90,8 @@ infix 9 !!?
| i < 0 = Nothing
| otherwise = listToMaybe $ drop i xs
getAtom32 :: Display -> Window -> String -> IO [Int]
getAtom32 :: Display -> Window -> T.Text -> IO [Int]
getAtom32 dpy root str = do
a <- internAtom dpy str False
a <- internAtom dpy (T.unpack str) False
p <- getWindowProperty32 dpy a root
return $ maybe [] (fmap fromIntegral) p

View File

@ -12,7 +12,6 @@ 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
@ -39,7 +38,7 @@ newtype BWServerConf = BWServerConf
-- TODO add a cache so the browse list will load faster
data CurrentSession = CurrentSession
{ timestamp :: UnixTime
, hash :: String
, hash :: T.Text
}
type Session = MVar (Maybe CurrentSession)
@ -62,7 +61,7 @@ syncSession conf ses = notify =<< fmap join . mapM cmd =<< getSession' conf ses
let j = isJust res
in notifyStatus j $ if j then "sync succeeded" else "sync failed"
getSession' :: BWServerConf -> Session -> IO (Maybe String)
getSession' :: BWServerConf -> Session -> IO (Maybe T.Text)
getSession' BWServerConf {timeout = t} ses = do
ut <- getUnixTime
modifyMVar ses $ \s -> case s of
@ -78,15 +77,15 @@ getSession' BWServerConf {timeout = t} ses = do
ut <- getUnixTime
return CurrentSession {timestamp = ut, hash = h}
getSession :: BWServerConf -> Session -> IO String
getSession :: BWServerConf -> Session -> IO T.Text
getSession conf ses = fromMaybe "" <$> getSession' conf ses
readSession :: String -> IO (Maybe String)
readSession :: T.Text -> IO (Maybe T.Text)
readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
notifyStatus :: Bool -> String -> IO ()
notifyStatus :: Bool -> T.Text -> IO ()
notifyStatus succeeded msg =
void $ spawnProcess "notify-send" ["-i", i, msg]
void $ spawnProcess "notify-send" ["-i", i, T.unpack msg]
where
i =
if succeeded
@ -109,12 +108,12 @@ 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]
newtype BWClientConf = BWClientConf [T.Text]
instance RofiConf BWClientConf where
defArgs (BWClientConf a) = a
runClient :: [String] -> IO ()
runClient :: [T.Text] -> IO ()
runClient a = do
let c = BWClientConf a
runRofiIO c $
@ -136,9 +135,9 @@ browseLogins = io getItems >>= selectItem
getItems :: IO [Item]
getItems = maybe (return []) getItems' =<< callGetSession
getItems' :: String -> IO [Item]
getItems' :: T.Text -> IO [Item]
getItems' session = do
items <- io $ readProcess "bw" ["list", "items", "--session", session] ""
items <- io $ readProcess "bw" ["list", "items", "--session", T.unpack session] ""
return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
where
notEmpty Item {login = Login {username = Nothing, password = Nothing}} =
@ -146,7 +145,7 @@ getItems' session = do
notEmpty _ = True
data Item = Item
{ name :: String
{ name :: T.Text
, login :: Login
}
deriving (Show)
@ -159,8 +158,8 @@ instance FromJSON Item where
parseJSON _ = mzero
data Login = Login
{ username :: Maybe String
, password :: Maybe String
{ username :: Maybe T.Text
, password :: Maybe T.Text
}
deriving (Show, Generic)
@ -188,7 +187,7 @@ selectCopy l =
, hotkeys = [copyHotkey, backHotkey]
}
where
copy = io . setClipboardString
copy = io . setClipboardString . T.unpack
copyRepeat s = copy s >> selectCopy l
copyHotkey =
Hotkey
@ -207,22 +206,27 @@ selectCopy l =
keyActions = loginToRofiActions l (const browseLogins)
}
loginToRofiActions :: Login -> (String -> RofiIO c ()) -> RofiActions c
loginToRofiActions :: Login -> (T.Text -> RofiIO c ()) -> RofiActions c
loginToRofiActions Login {username = u, password = p} a =
toRofiActions $ catMaybes [user, pwd]
where
copyIfJust f = fmap $ liftM2 (,) f a
fmtUsername s = "Username (" ++ s ++ ")"
fmtPassword s = "Password (" ++ take 32 (replicate (length s) '*') ++ ")"
fmtUsername s = T.concat ["Username (", s, ")"]
fmtPassword s = T.concat ["Password (", T.take 32 (T.replicate (T.length s) "*"), ")"]
user = copyIfJust fmtUsername u
pwd = copyIfJust fmtPassword p
getItemPassword' :: BWServerConf -> Session -> String -> IO (Maybe String)
getItemPassword' :: BWServerConf -> Session -> T.Text -> IO (Maybe T.Text)
getItemPassword' conf session item = mapM getPwd =<< getSession' conf session
where
getPwd s = readProcess "bw" ["get", "password", item, "--session", s] ""
getPwd s =
T.pack
<$> readProcess
"bw"
["get", "password", T.unpack item, "--session", T.unpack s]
""
getItemPassword :: BWServerConf -> Session -> String -> IO String
getItemPassword :: BWServerConf -> Session -> T.Text -> IO T.Text
getItemPassword conf session item =
fromMaybe ""
<$> getItemPassword' conf session item
@ -283,13 +287,13 @@ callLockSession = void $ callMember memLockSession
callSyncSession :: IO ()
callSyncSession = void $ callMember memSyncSession
callGetSession :: IO (Maybe String)
callGetSession :: IO (Maybe T.Text)
callGetSession = getBodyString <$> callMember memGetSession
-- TODO maybe will need to add a caller for getItemPassword
getBodyString :: [Variant] -> Maybe String
getBodyString [b] = case fromVariant b :: Maybe String of
getBodyString :: [Variant] -> Maybe T.Text
getBodyString [b] = case fromVariant b :: Maybe T.Text of
Just "" -> Nothing
s -> s
getBodyString _ = Nothing

View File

@ -25,60 +25,58 @@ module Rofi.Command
)
where
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Data.Char
import qualified Data.Map.Ordered as M
import Data.Maybe
import RIO
import qualified RIO.List as L
import qualified RIO.Text as T
import System.Process
class RofiConf c where
defArgs :: c -> [String]
defArgs :: c -> [T.Text]
type RofiAction c = (String, RofiIO c ())
type RofiAction c = (T.Text, RofiIO c ())
type RofiActions c = M.OMap String (RofiIO c ())
type RofiActions c = M.OMap T.Text (RofiIO c ())
data RofiGroup c = RofiGroup
{ actions :: RofiActions c
, title :: Maybe String
, title :: Maybe T.Text
}
untitledGroup :: RofiActions c -> RofiGroup c
untitledGroup a = RofiGroup {actions = a, title = Nothing}
titledGroup :: String -> RofiActions c -> RofiGroup c
titledGroup :: T.Text -> RofiActions c -> RofiGroup c
titledGroup t a = (untitledGroup a) {title = Just t}
data Hotkey c = Hotkey
{ keyCombo :: String
{ keyCombo :: !T.Text
, -- only 1-10 are valid
keyIndex :: Int
, keyDescription :: String
keyIndex :: !Int
, keyDescription :: !T.Text
, keyActions :: RofiActions c
}
hotkeyBinding :: Hotkey c -> [String]
hotkeyBinding :: Hotkey c -> [T.Text]
hotkeyBinding Hotkey {keyIndex = e, keyCombo = c} = [k, c]
where
k = "-kb-custom-" ++ show e
k = T.append "-kb-custom-" $ T.pack $ show e
hotkeyMsg1 :: Hotkey c -> String
hotkeyMsg1 :: Hotkey c -> T.Text
hotkeyMsg1 Hotkey {keyCombo = c, keyDescription = d} =
c ++ ": <i>" ++ d ++ "</i>"
T.concat [c, ": <i>", d, "</i>"]
hotkeyMsg :: [Hotkey c] -> [String]
hotkeyMsg :: [Hotkey c] -> [T.Text]
hotkeyMsg [] = []
hotkeyMsg hs = ["-mesg", L.intercalate " | " $ fmap hotkeyMsg1 hs]
hotkeyMsg hs = ["-mesg", T.intercalate " | " $ fmap hotkeyMsg1 hs]
hotkeyArgs :: [Hotkey c] -> [String]
hotkeyArgs :: [Hotkey c] -> [T.Text]
hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
data RofiMenu c = RofiMenu
{ groups :: [RofiGroup c]
, prompt :: Maybe String
, prompt :: Maybe T.Text
, hotkeys :: [Hotkey c]
}
@ -99,27 +97,27 @@ io = liftIO
runRofiIO :: c -> RofiIO c a -> IO a
runRofiIO c (RofiIO r) = runReaderT r c
toRofiActions :: [(String, RofiIO c ())] -> RofiActions c
toRofiActions :: [(T.Text, RofiIO c ())] -> RofiActions c
toRofiActions = M.fromList
rofiActionKeys :: RofiActions c -> String
rofiActionKeys :: RofiActions c -> T.Text
rofiActionKeys = joinNewline . map fst . M.assocs
lookupRofiAction :: String -> RofiActions c -> RofiIO c ()
lookupRofiAction :: T.Text -> RofiActions c -> RofiIO c ()
lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
groupEntries :: RofiGroup c -> String
groupEntries :: RofiGroup c -> T.Text
groupEntries RofiGroup {actions = a, title = t}
| null a = ""
| otherwise = title' ++ rofiActionKeys a
| otherwise = T.append title' $ rofiActionKeys a
where
title' = maybe "" (++ "\n") t
title' = maybe "" (`T.append` "\n") t
menuActions :: RofiMenu c -> RofiActions c
menuActions = L.foldr (M.<>|) M.empty . fmap actions . groups
menuEntries :: RofiMenu c -> String
menuEntries = L.intercalate "\n\n" . filter (not . null) . fmap groupEntries . groups
menuEntries :: RofiMenu c -> T.Text
menuEntries = T.intercalate "\n\n" . filter (not . T.null) . fmap groupEntries . groups
selectAction :: RofiConf c => RofiMenu c -> RofiIO c ()
selectAction rm = do
@ -133,63 +131,67 @@ selectAction rm = do
L.find ((==) n . (+ 9) . keyIndex) $
hotkeys rm
maybeOption :: String -> Maybe String -> [String]
maybeOption :: T.Text -> Maybe T.Text -> [T.Text]
maybeOption switch = maybe [] (\o -> [switch, o])
dmenuArgs :: [String]
dmenuArgs :: [T.Text]
dmenuArgs = ["-dmenu"]
readRofi
:: RofiConf c
=> [String]
-> String
-> RofiIO c (Either (Int, String, String) String)
=> [T.Text]
-> T.Text
-> RofiIO c (Either (Int, T.Text, T.Text) T.Text)
readRofi uargs input = do
dargs <- asks defArgs
io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
readCmdSuccess :: String -> [String] -> String -> IO (Maybe String)
readCmdSuccess :: T.Text -> [T.Text] -> T.Text -> IO (Maybe T.Text)
readCmdSuccess cmd args input =
either (const Nothing) Just
<$> readCmdEither cmd args input
readCmdEither
:: String
-> [String]
-> String
-> IO (Either (Int, String, String) String)
:: T.Text
-> [T.Text]
-> T.Text
-> IO (Either (Int, T.Text, T.Text) T.Text)
readCmdEither cmd args input =
resultToEither
<$> readProcessWithExitCode cmd args input
<$> readProcessWithExitCode (T.unpack cmd) (fmap T.unpack args) (T.unpack input)
readCmdEither'
:: String
-> [String]
-> String
-> [(String, String)]
-> IO (Either (Int, String, String) String)
:: T.Text
-> [T.Text]
-> T.Text
-> [(T.Text, T.Text)]
-> IO (Either (Int, T.Text, T.Text) T.Text)
readCmdEither' cmd args input environ =
resultToEither
<$> readCreateProcessWithExitCode p input
<$> readCreateProcessWithExitCode p (T.unpack input)
where
p = (proc cmd args) {env = Just environ}
p =
(proc (T.unpack cmd) (fmap T.unpack args))
{ env = Just $ fmap (bimap T.unpack T.unpack) environ
}
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)
-> Either (Int, T.Text, T.Text) T.Text
resultToEither (ExitSuccess, out, _) = Right $ stripWS $ T.pack out
resultToEither (ExitFailure n, out, err) =
Left (n, stripWS $ T.pack out, stripWS $ T.pack err)
stripWS :: String -> String
stripWS = reverse . dropWhile isSpace . reverse
stripWS :: T.Text -> T.Text
stripWS = T.reverse . T.dropWhile isSpace . T.reverse
joinNewline :: [String] -> String
joinNewline = L.intercalate "\n"
joinNewline :: [T.Text] -> T.Text
joinNewline = T.intercalate "\n"
readPassword :: IO (Maybe String)
readPassword :: IO (Maybe T.Text)
readPassword = readPassword' "Password"
readPassword' :: String -> IO (Maybe String)
readPassword' :: T.Text -> IO (Maybe T.Text)
readPassword' p = readCmdSuccess "rofi" args ""
where
args = dmenuArgs ++ ["-p", p, "-password"]