add readline UI

2 files changed, 94 insertions, 2 deletions

diff --git a/UI/Readline.hs b/UI/Readline.hs
new file mode 100644
index 0000000..bcbe27e
--- /dev/null
+++ b/UI/Readline.hs
@@ -0,0 +1,92 @@
+{- 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"
diff --git a/UI/Zenity.hs b/UI/Zenity.hs
index 2601f68..5eb4bef 100644
--- a/UI/Zenity.hs
+++ b/UI/Zenity.hs
@@ -27,7 +27,7 @@ zenityUI = UI
 	, withProgress = progress
 	}
 
-name :: Title -> Desc -> (Name -> Maybe String) -> IO (Maybe Name)
+name :: Title -> Desc -> (Name -> Maybe Problem) -> IO (Maybe Name)
 name title desc checkproblem = go ""
   where
 	go extradesc = do
@@ -45,7 +45,7 @@ name title desc checkproblem = go ""
 					Just problem -> go problem
 			else return Nothing
 
-password :: Title -> Desc -> (Password -> Maybe String) -> IO (Maybe Password)
+password :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
 password title desc checkproblem = go ""
   where
 	go extradesc = do