{- 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

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

myShowError :: Desc -> IO ()
myShowError desc = do
	hPutStrLn stderr $ "Error: " ++ desc
	putStrLn ""

myPromptQuestion :: Title -> Desc -> Question -> IO Bool
myPromptQuestion title desc question = do
	showTitle title
	go
  where
	go = do
		putStrLn desc
		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 -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
myPromptName title desc (Name suggested) checkproblem = do
	showTitle title
	putStrLn desc
	go
  where
	go = do
		addHistory (BU8.toString suggested)
		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 teardown (const prompt)
  where
	setup = do
		showTitle title
		putStrLn desc
		origattr <- getTerminalAttributes stdInput
		let newattr = origattr `withoutMode` EnableEcho
		setTerminalAttributes stdInput newattr Immediately
		return origattr
	teardown origattr = setTerminalAttributes stdInput origattr Immediately
	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 " ++ 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)
  where
	setup = do
		showTitle title
		putStrLn desc
	sendpercent p = do
		putStr (show p ++ "%  ")
		hFlush stdout
	teardown = putStrLn "done"

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