ENH generalize RofiIO monad
This commit is contained in:
parent
49c4f4cf1c
commit
7c1d899be6
|
@ -61,7 +61,7 @@ checkExe cmd = do
|
|||
--
|
||||
-- The session ID will be valid only as long as TIMEOUT
|
||||
|
||||
newtype BWConf = BWConf
|
||||
newtype BWServerConf = BWServerConf
|
||||
{ timeout :: UnixDiffTime
|
||||
}
|
||||
|
||||
|
@ -75,15 +75,15 @@ type Session = MVar (Maybe CurrentSession)
|
|||
runDaemon :: Int -> IO ()
|
||||
runDaemon t = do
|
||||
ses <- newMVar Nothing
|
||||
let c = BWConf { timeout = UnixDiffTime (fromIntegral t) 0 }
|
||||
let c = BWServerConf { timeout = UnixDiffTime (fromIntegral t) 0 }
|
||||
startService c ses
|
||||
forever $ threadDelay 1000000
|
||||
|
||||
lockSession :: Session -> IO ()
|
||||
lockSession ses = void $ swapMVar ses Nothing
|
||||
|
||||
getSession :: BWConf -> Session -> IO String
|
||||
getSession BWConf { timeout = t } ses = do
|
||||
getSession :: BWServerConf -> Session -> IO String
|
||||
getSession BWServerConf { timeout = t } ses = do
|
||||
ut <- getUnixTime
|
||||
modifyMVar ses $ \s -> case s of
|
||||
Just CurrentSession { timestamp = ts, hash = h } ->
|
||||
|
@ -98,11 +98,6 @@ getSession BWConf { timeout = t } ses = do
|
|||
ut <- getUnixTime
|
||||
return CurrentSession { timestamp = ut, hash = h }
|
||||
|
||||
readPassword :: IO (Maybe String)
|
||||
readPassword = readCmdSuccess "rofi" args ""
|
||||
where
|
||||
args = dmenuArgs ++ ["-p", "Password", "-password"]
|
||||
|
||||
readSession :: String -> IO (Maybe String)
|
||||
readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
|
||||
|
||||
|
@ -122,10 +117,15 @@ readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
|
|||
-- - password (if applicable) -> copy to clipboard
|
||||
-- - anything else (notes and such) -> copy to clipboard
|
||||
|
||||
newtype BWClientConf = BWClientConf [String]
|
||||
|
||||
instance RofiConf BWClientConf where
|
||||
defArgs (BWClientConf a) = a
|
||||
|
||||
runClient :: [String] -> IO ()
|
||||
runClient a = do
|
||||
let c = RofiConf { defArgs = a }
|
||||
runRofiPrompt c $ selectAction $ emptyMenu
|
||||
let c = BWClientConf a
|
||||
runRofiIO c $ selectAction $ emptyMenu
|
||||
{ groups = [untitledGroup $ toRofiActions ras]
|
||||
, prompt = Just "Action"
|
||||
}
|
||||
|
@ -134,12 +134,12 @@ runClient a = do
|
|||
, ("Lock Session", io callLockSession)
|
||||
]
|
||||
|
||||
browseLogins :: RofiPrompt ()
|
||||
browseLogins :: RofiConf c => RofiIO c ()
|
||||
browseLogins = do
|
||||
session <- io callGetSession
|
||||
forM_ session $ getItems >=> selectItem
|
||||
|
||||
getItems :: String -> RofiPrompt [Item]
|
||||
getItems :: RofiConf c => String -> RofiIO c [Item]
|
||||
getItems session = do
|
||||
items <- io $ readProcess "bw" ["list", "items", "--session", session] ""
|
||||
return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
|
||||
|
@ -170,16 +170,16 @@ instance FromJSON Login
|
|||
|
||||
-- TODO make menu buttons here to go back and to copy without leaving
|
||||
-- the current menu
|
||||
selectItem :: [Item] -> RofiPrompt ()
|
||||
selectItem :: RofiConf c => [Item] -> RofiIO c ()
|
||||
selectItem items = selectAction $ emptyMenu
|
||||
{ groups = [untitledGroup $ itemsToRofiActions items]
|
||||
, prompt = Just "Login"
|
||||
}
|
||||
|
||||
itemsToRofiActions :: [Item] -> RofiActions
|
||||
itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c
|
||||
itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
|
||||
|
||||
selectCopy :: Login -> RofiPrompt ()
|
||||
selectCopy :: RofiConf c => Login -> RofiIO c ()
|
||||
selectCopy l = selectAction $ emptyMenu
|
||||
{ groups = [untitledGroup $ loginToRofiActions l copy]
|
||||
, prompt = Just "Copy"
|
||||
|
@ -203,7 +203,7 @@ selectCopy l = selectAction $ emptyMenu
|
|||
, keyActions = loginToRofiActions l (const browseLogins)
|
||||
}
|
||||
|
||||
loginToRofiActions :: Login -> (String -> RofiPrompt ()) -> RofiActions
|
||||
loginToRofiActions :: RofiConf c => Login -> (String -> RofiIO c ()) -> RofiActions c
|
||||
loginToRofiActions Login { username = u, password = p } a =
|
||||
toRofiActions $ catMaybes [user, pwd]
|
||||
where
|
||||
|
@ -231,7 +231,7 @@ memGetSession = "GetSession"
|
|||
memLockSession :: MemberName
|
||||
memLockSession = "LockSession"
|
||||
|
||||
startService :: BWConf -> Session -> IO ()
|
||||
startService :: BWServerConf -> Session -> IO ()
|
||||
startService c ses = do
|
||||
client <- connectSession
|
||||
let flags = [nameAllowReplacement, nameReplaceExisting]
|
||||
|
|
|
@ -1,63 +1,145 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as B
|
||||
import Data.Char
|
||||
import Data.Csv hiding (lookup)
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.List.Split (splitOn)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Map.Ordered as O
|
||||
import Data.List.Split (splitOn)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Map.Ordered as O
|
||||
import Data.Maybe
|
||||
import Data.Vector (Vector, toList)
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Rofi.Command
|
||||
|
||||
import Text.Printf
|
||||
import Text.Regex.TDFA
|
||||
|
||||
import System.Console.GetOpt
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath.Posix
|
||||
import System.Posix.User (getEffectiveUserName)
|
||||
import System.Process
|
||||
|
||||
import UnliftIO.Exception
|
||||
|
||||
main :: IO ()
|
||||
main = check >> getArgs >>= parse
|
||||
|
||||
type Password = IO (Maybe String)
|
||||
|
||||
data MountConf = MountConf
|
||||
{ credentials :: M.Map String Password
|
||||
, mountDir :: FilePath
|
||||
, rofiArgs :: [String]
|
||||
}
|
||||
|
||||
instance RofiConf MountConf where
|
||||
defArgs MountConf { rofiArgs = a } = a
|
||||
|
||||
|
||||
type DevicePasswords = M.Map String Password
|
||||
|
||||
initMountConf :: [String] -> IO MountConf
|
||||
initMountConf a = conf <$> getEffectiveUserName
|
||||
where
|
||||
conf u = MountConf
|
||||
{ credentials = M.empty
|
||||
, mountDir = "/media" </> u
|
||||
, rofiArgs = a
|
||||
}
|
||||
|
||||
options :: [OptDescr (MountConf -> MountConf)]
|
||||
options =
|
||||
-- TODO clean up massive text blocks here with textwrap
|
||||
[ Option ['s'] ["secret"]
|
||||
(ReqArg (\s m -> m { credentials = addGetSecret (credentials m) s } ) "SECRET")
|
||||
("Use libsecret to retrieve password for DIR using ATTR/VAL pairs.\n" ++
|
||||
"The pairs will be supplied to a 'secret-tool lookup' call.\n" ++
|
||||
"Argument is formatted like 'DIR:ATTR1=VAL1,ATTR2=VAL2...'")
|
||||
, Option ['d'] ["directory"]
|
||||
(ReqArg (\s m -> m { mountDir = s } ) "DIR")
|
||||
("The directory in which new mountpoints will be created. This is\n" ++
|
||||
"assumed to be writable to the current user, and will be used for\n" ++
|
||||
"fuse entries as well as user mounts in fstab. For the latter, it is\n" ++
|
||||
"assumed that all user mounts contain this directory if a mountpoint\n" ++
|
||||
"does not already exist for them. If not diven this will default to\n" ++
|
||||
"'/media/USER'.")
|
||||
, Option ['p'] ["password"]
|
||||
(ReqArg (\s m -> m { credentials = addGetPrompt (credentials m) s } ) "DIR")
|
||||
"Prompt for password when mounting DIR."
|
||||
]
|
||||
|
||||
parse :: [String] -> IO ()
|
||||
parse = runMounts
|
||||
parse args = case getOpt Permute options args of
|
||||
(o, n, []) -> do
|
||||
i <- initMountConf n
|
||||
runMounts $ foldl (flip id) i o
|
||||
-- TODO make this a real error
|
||||
(_, _, errs) -> putStrLn $ concat errs ++ usageInfo "header" options
|
||||
|
||||
addGetSecret :: DevicePasswords -> String -> DevicePasswords
|
||||
addGetSecret pwds c = case splitPrefix c of
|
||||
(dir, ":", r) -> addPasswordGetter pwds dir $ runGetSecret
|
||||
$ mapMaybe (toCell . splitEq) $ splitBy ',' r
|
||||
_ -> pwds
|
||||
where
|
||||
splitPrefix s = s =~ (":" :: String) :: (String, String, String)
|
||||
splitEq e = e =~ ("=" :: String) :: (String, String, String)
|
||||
toCell (k, "=", v) = Just (k, v)
|
||||
toCell _ = Nothing
|
||||
|
||||
runGetSecret :: [(String, String)] -> Password
|
||||
runGetSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
|
||||
where
|
||||
kvs' = concatMap (\(k, v) -> [k, v]) kvs
|
||||
|
||||
addGetPrompt :: DevicePasswords -> String -> DevicePasswords
|
||||
addGetPrompt pwds dir = addPasswordGetter pwds dir readPassword
|
||||
|
||||
addPasswordGetter :: DevicePasswords -> String -> IO (Maybe String) -> DevicePasswords
|
||||
addPasswordGetter pwds key f = M.insert key f pwds
|
||||
|
||||
-- runGetBwPwd :: [(String, String)] -> IO (Maybe String)
|
||||
-- runGetBwPwd = undefined
|
||||
|
||||
-- getPassword :: Credentials -> IO (Maybe String)
|
||||
-- getPassword NoCredentials = return Nothing
|
||||
-- getPassword (Secret kvs) = do
|
||||
-- let kvs' = concat [[a, b] | (a, b) <- M.toList kvs]
|
||||
-- readCmdSuccess "secret-tool" ("lookup":kvs') ""
|
||||
|
||||
-- TODO
|
||||
check :: IO ()
|
||||
check = return ()
|
||||
|
||||
runMounts :: [String] -> IO ()
|
||||
runMounts a = do
|
||||
let c = RofiConf { defArgs = a }
|
||||
runRofiPrompt c runPrompt
|
||||
runMounts :: MountConf -> IO ()
|
||||
runMounts c = runRofiIO c $ runPrompt =<< getGroups
|
||||
|
||||
runPrompt :: RofiPrompt ()
|
||||
runPrompt = do
|
||||
net <- titledGroup "Network Devices" <$> io getNetActions
|
||||
rmv <- titledGroup "Removable Devices" <$> io getRemovableActions
|
||||
mtp <- titledGroup "MTP Devices" <$> io getMTPActions
|
||||
selectAction $ emptyMenu
|
||||
{ groups = [net, rmv, mtp]
|
||||
, prompt = Just "Select Device"
|
||||
}
|
||||
runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
|
||||
runPrompt gs = selectAction $ emptyMenu
|
||||
{ groups = gs
|
||||
, prompt = Just "Select Device"
|
||||
}
|
||||
|
||||
getNetActions :: IO RofiActions
|
||||
getNetActions = alignEntries . toRofiActions . catMaybes
|
||||
<$> (mapM csvToAction =<< getCSV)
|
||||
getGroups :: RofiIO MountConf [RofiGroup MountConf]
|
||||
getGroups = do
|
||||
fstab <- readFSTab
|
||||
sequence
|
||||
[ mkGroup "SSHFS Devices" $ sshfsDevices fstab
|
||||
, mkGroup "CIFS Devices" $ cifsDevices fstab
|
||||
, mkGroup "Removable Devices" =<< getRemovableDevices
|
||||
, mkGroup "MTP Devices" =<< getMTPDevices
|
||||
]
|
||||
|
||||
mkGroup :: Mountable d => String -> [d] -> RofiIO MountConf (RofiGroup MountConf)
|
||||
mkGroup header devs = titledGroup header . alignEntries . toRofiActions
|
||||
<$> mapM mkAction devs
|
||||
|
||||
alignSep :: String
|
||||
alignSep = " | "
|
||||
|
@ -65,7 +147,7 @@ alignSep = " | "
|
|||
alignSepPre :: String
|
||||
alignSepPre = "@@@"
|
||||
|
||||
alignEntries :: RofiActions -> RofiActions
|
||||
alignEntries :: RofiActions c -> RofiActions c
|
||||
alignEntries = O.fromList . withKeys . O.assocs
|
||||
where
|
||||
withKeys as = let (ks, vs) = unzip as in zip (align ks) vs
|
||||
|
@ -83,24 +165,24 @@ alignEntries = O.fromList . withKeys . O.assocs
|
|||
-- | Class and methods for type representing mountable devices
|
||||
class Mountable a where
|
||||
-- | Mount the given type (or dismount if False is passed)
|
||||
mount :: a -> Bool -> IO ()
|
||||
mount :: a -> Bool -> RofiIO MountConf ()
|
||||
|
||||
-- | Check if the mounting utilities are present
|
||||
allInstalled :: a -> IO Bool
|
||||
allInstalled :: a -> RofiIO MountConf Bool
|
||||
|
||||
-- | Return a string to go in the Rofi menu for the given type
|
||||
fmtEntry :: a -> String
|
||||
|
||||
-- | Determine if the given type is mounted or not
|
||||
isMounted :: a -> IO Bool
|
||||
isMounted :: a -> RofiIO MountConf Bool
|
||||
|
||||
-- | 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 -> IO (String, RofiPrompt ())
|
||||
mkAction :: a -> RofiIO MountConf (String, RofiIO MountConf ())
|
||||
mkAction dev = do
|
||||
m <- isMounted dev
|
||||
i <- allInstalled dev
|
||||
let a = when i $ io $ mount dev m
|
||||
let a = when i $ mount dev m
|
||||
let s = mountedPrefix m i ++ fmtEntry dev
|
||||
return (s, a)
|
||||
where
|
||||
|
@ -121,99 +203,62 @@ parseMountOptions s = M.fromList $ toCell . splitEq <$> splitBy ',' s
|
|||
toCell (k, "=", v) = (k, Just v)
|
||||
toCell (k, _, _) = (k, Nothing)
|
||||
|
||||
-- | Given a mount options map, return a string of comma separated items
|
||||
fmtMountOptions :: MountOptions -> String
|
||||
fmtMountOptions = intercalate "," . fmap fromCell . M.toList
|
||||
where
|
||||
fromCell (k, Just v) = k ++ "=" ++ v
|
||||
fromCell (k, Nothing) = k
|
||||
|
||||
-- | Various credentials to be used with a given mountable type.
|
||||
-- Secret: represents a lookup using 'secret-tool' where the map represents
|
||||
-- the attribute/value pairs to pass.
|
||||
-- NoCredentials: self explanatory
|
||||
data Credentials = Secret (M.Map String String)
|
||||
| NoCredentials
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Given a string, return a credentials type. The type of credentials is
|
||||
-- determined by the prefix (which is followed by a colon) and is followed by
|
||||
-- a comma-separated list of 'key=val' pairs
|
||||
parseCredentials :: String -> Credentials
|
||||
parseCredentials c = case splitPrefix c of
|
||||
("secret", ":", r) -> Secret $ M.fromList $ mapMaybe (toCell . splitEq) $ splitBy ',' r
|
||||
-- TODO fetch from bitwarden
|
||||
-- add more here...
|
||||
_ -> NoCredentials
|
||||
where
|
||||
splitPrefix s = s =~ (":" :: String) :: (String, String, String)
|
||||
splitEq e = e =~ ("=" :: String) :: (String, String, String)
|
||||
toCell (k, "=", v) = Just (k, v)
|
||||
toCell _ = Nothing
|
||||
-- -- | Given a mount options map, return a string of comma separated items
|
||||
-- fmtMountOptions :: MountOptions -> String
|
||||
-- fmtMountOptions = intercalate "," . fmap fromCell . M.toList
|
||||
-- where
|
||||
-- fromCell (k, Just v) = k ++ "=" ++ v
|
||||
-- fromCell (k, Nothing) = k
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Removable devices
|
||||
--
|
||||
-- A device which can be removed (which is all the devices we care about)
|
||||
-- This can be minimally described by a device PATH and LABEL. If MOUNTPOINT is
|
||||
-- Nothing, this represents the device being mounted at a default location.
|
||||
-- This can be minimally described by a device DEVICESPEC and LABEL.
|
||||
|
||||
data Removable = Removable
|
||||
{ path :: String
|
||||
{ deviceSpec :: String
|
||||
, label :: String
|
||||
, mountpoint :: Maybe String
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Mountable Removable where
|
||||
-- | (Un)mount the device using udiskctl
|
||||
mount Removable { path = p, label = l } m = do
|
||||
res <- readCmdEither "udisksctl" [cmd, "-b", p] ""
|
||||
mount Removable { deviceSpec = d, label = l } m = io $ do
|
||||
res <- readCmdEither "udisksctl" [cmd, "-b", d] ""
|
||||
notifyMounted (isRight res) m l
|
||||
where
|
||||
cmd = if m then "unmount" else "mount"
|
||||
|
||||
-- | Need udisksctl to mount and umount
|
||||
allInstalled _ = isJust <$> findExecutable "udisksctl"
|
||||
allInstalled _ = fmap isJust $ io $ findExecutable "udisksctl"
|
||||
|
||||
-- | Check if the device is mounted using /proc/mount
|
||||
isMounted Removable { path = p, mountpoint = m } = do
|
||||
cur <- curMountpoints
|
||||
return $ case m of
|
||||
Just m' -> (p, m') `elem` cur
|
||||
Nothing -> p `elem` fmap fst cur
|
||||
isMounted Removable { deviceSpec = d } = elem d <$> io curDeviceSpecs
|
||||
|
||||
-- | Format the Rofi entry like 'LABEL - PATH' and add a star in the front
|
||||
-- if the device is mounted
|
||||
fmtEntry Removable { path = p, label = l } = l ++ alignSepPre ++ p
|
||||
|
||||
fmtEntry Removable { deviceSpec = d, label = l } = l ++ alignSepPre ++ d
|
||||
|
||||
-- | Return list of possible rofi actions for removable devices
|
||||
-- A 'removable device' is defined as a hotplugged device with a filesystem as
|
||||
-- reported by 'lsblk'. If the LABEL does not exist on the filesystem, the
|
||||
-- label shown on the prompt will be 'SIZE Volume' where size is the size of
|
||||
-- the device
|
||||
getRemovableDevices :: IO [Removable]
|
||||
getRemovableDevices :: RofiConf c => RofiIO c [Removable]
|
||||
getRemovableDevices = mapMaybe toDev
|
||||
. lines
|
||||
. stripWS
|
||||
<$> readProcess "lsblk" ["-n", "-r", "-o", columns] ""
|
||||
<$> 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
|
||||
("":_) -> Nothing
|
||||
[_, "1", p, "", s] -> mk p $ s ++ " Volume"
|
||||
[_, "1", p, l, _] -> mk p l
|
||||
[_, "1", d, "", s] -> mk d $ s ++ " Volume"
|
||||
[_, "1", d, l, _] -> mk d l
|
||||
_ -> Nothing
|
||||
mk p l = Just $ Removable { path = p
|
||||
, label = l
|
||||
, mountpoint = Nothing
|
||||
}
|
||||
|
||||
getRemovableActions :: IO RofiActions
|
||||
getRemovableActions = alignEntries . toRofiActions
|
||||
<$> (mapM mkAction =<< getRemovableDevices)
|
||||
mk d l = Just $ Removable { deviceSpec = d, label = l }
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | CIFS Devices
|
||||
|
@ -221,34 +266,46 @@ getRemovableActions = alignEntries . toRofiActions
|
|||
-- This wraps the Removable device (since it is removable) and also adds its
|
||||
-- own mount options and credentials for authentication.
|
||||
|
||||
data CIFS = CIFS Removable MountOptions Credentials
|
||||
data CIFS = CIFS Removable FilePath (Maybe Password)
|
||||
|
||||
instance Mountable CIFS where
|
||||
-- | Mount using udevil
|
||||
mount (CIFS Removable{..} opts creds) False = do
|
||||
pwd <- getPassword creds
|
||||
let opts' = fmtOpts $ addPwd pwd opts
|
||||
res <- readCmdEither "udevil" (["mount"] ++ opts' ++ ["-t", "cifs", path]) ""
|
||||
notifyMounted (isRight res) False label
|
||||
where
|
||||
addPwd (Just pwd) o = M.insert "password" (Just pwd) o
|
||||
addPwd Nothing o = o
|
||||
fmtOpts o = if null o then [] else ["-o", fmtMountOptions o]
|
||||
mount (CIFS Removable{ label = l } m getPwd) False =
|
||||
bracketOnError_
|
||||
(mkDirMaybe m)
|
||||
(rmDirMaybe m)
|
||||
$ io $ do
|
||||
res <- case getPwd of
|
||||
Just pwd -> do
|
||||
p <- maybe [] (\p -> [("PASSWD", p)]) <$> pwd
|
||||
readCmdEither' "mount" [m] "" p
|
||||
Nothing -> readCmdEither "mount" [m] ""
|
||||
notifyMounted (isRight res) False l
|
||||
|
||||
-- | Unmount using udevil
|
||||
mount (CIFS Removable{..} _ _) True = do
|
||||
res <- readCmdEither "udevil" ["unmount", path] ""
|
||||
notifyMounted (isRight res) True label
|
||||
mount (CIFS Removable{ label = l } m _) True = umountNotify l m
|
||||
|
||||
-- | Need udevil and mount.cifs
|
||||
allInstalled _ = all isJust <$> mapM findExecutable ["udevil", "mount.cifs"]
|
||||
allInstalled _ = io $ isJust <$> findExecutable "mount.cifs"
|
||||
|
||||
-- | Return True if mounted. Only checks the removable type wrapped within
|
||||
isMounted (CIFS r _ _) = isMounted r
|
||||
isMounted (CIFS _ dir _) = io $ isDirMounted dir
|
||||
|
||||
-- | Format the Rofi entry like 'LABEL - (CIFS) - PATH' and prefix with a star
|
||||
-- if mounted
|
||||
fmtEntry (CIFS r _ _) = fmtNetEntry r "CIFS"
|
||||
fmtEntry (CIFS r _ _) = fmtEntry r
|
||||
|
||||
-- TODO this smells like something that should be in a typeclass
|
||||
fstabToCIFS :: FSTabEntry -> RofiIO MountConf CIFS
|
||||
fstabToCIFS FSTabEntry{ fstabSpec = s, fstabDir = d, fstabOptions = o } = do
|
||||
-- This is a hack. If the options specify "guest" don't require a
|
||||
-- password. Else try to find a means to get the password from the
|
||||
-- command line options provided for the this mountpoint. If nothing is
|
||||
-- found, create a dummy function that returns "" as the password, which
|
||||
-- will be passed to the env variable PASSWD when mounting this cifs
|
||||
-- directory and cause it to fail. Setting the env variable is necessary
|
||||
-- the cifs mount call will prompt for a password and hang otherwise.
|
||||
pwd <- if M.member "guest" o
|
||||
then return Nothing
|
||||
else Just . M.findWithDefault (return $ Just "") d <$> asks credentials
|
||||
let r = Removable { deviceSpec = smartSlashPrefix s, label = takeFileName d }
|
||||
return $ CIFS r d pwd
|
||||
where
|
||||
smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | SSHFS Devices
|
||||
|
@ -258,90 +315,77 @@ instance Mountable CIFS where
|
|||
-- config that specifies the port, hostname, user, and identity file, these
|
||||
-- need to be passed as mount options.
|
||||
|
||||
data SSHFS = SSHFS Removable MountOptions
|
||||
data SSHFS = SSHFS Removable FilePath
|
||||
|
||||
instance Mountable SSHFS where
|
||||
-- | Mount using sshfs
|
||||
mount (SSHFS Removable{..} opts) False =
|
||||
case mountpoint of
|
||||
Just m -> cmd m
|
||||
-- TODO only destroy mountpoint if it is not already another mountpoint
|
||||
Nothing -> bracketOnError (makeFuseMount label)
|
||||
(const $ destroyFuseMount label) (const $ cmd $ fmtFusePath label)
|
||||
where
|
||||
-- TODO add auto-dismount to options
|
||||
opts' = if null opts then [] else ["-o", fmtMountOptions opts]
|
||||
cmd m' = do
|
||||
res <- readCmdEither "sshfs" ([path, m'] ++ opts') ""
|
||||
notifyMounted (isRight res) False label
|
||||
mount (SSHFS Removable{ label = l } m) False =
|
||||
bracketOnError_
|
||||
(mkDirMaybe m)
|
||||
(rmDirMaybe m)
|
||||
$ io $ do
|
||||
res <- readCmdEither "mount" [m] ""
|
||||
notifyMounted (isRight res) False l
|
||||
|
||||
-- | Umount using fusermount
|
||||
mount (SSHFS r _) True = fuseUnmount r
|
||||
mount (SSHFS Removable{ label = l } m) True = umountNotify l m
|
||||
|
||||
-- | Need sshfs (assume fuse is also installed)
|
||||
allInstalled _ = isJust <$> findExecutable "sshfs"
|
||||
allInstalled _ = fmap isJust $ io $ findExecutable "sshfs"
|
||||
|
||||
-- | Return True if mounted. Only checks the removable type wrapped within
|
||||
isMounted (SSHFS r _) = isMounted r
|
||||
isMounted (SSHFS _ dir) = io $ isDirMounted dir
|
||||
|
||||
-- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH' and prefix with a
|
||||
-- star if mounted
|
||||
fmtEntry (SSHFS r _) = fmtNetEntry r "SSHFS"
|
||||
fmtEntry (SSHFS r _) = fmtEntry r
|
||||
|
||||
-- | Given a removable device, type string, and boolean for if the device is
|
||||
-- mounted, return a string like 'LABEL - (TYPESTRING) - PATH' and prefix with a
|
||||
-- star if mounted
|
||||
fmtNetEntry :: Removable -> String -> String
|
||||
fmtNetEntry Removable { label = l, path = p } t =
|
||||
intercalate alignSepPre [l, t, p]
|
||||
fstabToSSHFS :: FSTabEntry -> RofiIO MountConf SSHFS
|
||||
fstabToSSHFS FSTabEntry{ fstabSpec = s, fstabDir = d } = return $ SSHFS r d
|
||||
where
|
||||
r = Removable { deviceSpec = s, label = takeFileName d }
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | MTP devices
|
||||
|
||||
data MTPFS = MTPFS
|
||||
{ bus :: String
|
||||
, device :: String
|
||||
, mountpointMTP :: String
|
||||
, description :: String
|
||||
{ bus :: String
|
||||
, device :: String
|
||||
, mountpoint :: FilePath
|
||||
, description :: String
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Mountable MTPFS where
|
||||
-- | Mount using sshfs
|
||||
mount MTPFS {..} False = do
|
||||
-- TODO add autodismount to options
|
||||
let dev = "-device=" ++ bus ++ "," ++ device
|
||||
bracketOnError (createDirectoryIfMissing False mountpointMTP)
|
||||
(const $ removePathForcibly mountpointMTP) $ \_ -> do
|
||||
res <- readCmdEither "jmtpfs" [dev, mountpointMTP] ""
|
||||
bracketOnError_
|
||||
(mkDirMaybe mountpoint)
|
||||
(rmDirMaybe mountpoint)
|
||||
$ io $ do
|
||||
res <- readCmdEither "jmtpfs" [dev, mountpoint] ""
|
||||
notifyMounted (isRight res) False description
|
||||
|
||||
-- | Umount using fusermount
|
||||
mount MTPFS { mountpointMTP = m, description = d } True =
|
||||
finally (fuseUnmount' d m) $ removePathForcibly m
|
||||
mount MTPFS { mountpoint = m, description = d } True = umountNotify d m
|
||||
|
||||
-- | Need jmtpfs (assume fuse is also installed)
|
||||
allInstalled _ = isJust <$> findExecutable "jmtpfs"
|
||||
-- | return True always since the list won't even show without jmtpfs
|
||||
allInstalled _ = return True
|
||||
|
||||
-- | Return True if mounted. Only checks the mountpoint path
|
||||
isMounted MTPFS { mountpointMTP = m } = elem m . fmap snd <$> curMountpoints
|
||||
isMounted MTPFS { mountpoint = dir } = io $ isDirMounted dir
|
||||
|
||||
-- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH'
|
||||
fmtEntry MTPFS { description = d } = d
|
||||
|
||||
getMTPDevices :: IO [MTPFS]
|
||||
getMTPDevices = mapMaybe toDev . toDevList <$> readProcess "jmtpfs" ["-l"] ""
|
||||
getMTPDevices :: RofiIO MountConf [MTPFS]
|
||||
getMTPDevices = do
|
||||
dir <- asks mountDir
|
||||
res <- io $ readProcess "jmtpfs" ["-l"] ""
|
||||
return $ mapMaybe (toDev dir) $ toDevList res
|
||||
where
|
||||
toDevList = reverse
|
||||
. takeWhile (not . isPrefixOf "Available devices")
|
||||
. reverse
|
||||
. lines
|
||||
toDev s = case splitOn ", " s of
|
||||
toDev dir s = case splitOn ", " s of
|
||||
[busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc]
|
||||
in Just $ MTPFS
|
||||
{ bus = busNum
|
||||
, device = devNum
|
||||
, mountpointMTP = fuseMount ++ canonicalize d
|
||||
, mountpoint = dir </> canonicalize d
|
||||
, description = d
|
||||
}
|
||||
_ -> Nothing
|
||||
|
@ -351,108 +395,91 @@ getMTPDevices = mapMaybe toDev . toDevList <$> readProcess "jmtpfs" ["-l"] ""
|
|||
| c == ' ' = Just '-'
|
||||
| otherwise = Just c
|
||||
|
||||
getMTPActions :: IO RofiActions
|
||||
getMTPActions = toRofiActions <$> (mapM mkAction =<< getMTPDevices)
|
||||
|
||||
-- TODO add truecrypt volumes (see tcplay, will need root)
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Csv device parsing
|
||||
--
|
||||
-- These devices are stored in a CSV file which needs to be parsed into the
|
||||
-- appropriate devices types
|
||||
-- | Fstab devices
|
||||
|
||||
-- | Represents one parsable line in the network device config .tsv file
|
||||
data CsvDev = CsvDev
|
||||
{ csvLabel :: String
|
||||
, csvType :: String
|
||||
, csvPath :: String
|
||||
, csvMountpoint :: Maybe String
|
||||
, csvMountOptions :: Maybe String
|
||||
, csvCredentials :: Maybe String
|
||||
data FSTab = FSTab
|
||||
{ sshfsDevices :: [SSHFS]
|
||||
, cifsDevices :: [CIFS]
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance FromRecord CsvDev
|
||||
data FSTabEntry = FSTabEntry
|
||||
{ fstabSpec :: String
|
||||
, fstabDir :: FilePath
|
||||
, fstabType :: String
|
||||
, fstabOptions :: MountOptions
|
||||
}
|
||||
|
||||
-- | Return a list of all Csv lines from the network config file
|
||||
getCSV :: IO [CsvDev]
|
||||
getCSV = do
|
||||
xdgConf <- getEnv "XDG_CONFIG_HOME"
|
||||
-- TODO this shouldn't be hardcoded
|
||||
contents <- B.readFile $ xdgConf ++ "/rofi/devices.tsv"
|
||||
let opts = defaultDecodeOptions { decDelimiter = fromIntegral (ord '\t') }
|
||||
case decodeWith opts HasHeader contents of
|
||||
Left s -> putStrLn s >> return []
|
||||
Right v -> return $ toList (v :: Vector CsvDev)
|
||||
|
||||
-- TODO split this into each device type so they can be separated in the prompt
|
||||
-- | Given a parsed csv line from the network config file, return a
|
||||
-- (ENTRY, ACTION) where ENTRY is a string to appear on the Rofi prompt and
|
||||
-- ACTION is an action to perform on the device in the csv line when selected
|
||||
csvToAction :: CsvDev -> IO (Maybe (String, RofiPrompt ()))
|
||||
csvToAction CsvDev {..}
|
||||
| csvType == "cifs" = Just <$> mkAction (CIFS r' opts creds)
|
||||
| csvType == "sshfs" = Just <$> mkAction (SSHFS r opts)
|
||||
| otherwise = return Nothing
|
||||
readFSTab :: RofiIO MountConf FSTab
|
||||
readFSTab = do
|
||||
let i = FSTab { sshfsDevices = [], cifsDevices = [] }
|
||||
fstab <- io $ readFile "/etc/fstab"
|
||||
foldM addFstabDevice i $ mapMaybe toEntry $ lines fstab
|
||||
where
|
||||
r = Removable { label = csvLabel
|
||||
, path = csvPath
|
||||
, mountpoint = csvMountpoint
|
||||
}
|
||||
opts = maybe M.empty parseMountOptions csvMountOptions
|
||||
creds = maybe NoCredentials parseCredentials csvCredentials
|
||||
-- CIFS prefixes the path with two slashes
|
||||
r' = r { path = smartSlashPrefix csvPath }
|
||||
smartSlashPrefix s = if "//" `isPrefixOf` s then s else "//" ++ s
|
||||
toEntry line = case words $ stripWS line of
|
||||
(('#':_):_) -> Nothing
|
||||
[spec, dir, fsType, opts, _, _] -> Just $ FSTabEntry
|
||||
{ fstabSpec = spec
|
||||
, fstabDir = dir
|
||||
, fstabType = fsType
|
||||
, fstabOptions = parseMountOptions opts
|
||||
}
|
||||
_ -> Nothing
|
||||
|
||||
addFstabDevice :: FSTab -> FSTabEntry -> RofiIO MountConf FSTab
|
||||
addFstabDevice f@FSTab{..} e@FSTabEntry{..}
|
||||
| M.notMember "users" fstabOptions = return f
|
||||
| fstabType == "cifs" =
|
||||
(\d -> f { cifsDevices = cifsDevices ++ [d] }) <$> fstabToCIFS e
|
||||
| fstabType == "fuse.sshfs" =
|
||||
(\d -> f { sshfsDevices = sshfsDevices ++ [d] }) <$> fstabToSSHFS e
|
||||
| otherwise = return f
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Low-level mount functions
|
||||
|
||||
-- | Return a list of mountpoints like (PATH, MOUNTPOINT) from /proc/mount
|
||||
curMountpoints :: IO [(String, String)]
|
||||
curMountpoints = do
|
||||
m <- readFile "/proc/mounts"
|
||||
-- ASSUME this will never fail because the format of this file is fixed
|
||||
return $ (\(path:mntpnt:_) -> (path, mntpnt)) . words <$> lines m
|
||||
-- ASSUME these will never fail because the format of this file is fixed
|
||||
|
||||
-- | Given a path, return its mountpoint if it exists
|
||||
lookupMountpoint :: String -> IO (Maybe String)
|
||||
lookupMountpoint path = lookup path <$> curMountpoints
|
||||
curMountField :: Int -> IO [String]
|
||||
curMountField i = fmap ((!! i) . words) . lines <$> readFile "/proc/mounts"
|
||||
|
||||
-- | Given a removable device, unmount it using fuse
|
||||
fuseUnmount :: Removable -> IO ()
|
||||
fuseUnmount Removable { path = p, mountpoint = m, label = l } =
|
||||
maybe umountDef umount m
|
||||
curDeviceSpecs :: IO [String]
|
||||
curDeviceSpecs = curMountField 0
|
||||
|
||||
curMountpoints :: IO [String]
|
||||
curMountpoints = curMountField 1
|
||||
|
||||
mkDirMaybe :: FilePath -> RofiIO MountConf ()
|
||||
mkDirMaybe fp = whenInMountDir fp $ io $ createDirectoryIfMissing True fp
|
||||
|
||||
rmDirMaybe :: FilePath -> RofiIO MountConf ()
|
||||
rmDirMaybe fp = whenInMountDir fp $ unlessMountpoint fp
|
||||
$ asks mountDir >>= io . rmUntil fp
|
||||
where
|
||||
umount = fuseUnmount' l
|
||||
umountDef = lookupMountpoint p >>=
|
||||
mapM_ (liftM2 finally umount removePathForcibly)
|
||||
rmUntil cur target = unless (target == cur) $ do
|
||||
removePathForcibly cur
|
||||
rmUntil (takeDirectory cur) target
|
||||
|
||||
fuseUnmount' :: String -> String -> IO ()
|
||||
fuseUnmount' label path = do
|
||||
res <- readCmdEither "fusermount" ["-u", path] ""
|
||||
notifyMounted (isRight res) True label
|
||||
whenInMountDir :: FilePath -> RofiIO MountConf () -> RofiIO MountConf ()
|
||||
whenInMountDir fp f = do
|
||||
mDir <- asks mountDir
|
||||
when (mDir `isPrefixOf` fp) f
|
||||
|
||||
-- | Given credentials, return a password
|
||||
getPassword :: Credentials -> IO (Maybe String)
|
||||
getPassword NoCredentials = return Nothing
|
||||
getPassword (Secret kvs) = do
|
||||
let kvs' = concat [[a, b] | (a, b) <- M.toList kvs]
|
||||
readCmdSuccess "secret-tool" ("lookup":kvs') ""
|
||||
unlessMountpoint :: FilePath -> RofiIO MountConf () -> RofiIO MountConf ()
|
||||
unlessMountpoint fp f = do
|
||||
mounted <- io $ isDirMounted fp
|
||||
unless mounted f
|
||||
|
||||
-- TODO this shouldn't be hardcoded
|
||||
fuseMount :: FilePath
|
||||
fuseMount = "/media/ndwar-fuse/"
|
||||
umountNotify :: String -> FilePath -> RofiIO MountConf ()
|
||||
umountNotify label dir = finally cmd $ rmDirMaybe dir
|
||||
where
|
||||
cmd = io $ do
|
||||
res <- readCmdEither "umount" [dir] ""
|
||||
notifyMounted (isRight res) True label
|
||||
|
||||
-- TODO what if there is no trailing slash?
|
||||
fmtFusePath :: String -> String
|
||||
fmtFusePath label = fuseMount ++ label
|
||||
|
||||
makeFuseMount :: String -> IO ()
|
||||
makeFuseMount label = createDirectoryIfMissing False $ fmtFusePath label
|
||||
|
||||
destroyFuseMount :: String -> IO ()
|
||||
destroyFuseMount label = removePathForcibly $ fmtFusePath label
|
||||
isDirMounted :: FilePath -> IO Bool
|
||||
isDirMounted fp = elem fp <$> curMountpoints
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Other functions
|
||||
|
|
|
@ -5,126 +5,128 @@ module Rofi.Command
|
|||
, RofiMenu(..)
|
||||
, RofiAction
|
||||
, RofiActions
|
||||
, RofiPrompt
|
||||
, RofiIO
|
||||
, RofiGroup
|
||||
, Hotkey(..)
|
||||
, io
|
||||
, emptyMenu
|
||||
, runRofiPrompt
|
||||
, runRofiIO
|
||||
, toRofiActions
|
||||
, rofiActionKeys
|
||||
, untitledGroup
|
||||
, titledGroup
|
||||
, selectAction
|
||||
, readPassword
|
||||
, readCmdSuccess
|
||||
, readCmdEither
|
||||
, readCmdEither'
|
||||
, dmenuArgs
|
||||
, joinNewline
|
||||
, stripWS
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import qualified Data.Map.Ordered as M
|
||||
import qualified Data.Map.Ordered as M
|
||||
import Data.Maybe
|
||||
|
||||
import System.Exit
|
||||
import System.Process
|
||||
|
||||
newtype RofiConf = RofiConf
|
||||
{ defArgs :: [String]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
class RofiConf c where
|
||||
defArgs :: c -> [String]
|
||||
|
||||
type RofiAction = (String, RofiPrompt ())
|
||||
type RofiAction c = (String, RofiIO c ())
|
||||
|
||||
type RofiActions = M.OMap String (RofiPrompt ())
|
||||
type RofiActions c = M.OMap String (RofiIO c ())
|
||||
|
||||
data RofiGroup = RofiGroup
|
||||
{ actions :: RofiActions
|
||||
data RofiGroup c = RofiGroup
|
||||
{ actions :: RofiActions c
|
||||
, title :: Maybe String
|
||||
}
|
||||
|
||||
untitledGroup :: RofiActions -> RofiGroup
|
||||
untitledGroup :: RofiActions c -> RofiGroup c
|
||||
untitledGroup a = RofiGroup { actions = a, title = Nothing }
|
||||
|
||||
titledGroup :: String -> RofiActions -> RofiGroup
|
||||
titledGroup :: String -> RofiActions c -> RofiGroup c
|
||||
titledGroup t a = (untitledGroup a) { title = Just t }
|
||||
|
||||
data Hotkey = Hotkey
|
||||
data Hotkey c = Hotkey
|
||||
{ keyCombo :: String
|
||||
-- only 1-10 are valid
|
||||
, keyIndex :: Int
|
||||
, keyDescription :: String
|
||||
, keyActions :: RofiActions
|
||||
, keyActions :: RofiActions c
|
||||
}
|
||||
|
||||
hotkeyBinding :: Hotkey -> [String]
|
||||
hotkeyBinding :: Hotkey c -> [String]
|
||||
hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c]
|
||||
where
|
||||
k = "-kb-custom-" ++ show e
|
||||
|
||||
hotkeyMsg1 :: Hotkey -> String
|
||||
hotkeyMsg1 :: Hotkey c -> String
|
||||
hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } =
|
||||
c ++ ": <i>" ++ d ++ "</i>"
|
||||
|
||||
hotkeyMsg :: [Hotkey] -> [String]
|
||||
hotkeyMsg :: [Hotkey c] -> [String]
|
||||
hotkeyMsg [] = []
|
||||
hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs]
|
||||
|
||||
hotkeyArgs :: [Hotkey] -> [String]
|
||||
hotkeyArgs :: [Hotkey c] -> [String]
|
||||
hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
|
||||
|
||||
data RofiMenu = RofiMenu
|
||||
{ groups :: [RofiGroup]
|
||||
data RofiMenu c = RofiMenu
|
||||
{ groups :: [RofiGroup c]
|
||||
, prompt :: Maybe String
|
||||
, hotkeys :: [Hotkey]
|
||||
, hotkeys :: [Hotkey c]
|
||||
}
|
||||
|
||||
emptyMenu :: RofiMenu
|
||||
emptyMenu :: RofiMenu c
|
||||
emptyMenu = RofiMenu
|
||||
{ groups = []
|
||||
, prompt = Nothing
|
||||
, hotkeys = []
|
||||
}
|
||||
|
||||
newtype RofiPrompt a = RofiPrompt (ReaderT RofiConf IO a)
|
||||
deriving (Functor, Monad, MonadIO, MonadReader RofiConf)
|
||||
newtype RofiIO c a = RofiIO (ReaderT c IO a)
|
||||
deriving (Functor, Monad, MonadIO, MonadReader c, MonadUnliftIO)
|
||||
|
||||
instance Applicative RofiPrompt where
|
||||
instance Applicative (RofiIO c) where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
|
||||
io :: IO a -> RofiPrompt a
|
||||
io :: MonadIO m => IO a -> m a
|
||||
io = liftIO
|
||||
|
||||
runRofiPrompt :: RofiConf -> RofiPrompt a -> IO a
|
||||
runRofiPrompt c (RofiPrompt a) = runReaderT a c
|
||||
runRofiIO :: c -> RofiIO c a -> IO a
|
||||
runRofiIO c (RofiIO r) = runReaderT r c
|
||||
|
||||
toRofiActions :: [(String, RofiPrompt ())] -> RofiActions
|
||||
toRofiActions :: [(String, RofiIO c ())] -> RofiActions c
|
||||
toRofiActions = M.fromList
|
||||
|
||||
rofiActionKeys :: RofiActions -> String
|
||||
rofiActionKeys :: RofiActions c -> String
|
||||
rofiActionKeys = joinNewline . map fst . M.assocs
|
||||
|
||||
lookupRofiAction :: String -> RofiActions -> RofiPrompt ()
|
||||
lookupRofiAction :: String -> RofiActions c -> RofiIO c ()
|
||||
lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
|
||||
|
||||
groupEntries :: RofiGroup -> String
|
||||
groupEntries :: RofiGroup c -> String
|
||||
groupEntries RofiGroup { actions = a, title = t }
|
||||
| null a = ""
|
||||
| otherwise = title' ++ rofiActionKeys a
|
||||
where
|
||||
title' = maybe "" (++ "\n") t
|
||||
|
||||
menuActions :: RofiMenu -> RofiActions
|
||||
menuActions :: RofiMenu c -> RofiActions c
|
||||
menuActions = foldr1 (M.<>|) . fmap actions . groups
|
||||
|
||||
menuEntries :: RofiMenu -> String
|
||||
menuEntries :: RofiMenu c -> String
|
||||
menuEntries = intercalate "\n\n" . fmap groupEntries . groups
|
||||
|
||||
selectAction :: RofiMenu -> RofiPrompt ()
|
||||
selectAction :: RofiConf c => RofiMenu c -> RofiIO c ()
|
||||
selectAction rm = do
|
||||
let p = maybeOption "-p" $ prompt rm
|
||||
let hArgs = hotkeyArgs $ hotkeys rm
|
||||
|
@ -141,7 +143,9 @@ maybeOption switch = maybe [] (\o -> [switch, o])
|
|||
dmenuArgs :: [String]
|
||||
dmenuArgs = ["-dmenu"]
|
||||
|
||||
readRofi :: [String] -> String -> RofiPrompt (Either (Int, String, String) String)
|
||||
readRofi :: RofiConf c => [String]
|
||||
-> String
|
||||
-> RofiIO c (Either (Int, String, String) String)
|
||||
readRofi uargs input = do
|
||||
dargs <- asks defArgs
|
||||
io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
|
||||
|
@ -150,15 +154,35 @@ readCmdSuccess :: String -> [String] -> String -> IO (Maybe String)
|
|||
readCmdSuccess cmd args input = either (const Nothing) Just
|
||||
<$> readCmdEither cmd args input
|
||||
|
||||
readCmdEither :: String -> [String] -> String -> IO (Either (Int, String, String) String)
|
||||
readCmdEither cmd args input = do
|
||||
(ec, out, err) <- readProcessWithExitCode cmd args input
|
||||
return $ case ec of
|
||||
ExitSuccess -> Right $ stripWS out
|
||||
ExitFailure n -> Left (n, stripWS out, stripWS err)
|
||||
readCmdEither :: String
|
||||
-> [String]
|
||||
-> String
|
||||
-> IO (Either (Int, String, String) String)
|
||||
readCmdEither cmd args input = resultToEither
|
||||
<$> readProcessWithExitCode cmd args input
|
||||
|
||||
readCmdEither' :: String
|
||||
-> [String]
|
||||
-> String
|
||||
-> [(String, String)]
|
||||
-> IO (Either (Int, String, String) String)
|
||||
readCmdEither' cmd args input environ = resultToEither
|
||||
<$> readCreateProcessWithExitCode p input
|
||||
where
|
||||
p = (proc cmd args) { env = Just 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)
|
||||
|
||||
stripWS :: String -> String
|
||||
stripWS = reverse . dropWhile isSpace . reverse
|
||||
|
||||
joinNewline :: [String] -> String
|
||||
joinNewline = intercalate "\n"
|
||||
|
||||
readPassword :: IO (Maybe String)
|
||||
readPassword = readCmdSuccess "rofi" args ""
|
||||
where
|
||||
args = dmenuArgs ++ ["-p", "Password", "-password"]
|
||||
|
|
11
package.yaml
11
package.yaml
|
@ -23,16 +23,21 @@ dependencies:
|
|||
- process >= 1.6.5.0
|
||||
- aeson >= 1.4.5.0
|
||||
- unix-time >= 0.4.7
|
||||
- unix >= 2.7.2.2
|
||||
- dbus >= 1.2.7
|
||||
- ordered-containers >= 0.2.2
|
||||
- Clipboard >= 2.3.2.0
|
||||
- mtl >= 2.2.2
|
||||
- directory >= 1.3.3.0
|
||||
- cassava >= 0.5.2.0
|
||||
- bytestring >= 0.10.8.2
|
||||
- vector >= 0.12.0.3
|
||||
- regex-tdfa >= 1.2.3.2
|
||||
- split >= 0.2.3.4
|
||||
- split >= 0.2.3.3
|
||||
- containers >= 0.6.0.1
|
||||
- filepath >= 1.4.2.1
|
||||
- unliftio >= 0.2.12
|
||||
- unliftio-core >= 0.1.2.0
|
||||
# - cassava >= 0.5.2.0
|
||||
# - vector >= 0.12.0.3
|
||||
|
||||
library:
|
||||
source-dirs: lib/
|
||||
|
|
Loading…
Reference in New Issue