diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-08-16 14:58:16 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-08-16 14:58:16 -0400 |
commit | fccf788a5ce9788d7c073321a3d19941bc1269b1 (patch) | |
tree | 76726eb3d3cd6fbb05721e5862e87511d1683b76 /UI | |
parent | c9c476ae7216b80932b80870a2cd06f9339306aa (diff) | |
download | keysafe-fccf788a5ce9788d7c073321a3d19941bc1269b1.tar.gz |
more command line interface improvements
Diffstat (limited to 'UI')
-rw-r--r-- | UI/Readline.hs | 23 | ||||
-rw-r--r-- | UI/Zenity.hs | 31 |
2 files changed, 36 insertions, 18 deletions
diff --git a/UI/Readline.hs b/UI/Readline.hs index 50f2e99..086da1e 100644 --- a/UI/Readline.hs +++ b/UI/Readline.hs @@ -17,13 +17,18 @@ import qualified Data.ByteString.UTF8 as BU8 readlineUI :: UI readlineUI = UI { isAvailable = queryTerminal stdInput - , promptName = name - , promptPassword = password - , withProgress = progress + , showError = myShowError + , promptName = myPromptName + , promptPassword = myPromptPassword + , withProgress = myWithProgress } -name :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) -name title desc (Name suggested) checkproblem = do +myShowError :: Desc -> IO () +myShowError desc = do + hPutStrLn stderr $ "Error: " ++ desc + +myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) +myPromptName title desc (Name suggested) checkproblem = do showTitle title putStrLn desc go @@ -44,8 +49,8 @@ name title desc (Name suggested) checkproblem = do go Nothing -> return Nothing -password :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) -password title desc checkproblem = bracket setup teardown (const go) +myPromptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) +myPromptPassword title desc checkproblem = bracket setup teardown (const go) where setup = do showTitle title @@ -78,8 +83,8 @@ password title desc checkproblem = bracket setup teardown (const go) putStrLn problem go -progress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () -progress title desc a = bracket_ setup teardown (a sendpercent) +myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () +myWithProgress title desc a = bracket_ setup teardown (a sendpercent) where setup = do showTitle title diff --git a/UI/Zenity.hs b/UI/Zenity.hs index f61bb44..c8fca2d 100644 --- a/UI/Zenity.hs +++ b/UI/Zenity.hs @@ -22,13 +22,26 @@ zenityUI = UI ps <- getSearchPath loc <- filterM (\p -> doesFileExist (p </> "zenity")) ps return (not (null loc)) - , promptName = name - , promptPassword = password - , withProgress = progress + , showError = myShowError + , promptName = myPromptName + , promptPassword = myPromptPassword + , withProgress = myWithProgress } -name :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) -name title desc (Name suggested) checkproblem = go "" +myShowError :: Desc -> IO () +myShowError desc = bracket go cleanup (\_ -> return ()) + where + go = runZenity + [ "--error" + , "--title", "keysafe" + , "--text", "Error: " ++ desc + ] + cleanup h = do + _ <- waitZenity h + return () + +myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) +myPromptName title desc (Name suggested) checkproblem = go "" where go extradesc = do h <- runZenity @@ -46,8 +59,8 @@ name title desc (Name suggested) checkproblem = go "" Just problem -> go problem else return Nothing -password :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) -password title desc checkproblem = go "" +myPromptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) +myPromptPassword title desc checkproblem = go "" where go extradesc = do h <- runZenity @@ -71,8 +84,8 @@ password title desc checkproblem = go "" Just problem -> go problem else return Nothing -progress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () -progress title desc a = bracket setup teardown (a . sendpercent) +myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () +myWithProgress title desc a = bracket setup teardown (a . sendpercent) where setup = do h <- runZenity |