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

WIP use trees for staic config

This commit is contained in:
Nathan Dwarshuis 2021-03-22 19:20:32 -04:00
parent a033b673e0
commit 0fcf836d1d
1 changed files with 177 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

396
app/rofi-dev.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | rofi-dev - a rofi prompt for mountable devices -- | rofi-dev - a rofi prompt for mountable devices
@ -19,7 +20,7 @@ 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 qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector as V import qualified Data.Vector as V
@ -134,47 +135,54 @@ instance FromJSON PasswordConfig where
<*> o .:? "libsecret" <*> o .:? "libsecret"
<*> o .:? "prompt" <*> o .:? "prompt"
data DeviceConfig = VeracryptConfig data DataConfig = VeracryptConfig
{ _veracryptMount :: MountConfig { _veracryptVolume :: String
, _veracryptVolume :: String
, _veracryptDepends :: V.Vector String
, _veracryptPassword :: Maybe PasswordConfig , _veracryptPassword :: Maybe PasswordConfig
} | SSHFSConfig } | SSHFSConfig
{ _sshfsMount :: MountConfig { _sshfsRemote :: String
, _sshfsRemote :: String
, _sshfsDepends :: V.Vector String
} | CIFSConfig } | CIFSConfig
{ _cifsMount :: MountConfig { _cifsRemote :: String
, _cifsRemote :: String
, _cifsDepends :: V.Vector String
, _cifsPassword :: Maybe PasswordConfig , _cifsPassword :: Maybe PasswordConfig
} deriving Show } deriving Show
instance FromJSON DeviceConfig where data DeviceConfig = DeviceConfig
{ _deviceMount :: MountConfig
, _deviceData :: DataConfig
} deriving Show
data TreeConfig = TreeConfig
{ _treeParent :: DeviceConfig
, _treeChildren :: V.Vector String
} deriving Show
instance FromJSON TreeConfig where
parseJSON = withObject "devices" $ \o -> do parseJSON = withObject "devices" $ \o -> do
devType <- o .: "type" devType <- o .: "type"
case (devType :: String) of deps <- o .:& "depends"
"cifs" -> CIFSConfig mountconf <- o .: "mount"
<$> o .: "mount" devData <- case (devType :: String) of
<*> o .: "remote" "cifs" -> CIFSConfig
<*> o .:& "depends" <$> o .: "remote"
<*> o .:? "password" <*> o .:? "password"
"sshfs" -> SSHFSConfig "sshfs" -> SSHFSConfig
<$> o .: "mount" <$> o .: "remote"
<*> o .: "remote" "veracrypt" -> VeracryptConfig
<*> o .:& "depends" <$> o .: "volume"
"veracrypt" -> VeracryptConfig <*> o .:? "password"
<$> o .: "mount" -- TODO make this skip adding an entry to the map rather than
<*> o .: "volume" -- skipping the map entirely
<*> o .:& "depends" _ -> fail $ "unknown device type: " ++ devType
<*> o .:? "password" return $ TreeConfig
-- TODO make this skip adding an entry to the map rather than skipping the { _treeParent = DeviceConfig
-- map entirely { _deviceMount = mountconf
_ -> fail $ "unknown device type: " ++ devType , _deviceData = devData
}
, _treeChildren = deps
}
data StaticConfig = StaticConfig data StaticConfig = StaticConfig
{ _staticconfigTmpPath :: Maybe String { _staticconfigTmpPath :: Maybe String
, _staticconfigDevices :: M.Map String DeviceConfig , _staticconfigDevices :: M.Map String TreeConfig
} deriving Show } deriving Show
instance FromJSON StaticConfig where instance FromJSON StaticConfig where
@ -195,7 +203,7 @@ instance FromJSON StaticConfig where
data MountConf = MountConf data MountConf = MountConf
{ mountconfVolatilePath :: FilePath { mountconfVolatilePath :: FilePath
, mountconfRofiArgs :: [String] , mountconfRofiArgs :: [String]
, mountconfStaticDevs :: M.Map String DeviceConfig , mountconfStaticDevs :: M.Map String TreeConfig
} }
instance RofiConf MountConf where instance RofiConf MountConf where
@ -279,56 +287,46 @@ runPrompt gs = selectAction $ emptyMenu
getGroups :: RofiIO MountConf [RofiGroup MountConf] getGroups :: RofiIO MountConf [RofiGroup MountConf]
getGroups = do getGroups = do
(cifsDevs, sshfsDevs, vcDevs) <- groupTriples staticDevs <- asks mountconfStaticDevs
<$> (fromConfig =<< asks mountconfStaticDevs) staticActions <- mapM mkAction $ configToTree' staticDevs
sequence removableActions <- mapM mkAction =<< getRemovableDevices
[ mkGroup "SSHFS Devices" sshfsDevs mtpActions <- mapM mkAction =<< getMTPDevices
, mkGroup "CIFS Devices" cifsDevs return $ mapMaybe mkGroup
, mkGroup "Veracrypt Devices" vcDevs $ groupBy (\(hx, _, _) (hy, _, _) -> hx == hy)
, mkGroup "Removable Devices" =<< getRemovableDevices $ sortBy (\(hx, _, _) (hy, _, _) -> compare hx hy)
, mkGroup "MTP Devices" =<< getMTPDevices $ staticActions ++ removableActions ++ mtpActions
]
mountByAlias :: Bool -> String -> RofiIO MountConf () mountByAlias :: Bool -> String -> RofiIO MountConf ()
mountByAlias unmountFlag alias = do mountByAlias unmountFlag alias = do
static <- asks mountconfStaticDevs static <- asks mountconfStaticDevs
volatilePath <- asks mountconfVolatilePath mapM_ (`mount` unmountFlag) $ configToTree static <$> M.lookup alias static
forM_(M.lookup alias static) $ \d -> do
res <- configToDev volatilePath static d
case res of
First d' -> mount' d'
Second d' -> mount' d'
Third d' -> mount' d'
where
mount' :: Mountable a => a -> RofiIO MountConf ()
mount' = flip mount unmountFlag
mkGroup :: Mountable d => String -> [d] -> RofiIO MountConf (RofiGroup MountConf) mkGroup :: [(Header, String, RofiIO MountConf ())] -> Maybe (RofiGroup MountConf)
mkGroup header devs = sortGroup header <$> mapM mkAction devs mkGroup [] = Nothing
mkGroup as = let ((Header title _, _, _):_) = as in
-- Just $ titledGroup title $ alignEntries $ toRofiActions $ fmap (\(_, e, a) -> (e, a)) as
Just $ titledGroup title $ toRofiActions $ fmap (\(_, e, a) -> (e, a)) as
sortGroup :: String -> [(String, RofiIO MountConf ())] -> RofiGroup MountConf -- alignSep :: String
sortGroup header = titledGroup header . alignEntries . toRofiActions -- alignSep = " | "
alignSep :: String
alignSep = " | "
alignSepPre :: String alignSepPre :: String
alignSepPre = "@@@" alignSepPre = "@@@"
alignEntries :: RofiActions c -> RofiActions c -- 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
align = fmap (intercalate alignSep) -- align = fmap (intercalate alignSep)
. transpose -- . transpose
. mapToLast pad -- . mapToLast pad
. transpose -- . transpose
. fmap (splitOn alignSepPre) -- . fmap (splitOn alignSepPre)
pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs -- pad xs = let m = getMax xs in fmap (\x -> take m (x ++ repeat ' ')) xs
getMax = maximum . fmap length -- getMax = maximum . fmap length
mapToLast _ [] = [] -- mapToLast _ [] = []
mapToLast _ [x] = [x] -- mapToLast _ [x] = [x]
mapToLast f (x:xs) = f x : mapToLast f xs -- mapToLast f (x:xs) = f x : mapToLast f xs
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Removable devices -- | Removable devices
@ -352,8 +350,13 @@ instance Mountable Removable where
isMounted Removable { deviceSpec = d } = elem d <$> io curDeviceSpecs isMounted Removable { deviceSpec = d } = elem d <$> io curDeviceSpecs
getLabel Removable { label = l } = l
instance Actionable Removable where
fmtEntry Removable { deviceSpec = d, label = l } = l ++ alignSepPre ++ d fmtEntry Removable { deviceSpec = d, label = l } = l ++ alignSepPre ++ d
groupHeader _ = Header "Removable Devices" 3
-- | 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
@ -372,96 +375,10 @@ getRemovableDevices = fromLines toDev . lines
_ -> Nothing _ -> Nothing
mk d l = Just $ Removable { deviceSpec = d, label = l } mk d l = Just $ Removable { deviceSpec = d, label = l }
--------------------------------------------------------------------------------
-- | CIFS Devices
--
-- This wraps the Removable device (since it is removable) and also adds its
-- own mount options and passwords for authentication.
data CIFS = CIFS Removable FilePath (Maybe PasswordGetter) Dependencies
instance Show CIFS where
show (CIFS r f _ d) = unwords [show r, show f, "<Pwd>", show d]
instance Mountable CIFS where
mount (CIFS Removable{ label = l } m getPwd deps) False = do
mountDependencies deps
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
mount (CIFS Removable{ label = l } m _ _) True = umountNotify l m
allInstalled _ = io $ isJust <$> findExecutable "mount.cifs"
isMounted (CIFS _ dir _ _) = io $ isDirMounted dir
fmtEntry (CIFS r _ _ _) = fmtEntry r
--------------------------------------------------------------------------------
-- | SSHFS Devices
--
-- This wraps the Removable device (since it is removable) and also adds its
-- own mount options. If the path does not point to an aliased entry in the ssh
-- config that specifies the port, hostname, user, and identity file, these
-- need to be passed as mount options.
data SSHFS = SSHFS Removable FilePath Dependencies deriving Show
instance Mountable SSHFS where
mount (SSHFS Removable{ deviceSpec = d, label = l } m deps) False = do
mountDependencies deps
bracketOnError_
(mkDirMaybe m)
(rmDirMaybe m)
(io $ runMountNotify "sshfs" [d, m] l False)
mount (SSHFS Removable{ label = l } m _) True = umountNotify l m
allInstalled _ = fmap isJust $ io $ findExecutable "sshfs"
isMounted (SSHFS _ dir _) = io $ isDirMounted dir
fmtEntry (SSHFS r _ _) = fmtEntry r
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | VeraCrypt Devices -- | VeraCrypt Devices
-- --
data VeraCrypt = VeraCrypt Removable FilePath (Maybe PasswordGetter) Dependencies
instance Show VeraCrypt where
show (VeraCrypt r f _ d) = unwords [show r, show f, show d]
instance Mountable VeraCrypt where
mount (VeraCrypt Removable{ deviceSpec = s, label = l } m getPwd deps) False = do
mountDependencies deps
bracketOnError_ (mkDirMaybe m) (rmDirMaybe m) mountMaybe
where
mountMaybe = io $ maybe (runVeraCryptWith "" []) (runVeraCryptWithPwd =<<) getPwd
runVeraCryptWithPwd = maybe notifyFail (\p -> runVeraCryptWith p ["--stdin"])
runVeraCryptWith stdin args = (\res -> notifyMounted (isRight res) False l)
=<< runVeraCrypt stdin ([s, m] ++ args)
notifyFail = notify "dialog-error-symbolic" $
printf "Failed to get volume password for %s" l
mount (VeraCrypt Removable{ label = l } m _ _) True = io $ do
res <- runVeraCrypt "" ["-d", m]
notifyMounted (isRight res) True l
allInstalled _ = io $ isJust <$> findExecutable "veracrypt"
isMounted (VeraCrypt _ dir _ _) = io $ isDirMounted dir
fmtEntry (VeraCrypt r _ _ _) = fmtEntry r
-- NOTE: the user is assumed to have added themselves to the sudoers file so -- NOTE: the user is assumed to have added themselves to the sudoers file so
-- that this command will work -- that this command will work
runVeraCrypt :: String -> [String] -> IO (Either (Int, String, String) String) runVeraCrypt :: String -> [String] -> IO (Either (Int, String, String) String)
@ -502,8 +419,13 @@ instance Mountable MTPFS where
isMounted MTPFS { mountpoint = dir } = io $ isDirMounted dir isMounted MTPFS { mountpoint = dir } = io $ isDirMounted dir
getLabel = fmtEntry
instance Actionable MTPFS where
fmtEntry MTPFS { description = d } = d fmtEntry MTPFS { description = d } = d
groupHeader _ = Header "MTP Devices" 5
-- | Return list of all available MTP devices -- | Return list of all available MTP devices
getMTPDevices :: RofiIO MountConf [MTPFS] getMTPDevices :: RofiIO MountConf [MTPFS]
getMTPDevices = do getMTPDevices = do
@ -536,72 +458,88 @@ getMTPDevices = do
-- In order to make a consistent interface for the static device types, create -- In order to make a consistent interface for the static device types, create
-- a wrapper type to encapsulate them. -- a wrapper type to encapsulate them.
-- | a sum-type wrapper for three different types, obviously this will change data Tree a = Tree a [Tree a] deriving (Eq, Show)
-- if/when I add more static devices and their types
data Triple a b c = First a | Second b | Third c deriving Show
-- | Specific wrapper for static devices type StaticConfigTree = Tree DeviceConfig
type StaticDeviceTriple = Triple CIFS SSHFS VeraCrypt
fromConfig :: M.Map String DeviceConfig -> RofiIO MountConf [StaticDeviceTriple] instance Actionable (Tree DeviceConfig) where
fromConfig st = do fmtEntry (Tree p _) = getLabel p
p <- asks mountconfVolatilePath
mapM (configToDev p st) $ M.elems st
-- TODO abstract parts of this away in new typeclass for static devices groupHeader (Tree DeviceConfig{ _deviceData = d } _) =
configToDev :: FilePath -> M.Map String DeviceConfig -> DeviceConfig case d of
-> RofiIO MountConf StaticDeviceTriple CIFSConfig{} -> Header "CIFS Devices" 0
configToDev v s CIFSConfig { _cifsMount = MountConfig { _mountMountPoint = m } SSHFSConfig{} -> Header "SSHFS Devices" 1
, _cifsRemote = t VeracryptConfig{} -> Header "Veracrypt Devices" 2
, _cifsDepends = d
, _cifsPassword = p } = do configToTree' :: M.Map String TreeConfig -> [StaticConfigTree]
-- stuff like this is totally refactorable configToTree' devMap = configToTree devMap <$> M.elems devMap
let r = Removable { deviceSpec = smartSlashPrefix t, label = takeFileName m }
d' <- getDependencies s $ V.toList d configToTree :: M.Map String TreeConfig -> TreeConfig -> StaticConfigTree
return $ First $ CIFS r (appendRoot v m) (configToPwd <$> p) d' configToTree devMap TreeConfig{ _treeParent = p, _treeChildren = c } =
Tree p $ fmap go V.toList c
where where
smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a go ds = configToTree devMap <$> mapMaybe (`M.lookup` devMap) ds
configToDev v s SSHFSConfig { _sshfsMount = MountConfig { _mountMountPoint = m }
, _sshfsDepends = d
, _sshfsRemote = t } = do
let r = Removable { deviceSpec = t, label = takeFileName m }
d' <- getDependencies s $ V.toList d
return $ Second $ SSHFS r (appendRoot v m) d'
configToDev v s VeracryptConfig { _veracryptMount = MountConfig { _mountMountPoint = m }
, _veracryptVolume = t
, _veracryptDepends = d
, _veracryptPassword = p } = do
let r = Removable { deviceSpec = t, label = takeFileName m }
d' <- getDependencies s $ V.toList d
return $ Third $ VeraCrypt r (appendRoot v m) (configToPwd <$> p) d'
groupTriples :: [Triple a b c] -> ([a], [b], [c]) instance Mountable a => Mountable (Tree a) where
groupTriples = foldl stackTriples ([], [], []) mount (Tree p cs) False = mapM_ (`mount` False) cs >> mount p False
mount (Tree p _) True = mount p True
stackTriples :: ([a], [b], [c]) -> Triple a b c -> ([a], [b], [c]) isMounted (Tree p _) = isMounted p
stackTriples (c, v, s) (First x) = (x:c, v, s)
stackTriples (c, v, s) (Second x) = (c, x:v, s)
stackTriples (c, v, s) (Third x) = (c, v, x:s)
-------------------------------------------------------------------------------- allInstalled (Tree p cs) = do
-- | Static Dependencies res <- and <$> mapM allInstalled cs
-- if res then allInstalled p else return res
-- Define a data structure that allows one device to depend on another.
newtype Dependencies = Dependencies [StaticDeviceTriple] deriving Show getLabel (Tree p _) = getLabel p
getDependencies :: M.Map String DeviceConfig -> [String] -> RofiIO MountConf Dependencies instance Mountable DeviceConfig where
getDependencies devMap aliases = fmap Dependencies mount c@DeviceConfig{ _deviceMount = MountConfig { _mountMountPoint = m }
$ fromConfig $ M.filterWithKey (\k _ -> k `elem` aliases) devMap , _deviceData = devData
} False = do
mountRoot <- asks mountconfVolatilePath
let m' = appendRoot mountRoot m
bracketOnError_ (mkDirMaybe m') (rmDirMaybe m') $ mount' m'
where
mount' mountpoint = io $ case devData of
SSHFSConfig{ _sshfsRemote = r } ->
runMountNotify "sshfs" [r, mountpoint] (getLabel c) False
CIFSConfig{ _cifsPassword = p } -> do
res <- case p of
Just pwd -> do
pwd' <- maybe [] (\p' -> [("PASSWD", p')]) <$> configToPwd pwd
readCmdEither' "mount" [mountpoint] "" pwd'
Nothing -> readCmdEither "mount" [mountpoint] ""
notifyMounted (isRight res) False (getLabel c)
VeracryptConfig{ _veracryptPassword = getPwd, _veracryptVolume = v } ->
maybe (runVeraCryptWith "" []) (runVeraCryptWithPwd =<<) (configToPwd <$> getPwd)
where
l = getLabel c
runVeraCryptWithPwd = maybe notifyFail (\p -> runVeraCryptWith p ["--stdin"])
runVeraCryptWith stdin args = (\res -> notifyMounted (isRight res) False l)
=<< runVeraCrypt stdin ([v, mountpoint] ++ args)
notifyFail = notify "dialog-error-symbolic" $
printf "Failed to get volume password for %s" l
mountDependencies :: Dependencies -> RofiIO MountConf () mount c@DeviceConfig{ _deviceMount = MountConfig{ _mountMountPoint = m }
mountDependencies (Dependencies d) = mapM_ mount' d , _deviceData = VeracryptConfig{}
where } True = io $ do
-- this looks stupid but all these mount calls are technically different res <- runVeraCrypt "" ["-d", m]
-- functions because class instances notifyMounted (isRight res) True (getLabel c)
mount' (First m) = mount m False
mount' (Second m) = mount m False mount c@DeviceConfig{ _deviceMount = MountConfig { _mountMountPoint = m }} True =
mount' (Third m) = mount m False umountNotify (getLabel c) m
allInstalled DeviceConfig{ _deviceData = devData } = io $ isJust
<$> findExecutable (exe devData)
where
exe SSHFSConfig{} = "sshfs"
exe CIFSConfig{} = "mount.cifs"
exe VeracryptConfig{} = "veracrypt"
isMounted DeviceConfig{ _deviceMount = MountConfig{ _mountMountPoint = m }} = io $ isDirMounted m
getLabel DeviceConfig{ _deviceMount = MountConfig{ _mountMountPoint = p, _mountLabel = l }} =
fromMaybe (takeBaseName p) l
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Mountable typeclass -- | Mountable typeclass
@ -616,24 +554,44 @@ 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 -> RofiIO MountConf () mount :: a -> Bool -> RofiIO MountConf ()
mountMaybe :: a -> Bool -> RofiIO MountConf ()
mountMaybe dev mountFlag = do
mounted <- isMounted dev
if mountFlag == mounted then mount dev mountFlag
else io $ notify "dialog-information-symbolic"
$ getLabel dev ++ " already mounted"
-- | Check if the mounting utilities are present -- | Check if the mounting utilities are present
allInstalled :: a -> RofiIO MountConf Bool allInstalled :: a -> RofiIO MountConf Bool
-- | Return a string to go in the Rofi menu for the given type -- | Return a string representing the label of the device
fmtEntry :: a -> String getLabel :: a -> String
-- | Determine if the given type is mounted or not -- | Determine if the given type is mounted or not
isMounted :: a -> RofiIO MountConf Bool isMounted :: a -> RofiIO MountConf Bool
data Header = Header String Integer deriving (Show, Eq)
instance Ord Header where
compare (Header _ x) (Header _ y) = compare x y
class Mountable a => Actionable a where
-- | Return a string to go in the Rofi menu for the given type
fmtEntry :: a -> String
fmtEntry = getLabel
groupHeader :: a -> Header
-- | 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 -> RofiIO MountConf (String, RofiIO MountConf ()) mkAction :: a -> RofiIO MountConf (Header, 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 $ mount dev m let h = groupHeader dev
let a = when i $ mountMaybe dev m
let s = mountedPrefix m i ++ fmtEntry dev let s = mountedPrefix m i ++ fmtEntry dev
return (s, a) return (h, s, a)
where where
mountedPrefix False True = " " mountedPrefix False True = " "
mountedPrefix True True = "* " mountedPrefix True True = "* "