keysafe-0.20160922: UI/Zenity.hs

{- Copyright 2016 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

module UI.Zenity (zenityUI) where

import Types
import Types.UI
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
import qualified Data.Text as T

zenityUI :: UI
zenityUI = UI
	{ isAvailable = do
		ps <- getSearchPath
		loc <- filterM (\p -> doesFileExist (p </> "zenity")) ps
		return (not (null loc))
	, showError = myShowError
	, showInfo = myShowInfo
	, promptQuestion = myPromptQuestion
	, promptName = myPromptName
	, promptPassword = myPromptPassword
	, promptKeyId = myPromptKeyId
	, withProgress = myWithProgress
	}

myShowError :: Desc -> IO ()
myShowError desc = bracket go cleanup (\_ -> return ())
  where
	go = runZenity
		[ "--error"
		, "--title", "keysafe"
		, "--text", "Error: " ++ escape desc
		]
	cleanup h = do
		_ <- waitZenity h
		return ()

myShowInfo :: Title -> Desc -> IO ()
myShowInfo title desc = bracket go cleanup (\_ -> return ())
  where
	go = runZenity
		[ "--info"
		, "--title", title
		, "--text", escape desc
		]
	cleanup h = do
		_ <- waitZenity h
		return ()

myPromptQuestion :: Title -> Desc -> Question -> IO Bool
myPromptQuestion title desc question = do
	h <- runZenity
		[ "--question"
		, "--title", title
		, "--text",  escape $ desc ++ "\n" ++ question
		]
	(_, ok) <- waitZenity h
	return ok

myPromptName :: Title -> Desc -> Maybe Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
myPromptName title desc suggested checkproblem = go ""
  where
	go extradesc = do
		h <- runZenity
			[ "--entry"
			, "--title", title
			, "--text", escape $ desc ++ "\n" ++ extradesc
			, "--entry-text", case suggested of
				Nothing -> ""
				Just (Name b) -> BU8.toString b
			]
		(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

myPromptPassword :: Bool -> Title -> Desc -> IO (Maybe Password)
myPromptPassword confirm title desc = go ""
  where
	go extradesc = do
		h <- runZenity $
			[ "--forms"
			, "--title", title
			, "--text", escape $ desc ++ "\n" ++ extradesc ++ "\n"
			, "--separator", "\BEL"
			, "--add-password", "Enter password"
			] ++ if confirm
				then [ "--add-password", "Confirm password" ]
				else []
		(ret, ok) <- waitZenity h
		if ok
			then if confirm
				then 
					let (p1, _:p2) = break (== '\BEL') ret
						in if p1 /= p2
						then go "Passwords didn't match, try again..."
						else return $ Just $ Password $ BU8.fromString p1
				else return $ Just $ Password $ BU8.fromString ret
			else return Nothing

myPromptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId)
myPromptKeyId _ _ [] = return Nothing
myPromptKeyId title desc l = do
	h <- runZenity $
		[ "--list"
		, "--title", title
		, "--text", escape desc
		, "--column", "gpg secret key name"
		, "--column", "keyid"
		, "--print-column", "ALL"
		, "--separator", "\BEL"
		, "--width", "500"
		] ++ concatMap (\(Name n, KeyId kid) -> [BU8.toString n, T.unpack kid]) l
	(ret, ok) <- waitZenity h
	if ok
		then do
			let (_n, _:kid) = break (== '\BEL') ret
			return $ Just (KeyId (T.pack kid))
		else return Nothing

myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a
myWithProgress title desc a = bracket setup teardown (a . sendpercent)
  where
	setup = do
		h <- runZenity
			[ "--progress"
			, "--title", title
			, "--text", escape 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)

-- Zenity parses --text as html and will choke on invalid tags
-- and '&' used outside a html entity. We don't want to use html, so
-- escape these things.
escape :: String -> String
escape = concatMap esc 
  where
	esc '&' = "&amp;"
	esc '<' = "&lt;"
	esc '>' = "&gt;"
	esc c = [c]