REF use text everywhere
This commit is contained in:
parent
4265a5947c
commit
09ce10a942
|
|
@ -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>"
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]"
|
||||
|
|
|
|||
221
app/rofi-dev.hs
221
app/rofi-dev.hs
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
14
app/rofi.hs
14
app/rofi.hs
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue