ENH add wrap to command line text
This commit is contained in:
parent
7c1d899be6
commit
09e8bc9372
|
@ -13,11 +13,13 @@ 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 Rofi.Command
|
import Rofi.Command
|
||||||
|
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
import Text.Regex.TDFA
|
import Text.Regex.TDFA
|
||||||
|
import Text.Wrap
|
||||||
|
|
||||||
import System.Console.GetOpt
|
import System.Console.GetOpt
|
||||||
import System.Directory
|
import System.Directory
|
||||||
|
@ -56,32 +58,32 @@ initMountConf a = conf <$> getEffectiveUserName
|
||||||
|
|
||||||
options :: [OptDescr (MountConf -> MountConf)]
|
options :: [OptDescr (MountConf -> MountConf)]
|
||||||
options =
|
options =
|
||||||
-- TODO clean up massive text blocks here with textwrap
|
|
||||||
[ Option ['s'] ["secret"]
|
[ Option ['s'] ["secret"]
|
||||||
(ReqArg (\s m -> m { credentials = addGetSecret (credentials m) s } ) "SECRET")
|
(ReqArg (\s m -> m { credentials = addGetSecret (credentials m) s } ) "SECRET")
|
||||||
("Use libsecret to retrieve password for DIR using ATTR/VAL pairs.\n" ++
|
$ wrap "Use libsecret to retrieve password for DIR using ATTR/VAL pairs. \
|
||||||
"The pairs will be supplied to a 'secret-tool lookup' call.\n" ++
|
\The pairs will be supplied to a 'secret-tool lookup' call. \
|
||||||
"Argument is formatted like 'DIR:ATTR1=VAL1,ATTR2=VAL2...'")
|
\ Argument is formatted like 'DIR:ATTR1=VAL1,ATTR2=VAL2...'"
|
||||||
, Option ['d'] ["directory"]
|
, Option ['d'] ["directory"]
|
||||||
(ReqArg (\s m -> m { mountDir = s } ) "DIR")
|
(ReqArg (\s m -> m { mountDir = s } ) "DIR")
|
||||||
("The directory in which new mountpoints will be created. This is\n" ++
|
$ wrap "The DIR in which new mountpoints will be created. This is assumed \
|
||||||
"assumed to be writable to the current user, and will be used for\n" ++
|
\to be writable to the current user, and will be used for fuse \
|
||||||
"fuse entries as well as user mounts in fstab. For the latter, it is\n" ++
|
\entries as well as user mounts in fstab. For the latter, it is \
|
||||||
"assumed that all user mounts contain this directory if a mountpoint\n" ++
|
\assumed that all user mounts contain this directory if a \
|
||||||
"does not already exist for them. If not diven this will default to\n" ++
|
\mountpoint does not already exist for them. If not given this will \
|
||||||
"'/media/USER'.")
|
\default to '/media/USER'."
|
||||||
, Option ['p'] ["password"]
|
, Option ['p'] ["password"]
|
||||||
(ReqArg (\s m -> m { credentials = addGetPrompt (credentials m) s } ) "DIR")
|
(ReqArg (\s m -> m { credentials = addGetPrompt (credentials m) s } ) "DIR")
|
||||||
"Prompt for password when mounting DIR."
|
"Prompt for password when mounting DIR."
|
||||||
]
|
]
|
||||||
|
where
|
||||||
|
wrap = unpack . wrapText defaultWrapSettings 40
|
||||||
|
|
||||||
parse :: [String] -> IO ()
|
parse :: [String] -> IO ()
|
||||||
parse args = case getOpt Permute options args of
|
parse args = case getOpt Permute options args of
|
||||||
(o, n, []) -> do
|
(o, n, []) -> initMountConf n >>= \i -> runMounts $ foldl (flip id) i o
|
||||||
i <- initMountConf n
|
(_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo h options
|
||||||
runMounts $ foldl (flip id) i o
|
where
|
||||||
-- TODO make this a real error
|
h = "Usage: rofi-dev [OPTIONS] [-- ROFI-OPTIONS]"
|
||||||
(_, _, errs) -> putStrLn $ concat errs ++ usageInfo "header" options
|
|
||||||
|
|
||||||
addGetSecret :: DevicePasswords -> String -> DevicePasswords
|
addGetSecret :: DevicePasswords -> String -> DevicePasswords
|
||||||
addGetSecret pwds c = case splitPrefix c of
|
addGetSecret pwds c = case splitPrefix c of
|
||||||
|
@ -292,16 +294,15 @@ instance Mountable CIFS where
|
||||||
-- TODO this smells like something that should be in a typeclass
|
-- TODO this smells like something that should be in a typeclass
|
||||||
fstabToCIFS :: FSTabEntry -> RofiIO MountConf CIFS
|
fstabToCIFS :: FSTabEntry -> RofiIO MountConf CIFS
|
||||||
fstabToCIFS FSTabEntry{ fstabSpec = s, fstabDir = d, fstabOptions = o } = do
|
fstabToCIFS FSTabEntry{ fstabSpec = s, fstabDir = d, fstabOptions = o } = do
|
||||||
-- This is a hack. If the options specify "guest" don't require a
|
-- If the options specify "guest" don't require a password. Else try to find a
|
||||||
-- password. Else try to find a means to get the password from the
|
-- means to get the password from the command line options provided for the
|
||||||
-- command line options provided for the this mountpoint. If nothing is
|
-- this mountpoint. If nothing is found, prompt for a password. In any case,
|
||||||
-- found, create a dummy function that returns "" as the password, which
|
-- the output will be passed to env variable PASSWD when mounting this cifs
|
||||||
-- will be passed to the env variable PASSWD when mounting this cifs
|
-- directory and cause it to fail. Setting the env variable is necessary as
|
||||||
-- directory and cause it to fail. Setting the env variable is necessary
|
|
||||||
-- the cifs mount call will prompt for a password and hang otherwise.
|
-- the cifs mount call will prompt for a password and hang otherwise.
|
||||||
pwd <- if M.member "guest" o
|
pwd <- if M.member "guest" o
|
||||||
then return Nothing
|
then return Nothing
|
||||||
else Just . M.findWithDefault (return $ Just "") d <$> asks credentials
|
else Just . M.findWithDefault readPassword d <$> asks credentials
|
||||||
let r = Removable { deviceSpec = smartSlashPrefix s, label = takeFileName d }
|
let r = Removable { deviceSpec = smartSlashPrefix s, label = takeFileName d }
|
||||||
return $ CIFS r d pwd
|
return $ CIFS r d pwd
|
||||||
where
|
where
|
||||||
|
|
|
@ -36,6 +36,8 @@ dependencies:
|
||||||
- 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
|
||||||
# - cassava >= 0.5.2.0
|
# - cassava >= 0.5.2.0
|
||||||
# - vector >= 0.12.0.3
|
# - vector >= 0.12.0.3
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue