{- 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 qualified Data.ByteString.UTF8 as BU8

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

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
  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 :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
myPromptPassword title desc checkproblem = bracket setup teardown (const go)
  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
	go = do
		putStr "Enter password> "
		hFlush stdout
		p1 <- getLine
		putStrLn ""
		putStr "Confirm password> "
		hFlush stdout
		p2 <- getLine
		putStrLn ""
		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

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