diff options
Diffstat (limited to 'UI/Zenity.hs')
| -rw-r--r-- | UI/Zenity.hs | 183 |
1 files changed, 183 insertions, 0 deletions
diff --git a/UI/Zenity.hs b/UI/Zenity.hs new file mode 100644 index 0000000..85347c6 --- /dev/null +++ b/UI/Zenity.hs @@ -0,0 +1,183 @@ +{- 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 '&' = "&" + esc '<' = "<" + esc '>' = ">" + esc c = [c] |