ndwarshuis
/
rofi-extras
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH generalize RofiIO monad

This commit is contained in:
Nathan Dwarshuis 2020-05-01 21:29:54 -04:00
parent 49c4f4cf1c
commit 7c1d899be6
4 changed files with 364 additions and 308 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
app/rofi-bitwarden.hs
View File

@ -61,7 +61,7 @@ checkExe cmd = do
-- --
-- The session ID will be valid only as long as TIMEOUT -- The session ID will be valid only as long as TIMEOUT
newtype BWConf = BWConf newtype BWServerConf = BWServerConf
{ timeout :: UnixDiffTime { timeout :: UnixDiffTime
} }
@ -75,15 +75,15 @@ type Session = MVar (Maybe CurrentSession)
runDaemon :: Int -> IO () runDaemon :: Int -> IO ()
runDaemon t = do runDaemon t = do
ses <- newMVar Nothing ses <- newMVar Nothing
let c = BWConf { timeout = UnixDiffTime (fromIntegral t) 0 } let c = BWServerConf { timeout = UnixDiffTime (fromIntegral t) 0 }
startService c ses startService c ses
forever $ threadDelay 1000000 forever $ threadDelay 1000000
lockSession :: Session -> IO () lockSession :: Session -> IO ()
lockSession ses = void $ swapMVar ses Nothing lockSession ses = void $ swapMVar ses Nothing
getSession :: BWConf -> Session -> IO String getSession :: BWServerConf -> Session -> IO String
getSession BWConf { timeout = t } ses = do getSession BWServerConf { timeout = t } ses = do
ut <- getUnixTime ut <- getUnixTime
modifyMVar ses $ \s -> case s of modifyMVar ses $ \s -> case s of
Just CurrentSession { timestamp = ts, hash = h } -> Just CurrentSession { timestamp = ts, hash = h } ->
@ -98,11 +98,6 @@ getSession BWConf { timeout = t } ses = do
ut <- getUnixTime ut <- getUnixTime
return CurrentSession { timestamp = ut, hash = h } 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 :: String -> IO (Maybe String)
readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] "" readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
@ -122,10 +117,15 @@ readSession pwd = readCmdSuccess "bw" ["unlock", pwd, "--raw"] ""
-- - password (if applicable) -> copy to clipboard -- - password (if applicable) -> copy to clipboard
-- - anything else (notes and such) -> copy to clipboard -- - anything else (notes and such) -> copy to clipboard
newtype BWClientConf = BWClientConf [String]
instance RofiConf BWClientConf where
defArgs (BWClientConf a) = a
runClient :: [String] -> IO () runClient :: [String] -> IO ()
runClient a = do runClient a = do
let c = RofiConf { defArgs = a } let c = BWClientConf a
runRofiPrompt c $ selectAction $ emptyMenu runRofiIO c $ selectAction $ emptyMenu
{ groups = [untitledGroup $ toRofiActions ras] { groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Action" , prompt = Just "Action"
} }
@ -134,12 +134,12 @@ runClient a = do
, ("Lock Session", io callLockSession) , ("Lock Session", io callLockSession)
] ]
browseLogins :: RofiPrompt () browseLogins :: RofiConf c => RofiIO c ()
browseLogins = do browseLogins = do
session <- io callGetSession session <- io callGetSession
forM_ session $ getItems >=> selectItem forM_ session $ getItems >=> selectItem
getItems :: String -> RofiPrompt [Item] getItems :: RofiConf c => String -> RofiIO c [Item]
getItems session = do getItems session = do
items <- io $ readProcess "bw" ["list", "items", "--session", session] "" items <- io $ readProcess "bw" ["list", "items", "--session", session] ""
return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items return $ filter notEmpty $ fromMaybe [] $ decode $ fromString items
@ -170,16 +170,16 @@ instance FromJSON Login
-- TODO make menu buttons here to go back and to copy without leaving -- TODO make menu buttons here to go back and to copy without leaving
-- the current menu -- the current menu
selectItem :: [Item] -> RofiPrompt () selectItem :: RofiConf c => [Item] -> RofiIO c ()
selectItem items = selectAction $ emptyMenu selectItem items = selectAction $ emptyMenu
{ groups = [untitledGroup $ itemsToRofiActions items] { groups = [untitledGroup $ itemsToRofiActions items]
, prompt = Just "Login" , prompt = Just "Login"
} }
itemsToRofiActions :: [Item] -> RofiActions itemsToRofiActions :: RofiConf c => [Item] -> RofiActions c
itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i)) itemsToRofiActions = toRofiActions . fmap (\i -> (name i, selectCopy $ login i))
selectCopy :: Login -> RofiPrompt () selectCopy :: RofiConf c => Login -> RofiIO c ()
selectCopy l = selectAction $ emptyMenu selectCopy l = selectAction $ emptyMenu
{ groups = [untitledGroup $ loginToRofiActions l copy] { groups = [untitledGroup $ loginToRofiActions l copy]
, prompt = Just "Copy" , prompt = Just "Copy"
@ -203,7 +203,7 @@ selectCopy l = selectAction $ emptyMenu
, keyActions = loginToRofiActions l (const browseLogins) , 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 = loginToRofiActions Login { username = u, password = p } a =
toRofiActions $ catMaybes [user, pwd] toRofiActions $ catMaybes [user, pwd]
where where
@ -231,7 +231,7 @@ memGetSession = "GetSession"
memLockSession :: MemberName memLockSession :: MemberName
memLockSession = "LockSession" memLockSession = "LockSession"
startService :: BWConf -> Session -> IO () startService :: BWServerConf -> Session -> IO ()
startService c ses = do startService c ses = do
client <- connectSession client <- connectSession
let flags = [nameAllowReplacement, nameReplaceExisting] let flags = [nameAllowReplacement, nameReplaceExisting]

515
app/rofi-devices.hs
View File

@ -1,63 +1,145 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Main (main) where module Main (main) where
import Control.Exception
import Control.Monad 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.Either
import Data.List import Data.List
import Data.List.Split (splitOn) import Data.List.Split (splitOn)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Map.Ordered as O import qualified Data.Map.Ordered as O
import Data.Maybe import Data.Maybe
import Data.Vector (Vector, toList)
import GHC.Generics (Generic)
import Rofi.Command import Rofi.Command
import Text.Printf import Text.Printf
import Text.Regex.TDFA import Text.Regex.TDFA
import System.Console.GetOpt
import System.Directory import System.Directory
import System.Environment import System.Environment
import System.FilePath.Posix
import System.Posix.User (getEffectiveUserName)
import System.Process import System.Process
import UnliftIO.Exception
main :: IO () main :: IO ()
main = check >> getArgs >>= parse 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 :: [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 -- TODO
check :: IO () check :: IO ()
check = return () check = return ()
runMounts :: [String] -> IO () runMounts :: MountConf -> IO ()
runMounts a = do runMounts c = runRofiIO c $ runPrompt =<< getGroups
let c = RofiConf { defArgs = a }
runRofiPrompt c runPrompt
runPrompt :: RofiPrompt () runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
runPrompt = do runPrompt gs = selectAction $ emptyMenu
net <- titledGroup "Network Devices" <$> io getNetActions { groups = gs
rmv <- titledGroup "Removable Devices" <$> io getRemovableActions , prompt = Just "Select Device"
mtp <- titledGroup "MTP Devices" <$> io getMTPActions }
selectAction $ emptyMenu
{ groups = [net, rmv, mtp]
, prompt = Just "Select Device"
}
getNetActions :: IO RofiActions getGroups :: RofiIO MountConf [RofiGroup MountConf]
getNetActions = alignEntries . toRofiActions . catMaybes getGroups = do
<$> (mapM csvToAction =<< getCSV) 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 :: String
alignSep = " | " alignSep = " | "
@ -65,7 +147,7 @@ alignSep = " | "
alignSepPre :: String alignSepPre :: String
alignSepPre = "@@@" alignSepPre = "@@@"
alignEntries :: RofiActions -> RofiActions alignEntries :: RofiActions c -> RofiActions c
alignEntries = O.fromList . withKeys . O.assocs alignEntries = O.fromList . withKeys . O.assocs
where where
withKeys as = let (ks, vs) = unzip as in zip (align ks) vs 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 and methods for type representing mountable devices
class Mountable a where class Mountable a where
-- | Mount the given type (or dismount if False is passed) -- | 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 -- | 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 -- | Return a string to go in the Rofi menu for the given type
fmtEntry :: a -> String fmtEntry :: a -> String
-- | Determine if the given type is mounted or not -- | 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 -- | Given a mountable type, return a rofi action (string to go in the
-- Rofi prompt and an action to perform when it is selected) -- 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 mkAction dev = do
m <- isMounted dev m <- isMounted dev
i <- allInstalled 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 let s = mountedPrefix m i ++ fmtEntry dev
return (s, a) return (s, a)
where where
@ -121,99 +203,62 @@ parseMountOptions s = M.fromList $ toCell . splitEq <$> splitBy ',' s
toCell (k, "=", v) = (k, Just v) toCell (k, "=", v) = (k, Just v)
toCell (k, _, _) = (k, Nothing) toCell (k, _, _) = (k, Nothing)
-- | Given a mount options map, return a string of comma separated items -- -- | Given a mount options map, return a string of comma separated items
fmtMountOptions :: MountOptions -> String -- fmtMountOptions :: MountOptions -> String
fmtMountOptions = intercalate "," . fmap fromCell . M.toList -- fmtMountOptions = intercalate "," . fmap fromCell . M.toList
where -- where
fromCell (k, Just v) = k ++ "=" ++ v -- fromCell (k, Just v) = k ++ "=" ++ v
fromCell (k, Nothing) = k -- 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
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Removable devices -- | Removable devices
-- --
-- A device which can be removed (which is all the devices we care about) -- 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 -- This can be minimally described by a device DEVICESPEC and LABEL.
-- Nothing, this represents the device being mounted at a default location.
data Removable = Removable data Removable = Removable
{ path :: String { deviceSpec :: String
, label :: String , label :: String
, mountpoint :: Maybe String
} }
deriving (Eq, Show) deriving (Eq, Show)
instance Mountable Removable where instance Mountable Removable where
-- | (Un)mount the device using udiskctl -- | (Un)mount the device using udiskctl
mount Removable { path = p, label = l } m = do mount Removable { deviceSpec = d, label = l } m = io $ do
res <- readCmdEither "udisksctl" [cmd, "-b", p] "" res <- readCmdEither "udisksctl" [cmd, "-b", d] ""
notifyMounted (isRight res) m l notifyMounted (isRight res) m l
where where
cmd = if m then "unmount" else "mount" cmd = if m then "unmount" else "mount"
-- | Need udisksctl to mount and umount -- | 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 -- | Check if the device is mounted using /proc/mount
isMounted Removable { path = p, mountpoint = m } = do isMounted Removable { deviceSpec = d } = elem d <$> io curDeviceSpecs
cur <- curMountpoints
return $ case m of
Just m' -> (p, m') `elem` cur
Nothing -> p `elem` fmap fst cur
-- | Format the Rofi entry like 'LABEL - PATH' and add a star in the front -- | Format the Rofi entry like 'LABEL - PATH' and add a star in the front
-- if the device is mounted -- 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 -- | Return list of possible rofi actions for removable devices
-- A 'removable device' is defined as a hotplugged device with a filesystem as -- 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 -- reported by 'lsblk'. If the LABEL does not exist on the filesystem, the
-- label shown on the prompt will be 'SIZE Volume' where size is the size of -- label shown on the prompt will be 'SIZE Volume' where size is the size of
-- the device -- the device
getRemovableDevices :: IO [Removable] getRemovableDevices :: RofiConf c => RofiIO c [Removable]
getRemovableDevices = mapMaybe toDev getRemovableDevices = mapMaybe toDev
. lines . lines
. stripWS . stripWS
<$> readProcess "lsblk" ["-n", "-r", "-o", columns] "" <$> io (readProcess "lsblk" ["-n", "-r", "-o", columns] "")
where where
columns = "FSTYPE,HOTPLUG,PATH,LABEL,SIZE" columns = "FSTYPE,HOTPLUG,PATH,LABEL,SIZE"
-- can't use 'words' here since it will drop spaces in the front -- can't use 'words' here since it will drop spaces in the front
toDev line = case splitBy ' ' line of toDev line = case splitBy ' ' line of
("":_) -> Nothing ("":_) -> Nothing
[_, "1", p, "", s] -> mk p $ s ++ " Volume" [_, "1", d, "", s] -> mk d $ s ++ " Volume"
[_, "1", p, l, _] -> mk p l [_, "1", d, l, _] -> mk d l
_ -> Nothing _ -> Nothing
mk p l = Just $ Removable { path = p mk d l = Just $ Removable { deviceSpec = d, label = l }
, label = l
, mountpoint = Nothing
}
getRemovableActions :: IO RofiActions
getRemovableActions = alignEntries . toRofiActions
<$> (mapM mkAction =<< getRemovableDevices)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | CIFS Devices -- | CIFS Devices
@ -221,34 +266,46 @@ getRemovableActions = alignEntries . toRofiActions
-- This wraps the Removable device (since it is removable) and also adds its -- This wraps the Removable device (since it is removable) and also adds its
-- own mount options and credentials for authentication. -- own mount options and credentials for authentication.
data CIFS = CIFS Removable MountOptions Credentials data CIFS = CIFS Removable FilePath (Maybe Password)
instance Mountable CIFS where instance Mountable CIFS where
-- | Mount using udevil mount (CIFS Removable{ label = l } m getPwd) False =
mount (CIFS Removable{..} opts creds) False = do bracketOnError_
pwd <- getPassword creds (mkDirMaybe m)
let opts' = fmtOpts $ addPwd pwd opts (rmDirMaybe m)
res <- readCmdEither "udevil" (["mount"] ++ opts' ++ ["-t", "cifs", path]) "" $ io $ do
notifyMounted (isRight res) False label res <- case getPwd of
where Just pwd -> do
addPwd (Just pwd) o = M.insert "password" (Just pwd) o p <- maybe [] (\p -> [("PASSWD", p)]) <$> pwd
addPwd Nothing o = o readCmdEither' "mount" [m] "" p
fmtOpts o = if null o then [] else ["-o", fmtMountOptions o] Nothing -> readCmdEither "mount" [m] ""
notifyMounted (isRight res) False l
-- | Unmount using udevil mount (CIFS Removable{ label = l } m _) True = umountNotify l m
mount (CIFS Removable{..} _ _) True = do
res <- readCmdEither "udevil" ["unmount", path] ""
notifyMounted (isRight res) True label
-- | Need udevil and mount.cifs allInstalled _ = io $ isJust <$> findExecutable "mount.cifs"
allInstalled _ = all isJust <$> mapM findExecutable ["udevil", "mount.cifs"]
-- | Return True if mounted. Only checks the removable type wrapped within isMounted (CIFS _ dir _) = io $ isDirMounted dir
isMounted (CIFS r _ _) = isMounted r
-- | Format the Rofi entry like 'LABEL - (CIFS) - PATH' and prefix with a star fmtEntry (CIFS r _ _) = fmtEntry r
-- if mounted
fmtEntry (CIFS r _ _) = fmtNetEntry r "CIFS" -- 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 -- | SSHFS Devices
@ -258,90 +315,77 @@ instance Mountable CIFS where
-- config that specifies the port, hostname, user, and identity file, these -- config that specifies the port, hostname, user, and identity file, these
-- need to be passed as mount options. -- need to be passed as mount options.
data SSHFS = SSHFS Removable MountOptions data SSHFS = SSHFS Removable FilePath
instance Mountable SSHFS where instance Mountable SSHFS where
-- | Mount using sshfs mount (SSHFS Removable{ label = l } m) False =
mount (SSHFS Removable{..} opts) False = bracketOnError_
case mountpoint of (mkDirMaybe m)
Just m -> cmd m (rmDirMaybe m)
-- TODO only destroy mountpoint if it is not already another mountpoint $ io $ do
Nothing -> bracketOnError (makeFuseMount label) res <- readCmdEither "mount" [m] ""
(const $ destroyFuseMount label) (const $ cmd $ fmtFusePath label) notifyMounted (isRight res) False l
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
-- | Umount using fusermount mount (SSHFS Removable{ label = l } m) True = umountNotify l m
mount (SSHFS r _) True = fuseUnmount r
-- | Need sshfs (assume fuse is also installed) allInstalled _ = fmap isJust $ io $ findExecutable "sshfs"
allInstalled _ = isJust <$> findExecutable "sshfs"
-- | Return True if mounted. Only checks the removable type wrapped within isMounted (SSHFS _ dir) = io $ isDirMounted dir
isMounted (SSHFS r _) = isMounted r
-- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH' and prefix with a fmtEntry (SSHFS r _) = fmtEntry r
-- star if mounted
fmtEntry (SSHFS r _) = fmtNetEntry r "SSHFS"
-- | Given a removable device, type string, and boolean for if the device is fstabToSSHFS :: FSTabEntry -> RofiIO MountConf SSHFS
-- mounted, return a string like 'LABEL - (TYPESTRING) - PATH' and prefix with a fstabToSSHFS FSTabEntry{ fstabSpec = s, fstabDir = d } = return $ SSHFS r d
-- star if mounted where
fmtNetEntry :: Removable -> String -> String r = Removable { deviceSpec = s, label = takeFileName d }
fmtNetEntry Removable { label = l, path = p } t =
intercalate alignSepPre [l, t, p]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | MTP devices -- | MTP devices
data MTPFS = MTPFS data MTPFS = MTPFS
{ bus :: String { bus :: String
, device :: String , device :: String
, mountpointMTP :: String , mountpoint :: FilePath
, description :: String , description :: String
} }
deriving (Eq, Show) deriving (Eq, Show)
instance Mountable MTPFS where instance Mountable MTPFS where
-- | Mount using sshfs
mount MTPFS {..} False = do mount MTPFS {..} False = do
-- TODO add autodismount to options -- TODO add autodismount to options
let dev = "-device=" ++ bus ++ "," ++ device let dev = "-device=" ++ bus ++ "," ++ device
bracketOnError (createDirectoryIfMissing False mountpointMTP) bracketOnError_
(const $ removePathForcibly mountpointMTP) $ \_ -> do (mkDirMaybe mountpoint)
res <- readCmdEither "jmtpfs" [dev, mountpointMTP] "" (rmDirMaybe mountpoint)
$ io $ do
res <- readCmdEither "jmtpfs" [dev, mountpoint] ""
notifyMounted (isRight res) False description notifyMounted (isRight res) False description
-- | Umount using fusermount mount MTPFS { mountpoint = m, description = d } True = umountNotify d m
mount MTPFS { mountpointMTP = m, description = d } True =
finally (fuseUnmount' d m) $ removePathForcibly m
-- | Need jmtpfs (assume fuse is also installed) -- | return True always since the list won't even show without jmtpfs
allInstalled _ = isJust <$> findExecutable "jmtpfs" allInstalled _ = return True
-- | Return True if mounted. Only checks the mountpoint path isMounted MTPFS { mountpoint = dir } = io $ isDirMounted dir
isMounted MTPFS { mountpointMTP = m } = elem m . fmap snd <$> curMountpoints
-- | Format the Rofi entry like 'LABEL - (SSHFS) - PATH'
fmtEntry MTPFS { description = d } = d fmtEntry MTPFS { description = d } = d
getMTPDevices :: IO [MTPFS] getMTPDevices :: RofiIO MountConf [MTPFS]
getMTPDevices = mapMaybe toDev . toDevList <$> readProcess "jmtpfs" ["-l"] "" getMTPDevices = do
dir <- asks mountDir
res <- io $ readProcess "jmtpfs" ["-l"] ""
return $ mapMaybe (toDev dir) $ toDevList res
where where
toDevList = reverse toDevList = reverse
. takeWhile (not . isPrefixOf "Available devices") . takeWhile (not . isPrefixOf "Available devices")
. reverse . reverse
. lines . lines
toDev s = case splitOn ", " s of toDev dir s = case splitOn ", " s of
[busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc] [busNum, devNum, _, _, desc, vendor] -> let d = unwords [vendor, desc]
in Just $ MTPFS in Just $ MTPFS
{ bus = busNum { bus = busNum
, device = devNum , device = devNum
, mountpointMTP = fuseMount ++ canonicalize d , mountpoint = dir </> canonicalize d
, description = d , description = d
} }
_ -> Nothing _ -> Nothing
@ -351,108 +395,91 @@ getMTPDevices = mapMaybe toDev . toDevList <$> readProcess "jmtpfs" ["-l"] ""
| c == ' ' = Just '-' | c == ' ' = Just '-'
| otherwise = Just c | otherwise = Just c
getMTPActions :: IO RofiActions
getMTPActions = toRofiActions <$> (mapM mkAction =<< getMTPDevices)
-- TODO add truecrypt volumes (see tcplay, will need root) -- TODO add truecrypt volumes (see tcplay, will need root)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Csv device parsing -- | Fstab devices
--
-- These devices are stored in a CSV file which needs to be parsed into the
-- appropriate devices types
-- | Represents one parsable line in the network device config .tsv file data FSTab = FSTab
data CsvDev = CsvDev { sshfsDevices :: [SSHFS]
{ csvLabel :: String , cifsDevices :: [CIFS]
, csvType :: String
, csvPath :: String
, csvMountpoint :: Maybe String
, csvMountOptions :: Maybe String
, csvCredentials :: Maybe String
} }
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 readFSTab :: RofiIO MountConf FSTab
getCSV :: IO [CsvDev] readFSTab = do
getCSV = do let i = FSTab { sshfsDevices = [], cifsDevices = [] }
xdgConf <- getEnv "XDG_CONFIG_HOME" fstab <- io $ readFile "/etc/fstab"
-- TODO this shouldn't be hardcoded foldM addFstabDevice i $ mapMaybe toEntry $ lines fstab
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
where where
r = Removable { label = csvLabel toEntry line = case words $ stripWS line of
, path = csvPath (('#':_):_) -> Nothing
, mountpoint = csvMountpoint [spec, dir, fsType, opts, _, _] -> Just $ FSTabEntry
} { fstabSpec = spec
opts = maybe M.empty parseMountOptions csvMountOptions , fstabDir = dir
creds = maybe NoCredentials parseCredentials csvCredentials , fstabType = fsType
-- CIFS prefixes the path with two slashes , fstabOptions = parseMountOptions opts
r' = r { path = smartSlashPrefix csvPath } }
smartSlashPrefix s = if "//" `isPrefixOf` s then s else "//" ++ s _ -> 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 -- | Low-level mount functions
-- | Return a list of mountpoints like (PATH, MOUNTPOINT) from /proc/mount -- ASSUME these will never fail because the format of this file is fixed
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
-- | Given a path, return its mountpoint if it exists curMountField :: Int -> IO [String]
lookupMountpoint :: String -> IO (Maybe String) curMountField i = fmap ((!! i) . words) . lines <$> readFile "/proc/mounts"
lookupMountpoint path = lookup path <$> curMountpoints
-- | Given a removable device, unmount it using fuse curDeviceSpecs :: IO [String]
fuseUnmount :: Removable -> IO () curDeviceSpecs = curMountField 0
fuseUnmount Removable { path = p, mountpoint = m, label = l } =
maybe umountDef umount m 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 where
umount = fuseUnmount' l rmUntil cur target = unless (target == cur) $ do
umountDef = lookupMountpoint p >>= removePathForcibly cur
mapM_ (liftM2 finally umount removePathForcibly) rmUntil (takeDirectory cur) target
fuseUnmount' :: String -> String -> IO () whenInMountDir :: FilePath -> RofiIO MountConf () -> RofiIO MountConf ()
fuseUnmount' label path = do whenInMountDir fp f = do
res <- readCmdEither "fusermount" ["-u", path] "" mDir <- asks mountDir
notifyMounted (isRight res) True label when (mDir `isPrefixOf` fp) f
-- | Given credentials, return a password unlessMountpoint :: FilePath -> RofiIO MountConf () -> RofiIO MountConf ()
getPassword :: Credentials -> IO (Maybe String) unlessMountpoint fp f = do
getPassword NoCredentials = return Nothing mounted <- io $ isDirMounted fp
getPassword (Secret kvs) = do unless mounted f
let kvs' = concat [[a, b] | (a, b) <- M.toList kvs]
readCmdSuccess "secret-tool" ("lookup":kvs') ""
-- TODO this shouldn't be hardcoded umountNotify :: String -> FilePath -> RofiIO MountConf ()
fuseMount :: FilePath umountNotify label dir = finally cmd $ rmDirMaybe dir
fuseMount = "/media/ndwar-fuse/" where
cmd = io $ do
res <- readCmdEither "umount" [dir] ""
notifyMounted (isRight res) True label
-- TODO what if there is no trailing slash? isDirMounted :: FilePath -> IO Bool
fmtFusePath :: String -> String isDirMounted fp = elem fp <$> curMountpoints
fmtFusePath label = fuseMount ++ label
makeFuseMount :: String -> IO ()
makeFuseMount label = createDirectoryIfMissing False $ fmtFusePath label
destroyFuseMount :: String -> IO ()
destroyFuseMount label = removePathForcibly $ fmtFusePath label
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Other functions -- | Other functions

110
lib/Rofi/Command.hs
View File

@ -5,126 +5,128 @@ module Rofi.Command
, RofiMenu(..) , RofiMenu(..)
, RofiAction , RofiAction
, RofiActions , RofiActions
, RofiPrompt , RofiIO
, RofiGroup
, Hotkey(..) , Hotkey(..)
, io , io
, emptyMenu , emptyMenu
, runRofiPrompt , runRofiIO
, toRofiActions , toRofiActions
, rofiActionKeys , rofiActionKeys
, untitledGroup , untitledGroup
, titledGroup , titledGroup
, selectAction , selectAction
, readPassword
, readCmdSuccess , readCmdSuccess
, readCmdEither , readCmdEither
, readCmdEither'
, dmenuArgs , dmenuArgs
, joinNewline , joinNewline
, stripWS , stripWS
) where ) where
import Control.Monad.IO.Unlift
import Control.Monad.Reader import Control.Monad.Reader
import Data.Char import Data.Char
import Data.List import Data.List
import qualified Data.Map.Ordered as M import qualified Data.Map.Ordered as M
import Data.Maybe import Data.Maybe
import System.Exit import System.Exit
import System.Process import System.Process
newtype RofiConf = RofiConf class RofiConf c where
{ defArgs :: [String] defArgs :: c -> [String]
}
deriving (Eq, Show)
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 data RofiGroup c = RofiGroup
{ actions :: RofiActions { actions :: RofiActions c
, title :: Maybe String , title :: Maybe String
} }
untitledGroup :: RofiActions -> RofiGroup untitledGroup :: RofiActions c -> RofiGroup c
untitledGroup a = RofiGroup { actions = a, title = Nothing } 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 } titledGroup t a = (untitledGroup a) { title = Just t }
data Hotkey = Hotkey data Hotkey c = Hotkey
{ keyCombo :: String { keyCombo :: String
-- only 1-10 are valid -- only 1-10 are valid
, keyIndex :: Int , keyIndex :: Int
, keyDescription :: String , keyDescription :: String
, keyActions :: RofiActions , keyActions :: RofiActions c
} }
hotkeyBinding :: Hotkey -> [String] hotkeyBinding :: Hotkey c -> [String]
hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c] hotkeyBinding Hotkey { keyIndex = e, keyCombo = c } = [k, c]
where where
k = "-kb-custom-" ++ show e k = "-kb-custom-" ++ show e
hotkeyMsg1 :: Hotkey -> String hotkeyMsg1 :: Hotkey c -> String
hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } = hotkeyMsg1 Hotkey { keyCombo = c, keyDescription = d } =
c ++ ": <i>" ++ d ++ "</i>" c ++ ": <i>" ++ d ++ "</i>"
hotkeyMsg :: [Hotkey] -> [String] hotkeyMsg :: [Hotkey c] -> [String]
hotkeyMsg [] = [] hotkeyMsg [] = []
hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs] hotkeyMsg hs = ["-mesg", intercalate " | " $ fmap hotkeyMsg1 hs]
hotkeyArgs :: [Hotkey] -> [String] hotkeyArgs :: [Hotkey c] -> [String]
hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
data RofiMenu = RofiMenu data RofiMenu c = RofiMenu
{ groups :: [RofiGroup] { groups :: [RofiGroup c]
, prompt :: Maybe String , prompt :: Maybe String
, hotkeys :: [Hotkey] , hotkeys :: [Hotkey c]
} }
emptyMenu :: RofiMenu emptyMenu :: RofiMenu c
emptyMenu = RofiMenu emptyMenu = RofiMenu
{ groups = [] { groups = []
, prompt = Nothing , prompt = Nothing
, hotkeys = [] , hotkeys = []
} }
newtype RofiPrompt a = RofiPrompt (ReaderT RofiConf IO a) newtype RofiIO c a = RofiIO (ReaderT c IO a)
deriving (Functor, Monad, MonadIO, MonadReader RofiConf) deriving (Functor, Monad, MonadIO, MonadReader c, MonadUnliftIO)
instance Applicative RofiPrompt where instance Applicative (RofiIO c) where
pure = return pure = return
(<*>) = ap (<*>) = ap
io :: IO a -> RofiPrompt a io :: MonadIO m => IO a -> m a
io = liftIO io = liftIO
runRofiPrompt :: RofiConf -> RofiPrompt a -> IO a runRofiIO :: c -> RofiIO c a -> IO a
runRofiPrompt c (RofiPrompt a) = runReaderT a c runRofiIO c (RofiIO r) = runReaderT r c
toRofiActions :: [(String, RofiPrompt ())] -> RofiActions toRofiActions :: [(String, RofiIO c ())] -> RofiActions c
toRofiActions = M.fromList toRofiActions = M.fromList
rofiActionKeys :: RofiActions -> String rofiActionKeys :: RofiActions c -> String
rofiActionKeys = joinNewline . map fst . M.assocs 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 lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
groupEntries :: RofiGroup -> String groupEntries :: RofiGroup c -> String
groupEntries RofiGroup { actions = a, title = t } groupEntries RofiGroup { actions = a, title = t }
| null a = "" | null a = ""
| otherwise = title' ++ rofiActionKeys a | otherwise = title' ++ rofiActionKeys a
where where
title' = maybe "" (++ "\n") t title' = maybe "" (++ "\n") t
menuActions :: RofiMenu -> RofiActions menuActions :: RofiMenu c -> RofiActions c
menuActions = foldr1 (M.<>|) . fmap actions . groups menuActions = foldr1 (M.<>|) . fmap actions . groups
menuEntries :: RofiMenu -> String menuEntries :: RofiMenu c -> String
menuEntries = intercalate "\n\n" . fmap groupEntries . groups menuEntries = intercalate "\n\n" . fmap groupEntries . groups
selectAction :: RofiMenu -> RofiPrompt () selectAction :: RofiConf c => RofiMenu c -> RofiIO c ()
selectAction rm = do selectAction rm = do
let p = maybeOption "-p" $ prompt rm let p = maybeOption "-p" $ prompt rm
let hArgs = hotkeyArgs $ hotkeys rm let hArgs = hotkeyArgs $ hotkeys rm
@ -141,7 +143,9 @@ maybeOption switch = maybe [] (\o -> [switch, o])
dmenuArgs :: [String] dmenuArgs :: [String]
dmenuArgs = ["-dmenu"] 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 readRofi uargs input = do
dargs <- asks defArgs dargs <- asks defArgs
io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input 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 readCmdSuccess cmd args input = either (const Nothing) Just
<$> readCmdEither cmd args input <$> readCmdEither cmd args input
readCmdEither :: String -> [String] -> String -> IO (Either (Int, String, String) String) readCmdEither :: String
readCmdEither cmd args input = do -> [String]
(ec, out, err) <- readProcessWithExitCode cmd args input -> String
return $ case ec of -> IO (Either (Int, String, String) String)
ExitSuccess -> Right $ stripWS out readCmdEither cmd args input = resultToEither
ExitFailure n -> Left (n, stripWS out, stripWS err) <$> 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 :: String -> String
stripWS = reverse . dropWhile isSpace . reverse stripWS = reverse . dropWhile isSpace . reverse
joinNewline :: [String] -> String joinNewline :: [String] -> String
joinNewline = intercalate "\n" joinNewline = intercalate "\n"
readPassword :: IO (Maybe String)
readPassword = readCmdSuccess "rofi" args ""
where
args = dmenuArgs ++ ["-p", "Password", "-password"]

11
package.yaml
View File

@ -23,16 +23,21 @@ dependencies:
- process >= 1.6.5.0 - process >= 1.6.5.0
- aeson >= 1.4.5.0 - aeson >= 1.4.5.0
- unix-time >= 0.4.7 - unix-time >= 0.4.7
- unix >= 2.7.2.2
- dbus >= 1.2.7 - dbus >= 1.2.7
- ordered-containers >= 0.2.2 - ordered-containers >= 0.2.2
- Clipboard >= 2.3.2.0 - Clipboard >= 2.3.2.0
- mtl >= 2.2.2 - mtl >= 2.2.2
- directory >= 1.3.3.0 - directory >= 1.3.3.0
- cassava >= 0.5.2.0
- bytestring >= 0.10.8.2 - bytestring >= 0.10.8.2
- vector >= 0.12.0.3
- regex-tdfa >= 1.2.3.2 - 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: library:
source-dirs: lib/ source-dirs: lib/