diff options
Diffstat (limited to 'UI/Readline.hs')
| -rw-r--r-- | UI/Readline.hs | 73 |
1 files changed, 60 insertions, 13 deletions
diff --git a/UI/Readline.hs b/UI/Readline.hs index 086da1e..ac962d2 100644 --- a/UI/Readline.hs +++ b/UI/Readline.hs @@ -12,14 +12,20 @@ import System.Posix.Terminal import System.Posix.IO import Control.Exception import System.IO +import Data.List +import Data.Char +import Text.Read +import Control.Monad import qualified Data.ByteString.UTF8 as BU8 readlineUI :: UI readlineUI = UI { isAvailable = queryTerminal stdInput , showError = myShowError + , promptQuestion = myPromptQuestion , promptName = myPromptName , promptPassword = myPromptPassword + , promptKeyId = myPromptKeyId , withProgress = myWithProgress } @@ -27,6 +33,24 @@ myShowError :: Desc -> IO () myShowError desc = do hPutStrLn stderr $ "Error: " ++ desc +myPromptQuestion :: Title -> Desc -> IO Bool +myPromptQuestion title desc = do + showTitle title + go + where + go = do + putStrLn desc + mresp <- readline "y/n? " + case mresp of + Just s + | "y" `isPrefixOf` (map toLower s) -> + return True + | "n" `isPrefixOf` (map toLower s) -> + return False + _ -> do + putStrLn "Please enter 'y' or 'n'" + go + myPromptName :: Title -> Desc -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name) myPromptName title desc (Name suggested) checkproblem = do showTitle title @@ -49,8 +73,8 @@ myPromptName title desc (Name suggested) checkproblem = do go Nothing -> return Nothing -myPromptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password) -myPromptPassword title desc checkproblem = bracket setup teardown (const go) +myPromptPassword :: Bool -> Title -> Desc -> IO (Maybe Password) +myPromptPassword confirm title desc = bracket setup teardown (const prompt) where setup = do showTitle title @@ -60,11 +84,15 @@ myPromptPassword title desc checkproblem = bracket setup teardown (const go) setTerminalAttributes stdInput newattr Immediately return origattr teardown origattr = setTerminalAttributes stdInput origattr Immediately - go = do + prompt = do putStr "Enter password> " hFlush stdout p1 <- getLine putStrLn "" + if confirm + then promptconfirm p1 + else return $ mkpassword p1 + promptconfirm p1 = do putStr "Confirm password> " hFlush stdout p2 <- getLine @@ -72,16 +100,35 @@ myPromptPassword title desc checkproblem = bracket setup teardown (const go) if p1 /= p2 then do putStrLn "Passwords didn't match, try again..." - go - else - let p = Password $ BU8.fromString p1 - in case checkproblem p of - Nothing -> do - putStrLn "" - return $ Just p - Just problem -> do - putStrLn problem - go + prompt + else do + putStrLn "" + return $ mkpassword p1 + mkpassword = Just . Password . BU8.fromString + +myPromptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId) +myPromptKeyId _ _ [] = return Nothing +myPromptKeyId title desc l = do + showTitle title + putStrLn desc + putStrLn "" + forM_ nl $ \(n, ((Name name), (KeyId kid))) -> + putStrLn $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ BU8.toString kid ++ ")" + prompt + where + nl = zip [1 :: Integer ..] l + prompt = do + putStr "Enter number> " + hFlush stdout + r <- getLine + putStrLn "" + case readMaybe r of + Just n + | n > 0 && n < length l -> + return $ Just $ snd (l !! n) + _ -> do + putStrLn $ "Enter a number from 1 to " ++ show (length l) + prompt myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO () myWithProgress title desc a = bracket_ setup teardown (a sendpercent) |