keysafe-0.20160819: 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

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: " ++ 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", desc
		]
	cleanup h = do
		_ <- waitZenity h
		return ()

myPromptQuestion :: Title -> Desc -> Question -> IO Bool
myPromptQuestion title desc question = do
	h <- runZenity
		[ "--question"
		, "--title", title
		, "--text",  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", 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", 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", desc
		, "--column", "gpg secret key name"
		, "--column", "keyid"
		, "--print-column", "ALL"
		, "--separator", "\BEL"
		, "--width", "500"
		] ++ concatMap (\(Name n, KeyId kid) -> [BU8.toString n, BU8.toString kid]) l
	(ret, ok) <- waitZenity h
	if ok
		then do
			let (_n, _:kid) = break (== '\BEL') ret
			return $ Just (KeyId (BU8.fromString 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", 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)