blob: 16e4923dcd83eae3ffdb47f6eaacb23886186256 (
plain)
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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
{- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module UI.Readline (readlineUI) where
import Types.UI
import Types
import Output
import System.Console.Readline
import System.Posix.Terminal
import System.Posix.IO
import Control.Exception
import Data.List
import Data.Char
import Text.Read
import Control.Monad
import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Text as T
readlineUI :: UI
readlineUI = UI
{ isAvailable = queryTerminal stdInput
, showError = myShowError
, showInfo = myShowInfo
, promptQuestion = myPromptQuestion
, promptName = myPromptName
, promptPassword = myPromptPassword
, promptKeyId = myPromptKeyId
, withProgress = myWithProgress
}
myShowError :: Desc -> IO ()
myShowError desc = do
warn $ "Error: " ++ desc
_ <- readline "[Press Enter]"
say ""
myShowInfo :: Title -> Desc -> IO ()
myShowInfo title desc = do
showTitle title
say desc
say ""
myPromptQuestion :: Title -> Desc -> Question -> IO Bool
myPromptQuestion title desc question = bracket_ setup cleanup go
where
setup = do
showTitle title
say desc
cleanup = say ""
go = do
mresp <- readline $ question ++ " [y/n] "
case mresp of
Just s
| "y" `isPrefixOf` (map toLower s) ->
return True
| "n" `isPrefixOf` (map toLower s) ->
return False
_ -> do
say "Please enter 'y' or 'n'"
go
myPromptName :: Title -> Desc -> Maybe Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
myPromptName title desc suggested checkproblem =
bracket_ setup cleanup go
where
setup = do
showTitle title
say desc
cleanup = say ""
go = do
case suggested of
Nothing -> return ()
Just (Name b) -> addHistory (BU8.toString b)
mname <- readline "Name> "
case mname of
Just s -> do
addHistory s
let n = Name $ BU8.fromString s
case checkproblem n of
Nothing -> do
say ""
return $ Just n
Just problem -> do
say problem
go
Nothing -> return Nothing
myPromptPassword :: Bool -> Title -> Desc -> IO (Maybe Password)
myPromptPassword confirm title desc = bracket setup cleanup (const prompt)
where
setup = do
showTitle title
say desc
origattr <- getTerminalAttributes stdInput
let newattr = origattr `withoutMode` EnableEcho
setTerminalAttributes stdInput newattr Immediately
return origattr
cleanup origattr = do
setTerminalAttributes stdInput origattr Immediately
say ""
prompt = do
ask "Enter password> "
p1 <- getLine
say ""
if confirm
then promptconfirm p1
else return $ mkpassword p1
promptconfirm p1 = do
ask "Confirm password> "
p2 <- getLine
say ""
if p1 /= p2
then do
say "Passwords didn't match, try again..."
prompt
else do
say ""
return $ mkpassword p1
mkpassword = Just . Password . BU8.fromString
myPromptKeyId :: Title -> Desc -> [(Name, KeyId)] -> IO (Maybe KeyId)
myPromptKeyId _ _ [] = return Nothing
myPromptKeyId title desc l = do
showTitle title
say desc
say ""
forM_ nl $ \(n, ((Name name), (KeyId kid))) ->
say $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ T.unpack kid ++ ")"
prompt
where
nl = zip [1 :: Integer ..] l
prompt = do
ask "Enter number> "
r <- getLine
say ""
case readMaybe r of
Just n
| n > 0 && n <= length l -> do
say ""
return $ Just $ snd (l !! pred n)
_ -> do
say $ "Enter a number from 1 to " ++ show (length l)
prompt
myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO a) -> IO a
myWithProgress title desc a = bracket_ setup cleanup (a sendpercent)
where
setup = do
showTitle title
say desc
sendpercent p = ask (show p ++ "% ")
cleanup = do
say "done"
say ""
showTitle :: Title -> IO ()
showTitle title = do
say title
say (replicate (length title) '-')
say ""
|
