keysafe-0.20160927: 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 Output
import System.Console.Readline
import System.Posix.Terminal
import System.Posix.IO
import Control.Exception
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
	warn $ "Error: " ++ desc
	_ <- readline "[Press Enter]"
	say ""

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

myPromptQuestion :: Title -> Desc -> Question -> IO Bool
myPromptQuestion title desc question = bracket_ setup cleanup go
  where
	setup = do
		showTitle title
		say desc
	cleanup = say ""
	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
				say "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
		say desc
	cleanup = say ""
	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
						say ""
						return $ Just n
					Just problem -> do
						say 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
		say desc
		origattr <- getTerminalAttributes stdInput
		let newattr = origattr `withoutMode` EnableEcho
		setTerminalAttributes stdInput newattr Immediately
		return origattr
	cleanup origattr = do
		setTerminalAttributes stdInput origattr Immediately
		say ""
	prompt = do
		ask "Enter password> "
		p1 <- getLine
		say ""
		if confirm
			then promptconfirm p1
			else return $ mkpassword p1
	promptconfirm p1 = do
		ask "Confirm password> "
		p2 <- getLine
		say ""
		if p1 /= p2
			then do
				say "Passwords didn't match, try again..."
				prompt
			else do
				say ""
				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
	say desc
	say ""
	forM_ nl $ \(n, ((Name name), (KeyId kid))) ->
		say $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ T.unpack kid ++ ")"
	prompt
  where
	nl = zip [1 :: Integer ..] l
	prompt = do
		ask "Enter number> "
		r <- getLine
		say ""
		case readMaybe r of
			Just n
				| n > 0 && n <= length l -> do
					say ""
					return $ Just $ snd (l !! pred n)
			_ -> do
				say $ "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
		say desc
	sendpercent p = ask (show p ++ "%  ")
	cleanup = do
		say "done"
		say ""

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