blob: 8a3c4eedb72fa806d3d844c3f7645dd83ddf9f69 (
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
|
{- 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
, promptQuestion = myPromptQuestion
, promptName = myPromptName
, promptPassword = myPromptPassword
, promptKeyId = myPromptKeyId
, withProgress = myWithProgress
}
myShowError :: Desc -> IO ()
myShowError desc = do
hPutStrLn stderr $ "Error: " ++ desc
putStrLn ""
myPromptQuestion :: Title -> Desc -> Question -> IO Bool
myPromptQuestion title desc question = do
showTitle title
go
where
go = do
putStrLn desc
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 -> Name -> (Name -> Maybe Problem) -> IO (Maybe Name)
myPromptName title desc (Name suggested) checkproblem = do
showTitle title
putStrLn desc
go
where
go = do
addHistory (BU8.toString suggested)
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 teardown (const prompt)
where
setup = do
showTitle title
putStrLn desc
origattr <- getTerminalAttributes stdInput
let newattr = origattr `withoutMode` EnableEcho
setTerminalAttributes stdInput newattr Immediately
return origattr
teardown origattr = setTerminalAttributes stdInput origattr Immediately
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 ->
return $ Just $ snd (l !! n)
_ -> do
putStrLn $ "Enter a number from 1 to " ++ show (length l)
prompt
myWithProgress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
myWithProgress title desc a = bracket_ setup teardown (a sendpercent)
where
setup = do
showTitle title
putStrLn desc
sendpercent p = do
putStr (show p ++ "% ")
hFlush stdout
teardown = putStrLn "done"
showTitle :: Title -> IO ()
showTitle title = do
putStrLn title
putStrLn (replicate (length title) '-')
putStrLn ""
|