{- 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.Monad
import Control.Exception
import System.IO
import qualified Data.ByteString.UTF8 as BU8

readlineUI :: UI
readlineUI = UI
	{ isAvailable = queryTerminal stdInput
	, promptName = name
	, promptPassword = password
	, withProgress = progress
	}

name :: Title -> Desc -> (Name -> Maybe Problem) -> IO (Maybe Name)
name title desc checkproblem = go ""
  where
	go extradesc = do
		putStrLn title
		putStrLn ""
		putStrLn desc
		unless (null extradesc) $
			putStrLn extradesc
		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 -> go problem
			Nothing -> return Nothing

password :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
password title desc checkproblem = bracket setup teardown (const go)
  where
	setup = do
		putStrLn title
		putStrLn ""
		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

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