pluggable UI

using zenity for GUI in X

3 files changed, 133 insertions, 2 deletions

diff --git a/INSTALL b/INSTALL
index 21c43f7..3f09bc1 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,7 +1,7 @@
-You should first install ghc, cabal, and the argon2 library.
+You should first install ghc, cabal, the argon2 library, and zenity
 For example, on a Debian system:
 
-	sudo apt-get install ghc cabal-install libargon2-0-dev
+	sudo apt-get install ghc cabal-install libargon2-0-dev zenity
 
 Then to build and install keysafe:
 
diff --git a/UI.hs b/UI.hs
new file mode 100644
index 0000000..7e583cf
--- /dev/null
+++ b/UI.hs
@@ -0,0 +1,20 @@
+{- Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module UI where
+
+import Types
+
+data UI = UI
+	{ isAvailable :: IO Bool
+	, promptName :: Title -> Desc -> (Name -> Maybe Problem) -> IO (Maybe Name)
+	, promptPassword :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
+	, withProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
+	}
+
+type Title = String
+type Desc = String
+type Percent = Int
+type Problem = String
diff --git a/UI/Zenity.hs b/UI/Zenity.hs
new file mode 100644
index 0000000..2601f68
--- /dev/null
+++ b/UI/Zenity.hs
@@ -0,0 +1,111 @@
+{- Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module UI.Zenity (zenityUI) where
+
+import UI
+import Types
+import Control.Monad
+import System.Process
+import Control.Exception
+import System.IO
+import System.FilePath
+import System.Directory
+import System.Exit
+import qualified Data.ByteString.UTF8 as BU8
+
+zenityUI :: UI
+zenityUI = UI
+	{ isAvailable = do
+		ps <- getSearchPath
+		loc <- filterM (\p -> doesFileExist (p </> "zenity")) ps
+		return (not (null loc))
+	, promptName = name
+	, promptPassword = password
+	, withProgress = progress
+	}
+
+name :: Title -> Desc -> (Name -> Maybe String) -> IO (Maybe Name)
+name title desc checkproblem = go ""
+  where
+	go extradesc = do
+		h <- runZenity
+			[ "--entry"
+			, "--title", title
+			, "--text", desc ++ "\n" ++ extradesc
+			]
+		(ret, ok) <- waitZenity h
+		if ok
+			then 
+				let n = Name $ BU8.fromString ret
+				in case checkproblem n of
+					Nothing -> return $ Just n
+					Just problem -> go problem
+			else return Nothing
+
+password :: Title -> Desc -> (Password -> Maybe String) -> IO (Maybe Password)
+password title desc checkproblem = go ""
+  where
+	go extradesc = do
+		h <- runZenity
+			[ "--forms"
+			, "--title", title
+			, "--text", desc ++ "\n" ++ extradesc ++ "\n"
+			, "--add-password", "Enter password"
+			, "--add-password", "Confirm password"
+			, "--separator", "\BEL"
+			]
+		(ret, ok) <- waitZenity h
+		if ok
+			then
+				let (p1, _:p2) = break (== '\BEL') ret
+				in if p1 /= p2
+					then go "Passwords didn't match, try again..."
+					else
+						let p = Password $ BU8.fromString p1
+						in case checkproblem p of
+							Nothing -> return $ Just p
+							Just problem -> go problem
+			else return Nothing
+
+progress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
+progress title desc a = bracket setup teardown (a . sendpercent)
+  where
+	setup = do
+		h <- runZenity
+			[ "--progress"
+			, "--title", title
+			, "--text", desc
+			, "--auto-close"
+			, "--auto-kill"
+			]
+		return h
+	sendpercent h p = sendZenity h (show p)
+	teardown h = do
+		_ <- waitZenity h
+		return ()
+
+data ZenityHandle = ZenityHandle Handle Handle ProcessHandle
+
+runZenity :: [String] -> IO ZenityHandle
+runZenity ps = do
+	(Just hin, Just hout, Nothing, ph) <- createProcess
+		(proc "zenity" ps)
+		{ std_out = CreatePipe
+		, std_in = CreatePipe
+		}
+	return $ ZenityHandle hin hout ph
+
+sendZenity :: ZenityHandle -> String -> IO ()
+sendZenity (ZenityHandle hin _ _) s = do
+	hPutStrLn hin s
+	hFlush hin
+
+waitZenity :: ZenityHandle -> IO (String, Bool)
+waitZenity (ZenityHandle hin hout ph) = do
+	hClose hin
+	ret <- hGetContents hout
+	exit <- waitForProcess ph
+	return (takeWhile (/= '\n') ret, exit == ExitSuccess)