blob: bcbe27e0b5bf3eeed5ee08c9e788c9df8a3f10f8 (
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
|
{- 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.Monad
import Control.Exception
import System.IO
import qualified Data.ByteString.UTF8 as BU8
readlineUI :: UI
readlineUI = UI
{ isAvailable = queryTerminal stdInput
, promptName = name
, promptPassword = password
, withProgress = progress
}
name :: Title -> Desc -> (Name -> Maybe Problem) -> IO (Maybe Name)
name title desc checkproblem = go ""
where
go extradesc = do
putStrLn title
putStrLn ""
putStrLn desc
unless (null extradesc) $
putStrLn extradesc
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 -> go problem
Nothing -> return Nothing
password :: Title -> Desc -> (Password -> Maybe Problem) -> IO (Maybe Password)
password title desc checkproblem = bracket setup teardown (const go)
where
setup = do
putStrLn title
putStrLn ""
putStrLn desc
origattr <- getTerminalAttributes stdInput
let newattr = origattr `withoutMode` EnableEcho
setTerminalAttributes stdInput newattr Immediately
return origattr
teardown origattr = setTerminalAttributes stdInput origattr Immediately
go = do
putStr "Enter password> "
hFlush stdout
p1 <- getLine
putStrLn ""
putStr "Confirm password> "
hFlush stdout
p2 <- getLine
putStrLn ""
if p1 /= p2
then do
putStrLn "Passwords didn't match, try again..."
go
else
let p = Password $ BU8.fromString p1
in case checkproblem p of
Nothing -> do
putStrLn ""
return $ Just p
Just problem -> do
putStrLn problem
go
progress :: Title -> Desc -> ((Percent -> IO ()) -> IO ()) -> IO ()
progress title desc a = bracket_ setup teardown (a sendpercent)
where
setup = do
putStrLn title
putStrLn ""
putStrLn desc
sendpercent p = do
putStr (show p ++ "% ")
hFlush stdout
teardown = putStrLn "done"
|
