Filter out escape sequences and any other unusual characters when writing all messages to the console.

This should protect against all attacks where the server sends back a
malicious message.

2 files changed, 41 insertions, 48 deletions

diff --git a/UI/NonInteractive.hs b/UI/NonInteractive.hs
index f0010eb..cd96254 100644
--- a/UI/NonInteractive.hs
+++ b/UI/NonInteractive.hs
@@ -6,7 +6,7 @@
 module UI.NonInteractive (noninteractiveUI) where
 
 import Types.UI
-import System.IO
+import Output
 import Control.Exception
 
 noninteractiveUI :: UI
@@ -22,21 +22,19 @@ noninteractiveUI = UI
 	}
 
 myShowError :: Desc -> IO ()
-myShowError desc = hPutStrLn stderr $ "Error: " ++ desc
+myShowError desc = warn $ "Error: " ++ desc
 
 myShowInfo :: Title -> Desc -> IO ()
-myShowInfo _title desc = putStrLn desc
+myShowInfo _title desc = say desc
 
 myPrompt :: Title -> Desc -> x -> IO a
 myPrompt _title desc _ = do
-	putStrLn desc
+	say desc
 	error "Not running at a terminal and zenity is not installed; cannot interact with user."
 
 myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a
 myWithProgress _title desc a = bracket_ setup cleanup (a sendpercent)
   where
-	setup = putStrLn desc
-	sendpercent p = do
-		putStr (show p ++ "%  ")
-		hFlush stdout
-	cleanup = putStrLn "done"
+	setup = say desc
+	sendpercent p = progress (show p ++ "%  ")
+	cleanup = say "done"
diff --git a/UI/Readline.hs b/UI/Readline.hs
index 7f19f67..16e4923 100644
--- a/UI/Readline.hs
+++ b/UI/Readline.hs
@@ -7,11 +7,11 @@ 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 System.IO
 import Data.List
 import Data.Char
 import Text.Read
@@ -33,23 +33,23 @@ readlineUI = UI
 
 myShowError :: Desc -> IO ()
 myShowError desc = do
-	hPutStrLn stderr $ "Error: " ++ desc
+	warn $ "Error: " ++ desc
 	_ <- readline "[Press Enter]"
-	putStrLn ""
+	say ""
 
 myShowInfo :: Title -> Desc -> IO ()
 myShowInfo title desc = do
 	showTitle title
-	putStrLn desc
-	putStrLn ""
+	say desc
+	say ""
 
 myPromptQuestion :: Title -> Desc -> Question -> IO Bool
 myPromptQuestion title desc question = bracket_ setup cleanup go
   where
 	setup = do
 		showTitle title
-		putStrLn desc
-	cleanup = putStrLn ""
+		say desc
+	cleanup = say ""
 	go = do
 		mresp <- readline $ question ++ " [y/n] "
 		case mresp of
@@ -59,7 +59,7 @@ myPromptQuestion title desc question = bracket_ setup cleanup go
 				| "n" `isPrefixOf` (map toLower s) -> 
 					return False
 			_ -> do
-				putStrLn "Please enter 'y' or 'n'"
+				say "Please enter 'y' or 'n'"
 				go
 
 myPromptName :: Title -> Desc -> Maybe Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
@@ -68,8 +68,8 @@ myPromptName title desc suggested checkproblem =
   where
 	setup = do
 		showTitle title
-		putStrLn desc
-	cleanup = putStrLn ""
+		say desc
+	cleanup = say ""
 	go = do
 		case suggested of
 			Nothing -> return ()
@@ -81,10 +81,10 @@ myPromptName title desc suggested checkproblem =
 				let n = Name $ BU8.fromString s
 				case checkproblem n of
 					Nothing -> do
-						putStrLn ""
+						say ""
 						return $ Just n
 					Just problem -> do
-						putStrLn problem
+						say problem
 						go
 			Nothing -> return Nothing
 
@@ -93,33 +93,31 @@ myPromptPassword confirm title desc = bracket setup cleanup (const prompt)
   where
 	setup = do
 		showTitle title
-		putStrLn desc
+		say desc
 		origattr <- getTerminalAttributes stdInput
 		let newattr = origattr `withoutMode` EnableEcho
 		setTerminalAttributes stdInput newattr Immediately
 		return origattr
 	cleanup origattr = do
 		setTerminalAttributes stdInput origattr Immediately
-		putStrLn ""
+		say ""
 	prompt = do
-		putStr "Enter password> "
-		hFlush stdout
+		ask "Enter password> "
 		p1 <- getLine
-		putStrLn ""
+		say ""
 		if confirm
 			then promptconfirm p1
 			else return $ mkpassword p1
 	promptconfirm p1 = do
-		putStr "Confirm password> "
-		hFlush stdout
+		ask "Confirm password> "
 		p2 <- getLine
-		putStrLn ""
+		say ""
 		if p1 /= p2
 			then do
-				putStrLn "Passwords didn't match, try again..."
+				say "Passwords didn't match, try again..."
 				prompt
 			else do
-				putStrLn ""
+				say ""
 				return $ mkpassword p1
 	mkpassword = Just . Password . BU8.fromString
 
@@ -127,25 +125,24 @@ myPromptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId)
 myPromptKeyId _ _ [] = return Nothing
 myPromptKeyId title desc l = do
 	showTitle title
-	putStrLn desc
-	putStrLn ""
+	say desc
+	say ""
 	forM_ nl $ \(n, ((Name name), (KeyId kid))) ->
-		putStrLn $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ T.unpack kid ++ ")"
+		say $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ T.unpack kid ++ ")"
 	prompt
   where
 	nl = zip [1 :: Integer ..] l
 	prompt = do
-		putStr "Enter number> "
-		hFlush stdout
+		ask "Enter number> "
 		r <- getLine
-		putStrLn ""
+		say ""
 		case readMaybe r of
 			Just n
 				| n > 0 && n <= length l -> do
-					putStrLn ""
+					say ""
 					return $ Just $ snd (l !! pred n)
 			_ -> do
-				putStrLn $ "Enter a number from 1 to " ++ show (length l)
+				say $ "Enter a number from 1 to " ++ show (length l)
 				prompt
 
 myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a
@@ -153,16 +150,14 @@ myWithProgress title desc a = bracket_ setup cleanup (a sendpercent)
   where
 	setup = do
 		showTitle title
-		putStrLn desc
-	sendpercent p = do
-		putStr (show p ++ "%  ")
-		hFlush stdout
+		say desc
+	sendpercent p = ask (show p ++ "%  ")
 	cleanup = do
-		putStrLn "done"
-		putStrLn ""
+		say "done"
+		say ""
 
 showTitle :: Title -> IO ()
 showTitle title = do
-	putStrLn title
-	putStrLn (replicate (length title) '-')
-	putStrLn ""
+	say title
+	say (replicate (length title) '-')
+	say ""