1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
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 Problem) -> 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 Problem) -> 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)
|
