keysafe-0.20160922: UI/Readline.hs

{- Copyright 2016 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

module UI.Readline (readlineUI) where

import Types.UI
import Types
import System.Console.Readline
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
import qualified Data.Text as T

readlineUI :: UI
readlineUI = UI
	{ isAvailable = queryTerminal stdInput
	, showError = myShowError
	, showInfo = myShowInfo
	, promptQuestion = myPromptQuestion
	, promptName = myPromptName
	, promptPassword = myPromptPassword
	, promptKeyId = myPromptKeyId
	, withProgress = myWithProgress
	}

myShowError :: Desc -> IO ()
myShowError desc = do
	hPutStrLn stderr $ "Error: " ++ desc
	_ <- readline "[Press Enter]"
	putStrLn ""

myShowInfo :: Title -> Desc -> IO ()
myShowInfo title desc = do
	showTitle title
	putStrLn desc
	putStrLn ""

myPromptQuestion :: Title -> Desc -> Question -> IO Bool
myPromptQuestion title desc question = bracket_ setup cleanup go
  where
	setup = do
		showTitle title
		putStrLn desc
	cleanup = putStrLn ""
	go = do
		mresp <- readline $ question ++ " [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 -> Maybe Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
myPromptName title desc suggested checkproblem =
	bracket_ setup cleanup go
  where
	setup = do
		showTitle title
		putStrLn desc
	cleanup = putStrLn ""
	go = do
		case suggested of
			Nothing -> return ()
			Just (Name b) -> addHistory (BU8.toString b)
		mname <- readline "Name> "
		case mname of
			Just s -> do
				addHistory s
				let n = Name $ BU8.fromString s
				case checkproblem n of
					Nothing -> do
						putStrLn ""
						return $ Just n
					Just problem -> do
						putStrLn problem
						go
			Nothing -> return Nothing

myPromptPassword :: Bool -> Title -> Desc -> IO (Maybe Password)
myPromptPassword confirm title desc = bracket setup cleanup (const prompt)
  where
	setup = do
		showTitle title
		putStrLn desc
		origattr <- getTerminalAttributes stdInput
		let newattr = origattr `withoutMode` EnableEcho
		setTerminalAttributes stdInput newattr Immediately
		return origattr
	cleanup origattr = do
		setTerminalAttributes stdInput origattr Immediately
		putStrLn ""
	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
		putStrLn ""
		if p1 /= p2
			then do
				putStrLn "Passwords didn't match, try again..."
				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 " ++ T.unpack 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 -> do
					putStrLn ""
					return $ Just $ snd (l !! pred n)
			_ -> do
				putStrLn $ "Enter a number from 1 to " ++ show (length l)
				prompt

myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a
myWithProgress title desc a = bracket_ setup cleanup (a sendpercent)
  where
	setup = do
		showTitle title
		putStrLn desc
	sendpercent p = do
		putStr (show p ++ "%  ")
		hFlush stdout
	cleanup = do
		putStrLn "done"
		putStrLn ""

showTitle :: Title -> IO ()
showTitle title = do
	putStrLn title
	putStrLn (replicate (length title) '-')
	putStrLn ""