blob: 668c023f81e767d7c4c76e1f585c0a36e2b47840 (
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
164
165
166
167
|
{- 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 System.Console.Readline
import System.Posix.Terminal
import System.Posix.IO
import Control.Exception
import System.IO
import Data.List
import Data.Char
import Text.Read
import Control.Monad
import qualified Data.ByteString.UTF8 as BU8
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
hPutStrLn stderr $ "Error: " ++ desc
_ <- readline "[Press Enter]"
putStrLn ""
myShowInfo :: Title -> Desc -> IO ()
myShowInfo title desc = do
showTitle title
putStrLn desc
putStrLn ""
myPromptQuestion :: Title -> Desc -> Question -> IO Bool
myPromptQuestion title desc question = bracket_ setup cleanup go
where
setup = do
showTitle title
putStrLn desc
cleanup = putStrLn ""
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
putStrLn "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
putStrLn desc
cleanup = putStrLn ""
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
putStrLn ""
return $ Just n
Just problem -> do
putStrLn 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
putStrLn desc
origattr <- getTerminalAttributes stdInput
let newattr = origattr `withoutMode` EnableEcho
setTerminalAttributes stdInput newattr Immediately
return origattr
cleanup origattr = do
setTerminalAttributes stdInput origattr Immediately
putStrLn ""
prompt = do
putStr "Enter password> "
hFlush stdout
p1 <- getLine
putStrLn ""
if confirm
then promptconfirm p1
else return $ mkpassword p1
promptconfirm p1 = do
putStr "Confirm password> "
hFlush stdout
p2 <- getLine
putStrLn ""
if p1 /= p2
then do
putStrLn "Passwords didn't match, try again..."
prompt
else do
putStrLn ""
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
putStrLn desc
putStrLn ""
forM_ nl $ \(n, ((Name name), (KeyId kid))) ->
putStrLn $ show n ++ ".\t" ++ BU8.toString name ++ " (keyid " ++ BU8.toString kid ++ ")"
prompt
where
nl = zip [1 :: Integer ..] l
prompt = do
putStr "Enter number> "
hFlush stdout
r <- getLine
putStrLn ""
case readMaybe r of
Just n
| n > 0 && n < length l -> do
putStrLn ""
return $ Just $ snd (l !! n)
_ -> do
putStrLn $ "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
putStrLn desc
sendpercent p = do
putStr (show p ++ "% ")
hFlush stdout
cleanup = do
putStrLn "done"
putStrLn ""
showTitle :: Title -> IO ()
showTitle title = do
putStrLn title
putStrLn (replicate (length title) '-')
putStrLn ""
|