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

ENH use yaml file for static config

This commit is contained in:
Nathan Dwarshuis 2021-03-18 00:41:04 -04:00
parent 5f3a3f39fb
commit cd3ee141b0
2 changed files with 220 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

384
app/rofi-dev.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -23,13 +24,14 @@ 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.Text (unpack) import qualified Data.Vector as V
import Data.Yaml
import GHC.Generics()
import Rofi.Command import Rofi.Command
import Text.Printf import Text.Printf
import Text.Regex.TDFA
import Text.Wrap
import System.Console.GetOpt import System.Console.GetOpt
import System.Directory import System.Directory
@ -53,39 +55,144 @@ parse args = case getOpt Permute options args of
options :: [OptDescr (MountConf -> MountConf)] options :: [OptDescr (MountConf -> MountConf)]
options = options =
[ Option ['s'] ["secret"] [ Option ['c'] ["config"]
(ReqArg (\s m -> m { passwords = addSecret (passwords m) s } ) "SECRET") (ReqArg (\s m -> m { mConfig = Just s } ) "CONF")
$ wrap "Use libsecret to retrieve password for DIR using ATTR/VAL pairs. \ "The path to the config file"
\The pairs will be supplied to a 'secret-tool lookup' call. \
\ Argument is formatted like 'DIR:ATTR1=VAL1,ATTR2=VAL2...'"
, Option ['b'] ["bitwarden"]
(ReqArg (\s m -> m { passwords = addBitwarden (passwords m) s } ) "BW")
$ wrap "Use the Bitwarden CLI to retrieve a password for DIR. \
\The argument is formatted like 'DIR:NAME' where NAME is the \
\name of the Bitwarden entry to find."
, Option ['p'] ["password"]
(ReqArg (\s m -> m { passwords = addPwdPrompt (passwords m) s } ) "DIR")
"Prompt for password when mounting DIR."
, Option ['d'] ["directory"]
(ReqArg (\s m -> m { mountDir = s } ) "DIR")
$ wrap "The DIR in which new mountpoints will be created. This is assumed \
\to be writable to the current user, and will be used for fuse \
\entries as well as user mounts in fstab. For the latter, it is \
\assumed that all user mounts contain this directory if a \
\mountpoint does not already exist for them. If not given this will \
\default to '/tmp/media/USER'."
, Option ['v'] ["veracrypt"]
(ReqArg (\s m -> m { vcMounts = addVeracryptMount (vcMounts m) s } ) "VC")
$ wrap "A veracrypt mount specification formatted like DIR:VOL where \
\DIR is the mountpoint and VOL is the path to the encrypted \
\volume. To specify a password, use the -p, -b- or -s options."
] ]
where
wrap = unpack . wrapText defaultWrapSettings 40
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Static configuration -- | Static configuration
-- --
-- This is defined in a YAML file which describes how to mount each device. Here
-- I define a parser for said YAML file
defaultTries :: Integer
defaultTries = 2
data MountConfig = MountConfig
{ _mountMountPoint :: FilePath
, _mountLabel :: Maybe String
} deriving Show
instance FromJSON MountConfig where
parseJSON = withObject "devices" $ \o -> MountConfig
<$> o .: "mountpoint"
<*> o .:? "label"
data BitwardenConfig = BitwardenConfig
{ _bitwardenKey :: String
, _bitwardenTries :: Integer }
deriving Show
instance FromJSON BitwardenConfig where
parseJSON = withObject "bitwarden" $ \o -> BitwardenConfig
<$> o .: "key"
<*> o .:? "tries" .!= defaultTries
newtype LibSecretConfig = LibSecretConfig
{ _libsecretAttributes :: M.Map String String }
deriving Show
instance FromJSON LibSecretConfig where
parseJSON = withObject "libsecret" $ \o -> LibSecretConfig
<$> o .: "attributes"
newtype PromptConfig = PromptConfig
{ _promptTries :: Integer }
deriving Show
instance FromJSON PromptConfig where
parseJSON = withObject "libsecret" $ \o -> PromptConfig
<$> o .: "tries" .!= defaultTries
data PasswordConfig = PasswordConfig
{ _passwordBitwarden :: Maybe BitwardenConfig
, _passwordLibSecret :: Maybe LibSecretConfig
, _passwordPrompt :: Maybe PromptConfig
}
deriving Show
instance FromJSON PasswordConfig where
parseJSON = withObject "password" $ \o -> PasswordConfig
<$> o .:? "bitwarden"
<*> o .:? "libsecret"
<*> o .:? "prompt"
data VeracryptConfig = VeracryptConfig
{ _veracryptMount :: MountConfig
, _veracryptVolume :: String
, _veracryptPassword :: Maybe PasswordConfig
} deriving Show
instance FromJSON VeracryptConfig where
parseJSON = withObject "veracrypt" $ \o -> VeracryptConfig
<$> o .: "mount"
<*> o .: "volume"
<*> o .:? "password"
data SSHFSConfig = SSHFSConfig
{ _sshfsMount :: MountConfig
, _sshfsRemote :: String
} deriving Show
instance FromJSON SSHFSConfig where
parseJSON = withObject "sshfs" $ \o -> SSHFSConfig
<$> o .: "mount"
<*> o .: "remote"
data CIFSConfig = CIFSConfig
{ _cifsMount :: MountConfig
, _cifsRemote :: String
, _cifsPassword :: Maybe PasswordConfig
} deriving Show
instance FromJSON CIFSConfig where
parseJSON = withObject "cifs" $ \o -> CIFSConfig
<$> o .: "mount"
<*> o .: "remote"
<*> o .: "password"
data DevicesConfig = DevicesConfig
{ _veracryptConfigs :: V.Vector VeracryptConfig
, _sshfsConfigs :: V.Vector SSHFSConfig
, _cifsConfigs :: V.Vector CIFSConfig
} deriving Show
instance FromJSON DevicesConfig where
parseJSON = withObject "devices" $ \o -> DevicesConfig
<$> o .: "veracrypt"
<*> o .: "sshfs"
<*> o .: "cifs"
data StaticConfig = StaticConfig
{ _tmpMountDir :: Maybe String
, _devicesConfig :: Maybe DevicesConfig
} deriving Show
instance FromJSON StaticConfig where
parseJSON = withObject "devices" $ \o -> StaticConfig
<$> o .:? "mountdir"
<*> o .:? "devices"
--------------------------------------------------------------------------------
-- | Static Devices typeclass
--
-- A class to represent devices defined in the static configuration (eg the YAML
-- file). Its methods define the machinery to extract specific devies types
-- from the parse tree.
class Mountable m => StaticDevice m a where
-- | Mount the given type (or dismount if False is passed)
fromConfig :: V.Vector a -> RofiIO MountConf [m]
fromConfig s = do
v <- asks mountDir
return $ configToDev v <$> V.toList s
configToDev :: FilePath -> a -> m
--------------------------------------------------------------------------------
-- | Global config used in the reader monad stack
--
-- This is defined by the mount options on the command line, and holds: -- This is defined by the mount options on the command line, and holds:
-- - a map between mountpoints and a means to get passwords when mounting those -- - a map between mountpoints and a means to get passwords when mounting those
-- mountpoints -- mountpoints
@ -93,23 +200,11 @@ options =
-- to '/tmp/media/USER' -- to '/tmp/media/USER'
-- - any arguments to be passed to the rofi command -- - any arguments to be passed to the rofi command
type PasswordGetter = IO (Maybe String)
type MountpointPasswords = M.Map String PasswordGetter
type VeracryptMount = (FilePath, FilePath)
addVeracryptMount :: [VeracryptMount] -> String -> [VeracryptMount]
addVeracryptMount l s = case splitPrefix s of
(dir, ":", vol) -> (dir, vol):l
_ -> l
-- TODO check if mountdir exists or puke
data MountConf = MountConf data MountConf = MountConf
{ passwords :: MountpointPasswords { mountDir :: FilePath
, mountDir :: FilePath
, rofiArgs :: [String] , rofiArgs :: [String]
, vcMounts :: [VeracryptMount] , mConfig :: Maybe FilePath
, devConfig :: Maybe DevicesConfig
} }
instance RofiConf MountConf where instance RofiConf MountConf where
@ -119,39 +214,52 @@ initMountConf :: [String] -> IO MountConf
initMountConf a = conf <$> getEffectiveUserName initMountConf a = conf <$> getEffectiveUserName
where where
conf u = MountConf conf u = MountConf
{ passwords = M.empty { mountDir = "/tmp/media" </> u
, mountDir = "/tmp/media" </> u
, rofiArgs = a , rofiArgs = a
, vcMounts = [] , mConfig = Nothing
, devConfig = Nothing
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Password-getting functions -- | Password-getting functions
addSecret :: MountpointPasswords -> String -> MountpointPasswords type PasswordGetter = IO (Maybe String)
addSecret pwds c = case splitPrefix c of
(dir, ":", r) -> M.insert dir (runSecret $ fromCommaSepString' r) pwds
_ -> pwds
runSecret :: [(String, String)] -> PasswordGetter runSecret :: [(String, String)] -> PasswordGetter
runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') "" runSecret kvs = readCmdSuccess "secret-tool" ("lookup":kvs') ""
where where
kvs' = concatMap (\(k, v) -> [k, v]) kvs kvs' = concatMap (\(k, v) -> [k, v]) kvs
addBitwarden :: MountpointPasswords -> String -> MountpointPasswords
addBitwarden pwds c = case splitPrefix c of
(dir, ":", name) -> M.insert dir (runBitwarden name) pwds
_ -> pwds
runBitwarden :: String -> PasswordGetter runBitwarden :: String -> PasswordGetter
runBitwarden pname = ((password . login) <=< find (\i -> name i == pname)) runBitwarden pname = ((password . login) <=< find (\i -> name i == pname))
<$> getItems <$> getItems
addPwdPrompt :: MountpointPasswords -> String -> MountpointPasswords runPromptLoop :: Integer -> PasswordGetter -> PasswordGetter
addPwdPrompt pwds dir = M.insert dir readPassword pwds runPromptLoop n pwd = do
res <- pwd
if isNothing res then
if n <= 0 then return Nothing else runPromptLoop (n-1) pwd
else return res
splitPrefix :: String -> (String, String, String) configToPwd :: PasswordConfig -> PasswordGetter
splitPrefix s = s =~ (":" :: String) configToPwd PasswordConfig{ _passwordBitwarden = b
, _passwordLibSecret = s
, _passwordPrompt = p
} =
getBW b `runMaybe` getLS s `runMaybe` getPrompt p
where
getBW (Just BitwardenConfig{ _bitwardenKey = k, _bitwardenTries = n }) =
runPromptLoop n $ runBitwarden k
getBW _ = return Nothing
getLS (Just LibSecretConfig{ _libsecretAttributes = a }) =
runSecret $ M.toList a
getLS _ = return Nothing
getPrompt (Just PromptConfig{ _promptTries = n }) =
runPromptLoop n readPassword
getPrompt _ = return Nothing
runMaybe x y = do
res <- x
if isNothing res then y else return res
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Main prompt -- | Main prompt
@ -161,7 +269,18 @@ splitPrefix s = s =~ (":" :: String)
-- pretty things, so ensure the entries are aligned properly as well -- pretty things, so ensure the entries are aligned properly as well
runMounts :: MountConf -> IO () runMounts :: MountConf -> IO ()
runMounts c = runRofiIO c $ runPrompt =<< getGroups runMounts c = do
c' <- maybe (return c) parseConfig (mConfig c)
runRofiIO c' $ runPrompt =<< getGroups
where
parseConfig m = do
res <- decodeFileEither m
case res of
Left e -> print e >> return c
Right StaticConfig { _tmpMountDir = Just v, _devicesConfig = dc } ->
return $ c { mountDir = v, devConfig = dc }
Right StaticConfig { _devicesConfig = dc } ->
return $ c { devConfig = dc }
runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c () runPrompt :: RofiConf c => [RofiGroup c] -> RofiIO c ()
runPrompt gs = selectAction $ emptyMenu runPrompt gs = selectAction $ emptyMenu
@ -171,12 +290,19 @@ runPrompt gs = selectAction $ emptyMenu
getGroups :: RofiIO MountConf [RofiGroup MountConf] getGroups :: RofiIO MountConf [RofiGroup MountConf]
getGroups = do getGroups = do
fstab <- readFSTab
sysd <- io getSystemdDevices sysd <- io getSystemdDevices
devConf <- asks devConfig
(cifsDevs, sshfsDevs, vcDevs) <- maybe
(return ( [] :: [CIFS], [] :: [SSHFS], [] :: [VeraCrypt]))
(\c -> liftM3 (,,)
(fromConfig $ _cifsConfigs c)
(fromConfig $ _sshfsConfigs c)
(fromConfig $ _veracryptConfigs c))
devConf
sequence sequence
[ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) $ sshfsDevices fstab [ mkGroup2 "SSHFS Devices" (filterSysd SystemdSSHFS sysd) sshfsDevs
, mkGroup "CIFS Devices" $ cifsDevices fstab , mkGroup "CIFS Devices" cifsDevs
, mkGroup2 "Veracrypt Devices" (filterSysd SystemdVeracrypt sysd) =<< getVeracryptDevices , mkGroup2 "Veracrypt Devices" (filterSysd SystemdVeracrypt sysd) vcDevs
, mkGroup "Removable Devices" =<< getRemovableDevices , mkGroup "Removable Devices" =<< getRemovableDevices
, mkGroup "MTP Devices" =<< getMTPDevices , mkGroup "MTP Devices" =<< getMTPDevices
] ]
@ -288,20 +414,12 @@ instance Mountable CIFS where
fmtEntry (CIFS r _ _) = fmtEntry r fmtEntry (CIFS r _ _) = fmtEntry r
-- TODO this smells like something that should be in a typeclass instance StaticDevice CIFS CIFSConfig where
fstabToCIFS :: FSTabEntry -> RofiIO MountConf CIFS configToDev v CIFSConfig { _cifsMount = MountConfig { _mountMountPoint = m }
fstabToCIFS FSTabEntry{ fstabSpec = s, fstabDir = d, fstabOptions = o } = do , _cifsRemote = t
-- If the options specify "guest" don't require a password. Else try to find a , _cifsPassword = p } =
-- means to get the password from the command line options provided for the let r = Removable { deviceSpec = smartSlashPrefix t, label = takeFileName m }
-- this mountpoint. If nothing is found, prompt for a password. In any case, in CIFS r (appendRoot v m) $ configToPwd <$> p
-- the output will be passed to env variable PASSWD when mounting this cifs
-- directory and cause it to fail. Setting the env variable is necessary as
-- the cifs mount call will prompt for a password and hang otherwise.
pwd <- if M.member "guest" o
then return Nothing
else asks $ Just . M.findWithDefault readPassword d . passwords
let r = Removable { deviceSpec = smartSlashPrefix s, label = takeFileName d }
return $ CIFS r d pwd
where where
smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a smartSlashPrefix a = if "//" `isPrefixOf` a then a else "//" ++ a
@ -316,11 +434,11 @@ fstabToCIFS FSTabEntry{ fstabSpec = s, fstabDir = d, fstabOptions = o } = do
data SSHFS = SSHFS Removable FilePath data SSHFS = SSHFS Removable FilePath
instance Mountable SSHFS where instance Mountable SSHFS where
mount (SSHFS Removable{ label = l } m) False = mount (SSHFS Removable{ deviceSpec = d, label = l } m) False = do
bracketOnError_ bracketOnError_
(mkDirMaybe m) (mkDirMaybe m)
(rmDirMaybe m) (rmDirMaybe m)
(io $ runMountNotify "mount" [m] l False) (io $ runMountNotify "sshfs" [d, m] l False)
mount (SSHFS Removable{ label = l } m) True = umountNotify l m mount (SSHFS Removable{ label = l } m) True = umountNotify l m
@ -330,10 +448,11 @@ instance Mountable SSHFS where
fmtEntry (SSHFS r _) = fmtEntry r fmtEntry (SSHFS r _) = fmtEntry r
fstabToSSHFS :: FSTabEntry -> RofiIO MountConf SSHFS instance StaticDevice SSHFS SSHFSConfig where
fstabToSSHFS FSTabEntry{ fstabSpec = s, fstabDir = d } = return $ SSHFS r d configToDev v SSHFSConfig { _sshfsMount = MountConfig { _mountMountPoint = m }
where , _sshfsRemote = t } =
r = Removable { deviceSpec = s, label = takeFileName d } let r = Removable { deviceSpec = t, label = takeFileName m }
in SSHFS r (appendRoot v m)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | VeraCrypt Devices -- | VeraCrypt Devices
@ -370,13 +489,12 @@ runVeraCrypt stdin args = do
where where
defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"] defaultArgs = ["/usr/bin/veracrypt", "--text", "--non-interactive"]
getVeracryptDevices :: RofiIO MountConf [VeraCrypt] instance StaticDevice VeraCrypt VeracryptConfig where
getVeracryptDevices = mapM toDev =<< asks vcMounts configToDev v VeracryptConfig { _veracryptMount = MountConfig { _mountMountPoint = m }
where , _veracryptVolume = t
toDev (d, s) = do , _veracryptPassword = p } =
pwd <- asks $ Just . M.findWithDefault readPassword d . passwords let r = Removable { deviceSpec = t, label = takeFileName m }
let r = Removable { deviceSpec = s, label = takeFileName d } in VeraCrypt r (appendRoot v m) $ configToPwd <$> p
return $ VeraCrypt r d pwd
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | MTP devices -- | MTP devices
@ -452,8 +570,8 @@ data Systemd = Systemd
instance Mountable Systemd where instance Mountable Systemd where
mount s@Systemd { sysdInstance = i } m = let mount s@Systemd { sysdInstance = i } m = let
unit = fmtSysdInstanceName s unit = fmtSysdInstanceName s
op = if m then "stop" else "start" in operation = if m then "stop" else "start" in
io $ runMountNotify "systemctl" ["--user", op, unit] i m io $ runMountNotify "systemctl" ["--user", operation, unit] i m
allInstalled Systemd { sysdType = SystemdVeracrypt } = allInstalled Systemd { sysdType = SystemdVeracrypt } =
io $ isJust <$> findExecutable "veracrypt" io $ isJust <$> findExecutable "veracrypt"
@ -525,64 +643,6 @@ class Mountable a where
mountedPrefix True True = "* " mountedPrefix True True = "* "
mountedPrefix _ False = "! " mountedPrefix _ False = "! "
-- TODO add truecrypt volumes
--------------------------------------------------------------------------------
-- | Fstab devices
--
-- Functions to gather all user fstab mounts on the system
-- | Intermediate structure to hold fstab devices
data FSTab = FSTab
{ sshfsDevices :: [SSHFS]
, cifsDevices :: [CIFS]
-- , veracryptDevices :: [VeraCrypt]
}
-- | Data structure representing an fstab device (or one line in the fstab file)
data FSTabEntry = FSTabEntry
{ fstabSpec :: String
, fstabDir :: FilePath
, fstabType :: String
, fstabOptions :: MountOptions
}
-- | Key/val pairs to represent mount options. A Nothing for the value signifies
-- a standalone option (eg 'rw' and 'ro')
type MountOptions = M.Map String (Maybe String)
-- | Return all user fstab devices from /etc/fstab
readFSTab :: RofiIO MountConf FSTab
readFSTab = do
-- let i = FSTab { sshfsDevices = [], cifsDevices = [], veracryptDevices = []}
let i = FSTab { sshfsDevices = [], cifsDevices = []}
fstab <- io $ readFile "/etc/fstab"
foldM addFstabDevice i $ fromLines toEntry $ lines fstab
where
toEntry line = case words line of
(('#':_):_) -> Nothing
[spec, dir, fsType, opts, _, _] -> Just $ FSTabEntry
{ fstabSpec = spec
, fstabDir = dir
, fstabType = fsType
, fstabOptions = parseOptions opts
}
_ -> Nothing
parseOptions = M.fromList . fromCommaSepString
-- | Add entry to the fstab devices list, but only if it is a known user mount
addFstabDevice :: FSTab -> FSTabEntry -> RofiIO MountConf FSTab
addFstabDevice f@FSTab{..} e@FSTabEntry{..}
| M.notMember "users" fstabOptions = return f
| fstabType == "cifs" =
(\d -> f { cifsDevices = append d cifsDevices }) <$> fstabToCIFS e
| fstabType == "fuse.sshfs" =
(\d -> f { sshfsDevices = append d sshfsDevices }) <$> fstabToSSHFS e
-- | fstabType == "veracrypt" =
-- (\d -> f { veracryptDevices = append d veracryptDevices }) <$> fstabToVeraCrypt e
| otherwise = return f
where
append x xs = xs ++ [x]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Low-level mount functions -- | Low-level mount functions
@ -668,17 +728,5 @@ splitBy delimiter = foldr f [[]]
f c l@(x:xs) | c == delimiter = []:l f c l@(x:xs) | c == delimiter = []:l
| otherwise = (c:x):xs | otherwise = (c:x):xs
-- | Like fromCommaSepString but only return substrings with '=' appendRoot :: FilePath -> FilePath -> FilePath
fromCommaSepString' :: String -> [(String, String)] appendRoot root path = if isRelative path then root </> path else path
fromCommaSepString' s = [(k, v) | (k, Just v) <- fromCommaSepString s]
-- | Split a string of comma-separated values into an alist
-- If the substrings have an '=' in them, the left side will become the key and
-- the right will become the value of the cell. If there is not '=' then the
-- entire substring will become the key and the value will be Nothing
fromCommaSepString :: String -> [(String, Maybe String)]
fromCommaSepString = fmap (toCell . splitEq) . splitBy ','
where
splitEq e = e =~ ("=" :: String) :: (String, String, String)
toCell (k, "=", v) = (k, Just v)
toCell (k, _, _) = (k, Nothing)

5
package.yaml
View File

@ -30,15 +30,14 @@ dependencies:
- mtl >= 2.2.2 - mtl >= 2.2.2
- directory >= 1.3.3.0 - directory >= 1.3.3.0
- bytestring >= 0.10.8.2 - bytestring >= 0.10.8.2
- regex-tdfa >= 1.2.3.2
- split >= 0.2.3.3 - split >= 0.2.3.3
- containers >= 0.6.0.1 - containers >= 0.6.0.1
- filepath >= 1.4.2.1 - filepath >= 1.4.2.1
- unliftio >= 0.2.12 - unliftio >= 0.2.12
- unliftio-core >= 0.1.2.0 - unliftio-core >= 0.1.2.0
- word-wrap >= 0.4.1
- text >= 1.2.3.1
- X11 >= 1.9.1 - X11 >= 1.9.1
- yaml >= 0.11.1.2
- vector >= 0.12.0.3
library: library:
source-dirs: lib/ source-dirs: lib/