never executed always true always false
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE LambdaCase #-}
3 {-# LANGUAGE TypeApplications #-}
4
5 {-# OPTIONS_HADDOCK hide #-}
6
7 module System.IO.Extra
8 (
9 -- * I/O application-specific helpers
10 -- ** Read
11 hGetBytes
12 , hGetBech32
13 , hGetXPrv
14 , hGetXPub
15 , hGetXP__
16 , hGetScriptHash
17 , hGetSomeMnemonic
18 , hGetSomeMnemonicInteractively
19 , hGetPassphraseMnemonic
20 , hGetPassphraseBytes
21
22 -- ** Write
23 , hPutBytes
24 , hPutString
25
26 -- * I/O Helpers
27 , prettyIOException
28 , progName
29 , markCharsRedAtIndices
30 , noNewline
31 ) where
32
33 import Prelude
34
35 import Cardano.Address.Derivation
36 ( XPrv, XPub, xprvFromBytes, xpubFromBytes )
37 import Cardano.Address.Script
38 ( ScriptHash, scriptHashFromBytes )
39 import Cardano.Mnemonic
40 ( MkSomeMnemonicError (..), SomeMnemonic, mkSomeMnemonic )
41 import Codec.Binary.Bech32
42 ( HumanReadablePart, humanReadablePartToText )
43 import Codec.Binary.Encoding
44 ( AbstractEncoding (..)
45 , Encoding
46 , detectEncoding
47 , encode
48 , fromBase16
49 , fromBase58
50 , fromBase64
51 , fromBech32
52 )
53 import Control.Exception
54 ( IOException, bracket )
55 import Control.Monad
56 ( unless )
57 import Data.ByteString
58 ( ByteString )
59 import Data.List
60 ( nub, sort )
61 import Data.Text
62 ( Text )
63 import Data.Word
64 ( Word8 )
65 import Options.Applicative.Style
66 ( PassphraseInfo (..), PassphraseInput (..), PassphraseInputMode (..) )
67 import System.Console.ANSI
68 ( Color (..)
69 , ColorIntensity (..)
70 , ConsoleLayer (..)
71 , SGR (..)
72 , hCursorBackward
73 , setSGRCode
74 )
75 import System.Environment
76 ( getProgName )
77 import System.Exit
78 ( exitFailure )
79 import System.IO
80 ( BufferMode (..)
81 , Handle
82 , hGetBuffering
83 , hGetChar
84 , hGetEcho
85 , hPutChar
86 , hSetBuffering
87 , hSetEcho
88 , stderr
89 )
90 import System.IO.Unsafe
91 ( unsafePerformIO )
92
93 import qualified Data.ByteString as BS
94 import qualified Data.ByteString.Char8 as B8
95 import qualified Data.Text as T
96 import qualified Data.Text.Encoding as T
97 import qualified Data.Text.IO as TIO
98 --
99 -- I/O Read
100 --
101
102 -- | Read some bytes from the console, and decode them if the encoding is recognized.
103 hGetBytes :: Handle -> IO ByteString
104 hGetBytes h = do
105 raw <- B8.filter noNewline <$> B8.hGetContents h
106 case detectEncoding (T.unpack $ T.decodeUtf8 raw) of
107 Just (EBase16 ) -> decodeBytes fromBase16 raw
108 Just (EBech32{}) -> decodeBytes (fmap snd . fromBech32 markCharsRedAtIndices) raw
109 Just (EBase58 ) -> decodeBytes fromBase58 raw
110 Nothing -> fail
111 "Couldn't detect input encoding? Data on stdin must be encoded as \
112 \bech16, bech32 or base58."
113
114 decodeBytes
115 :: (bin -> Either String result)
116 -> bin
117 -> IO result
118 decodeBytes from = either fail pure . from
119
120 -- | Read some bytes encoded in Bech32, only allowing the given prefixes.
121 hGetBech32 :: Handle -> [HumanReadablePart] -> IO (HumanReadablePart, ByteString)
122 hGetBech32 h allowedPrefixes = do
123 raw <- B8.filter noNewline <$> B8.hGetContents h
124 (hrp, bytes) <- decodeBytes (fromBech32 markCharsRedAtIndices) raw
125 unless (hrp `elem` allowedPrefixes) $ fail
126 $ "Invalid human-readable prefix. Prefix ought to be one of: "
127 <> show (showHrp <$> allowedPrefixes)
128 pure (hrp, bytes)
129 where
130 showHrp :: HumanReadablePart -> String
131 showHrp = T.unpack . humanReadablePartToText
132
133 -- | Read some English mnemonic words from the console, or fail.
134 hGetSomeMnemonic :: Handle -> IO SomeMnemonic
135 hGetSomeMnemonic h = do
136 wrds <- T.words . T.filter noNewline . T.decodeUtf8 <$> B8.hGetContents h
137 case mkSomeMnemonic @'[ 9, 12, 15, 18, 21, 24 ] wrds of
138 Left (MkSomeMnemonicError e) -> fail e
139 Right mw -> pure mw
140
141 -- | Read an encoded private key from the console, or fail.
142 hGetXPrv :: Handle -> [HumanReadablePart] -> IO (HumanReadablePart, XPrv)
143 hGetXPrv h allowedPrefixes = do
144 (hrp, bytes) <- hGetBech32 h allowedPrefixes
145 case xprvFromBytes bytes of
146 Nothing -> fail "Couldn't convert bytes into extended private key."
147 Just key -> pure (hrp, key)
148
149 -- | Read an encoded public key from the console, or fail.
150 hGetXPub :: Handle -> [HumanReadablePart] -> IO (HumanReadablePart, XPub)
151 hGetXPub h allowedPrefixes = do
152 (hrp, bytes) <- hGetBech32 h allowedPrefixes
153 case xpubFromBytes bytes of
154 Nothing -> fail "Couldn't convert bytes into extended public key."
155 Just key -> pure (hrp, key)
156
157 -- | Read a script hash from the console, or fail.
158 hGetScriptHash :: Handle -> IO ScriptHash
159 hGetScriptHash h = do
160 bytes <- hGetBytes h
161 case scriptHashFromBytes bytes of
162 Nothing -> fail "Couldn't convert bytes into script hash."
163 Just scriptHash -> pure scriptHash
164
165 -- | Read either an encoded public or private key from the console, or fail.
166 hGetXP__
167 :: Handle
168 -> [HumanReadablePart]
169 -> IO (Either (HumanReadablePart, XPub) (HumanReadablePart, XPrv))
170 hGetXP__ h allowedPrefixes = do
171 (hrp, bytes) <- hGetBech32 h allowedPrefixes
172 case (xpubFromBytes bytes, xprvFromBytes bytes) of
173 (Just xpub, _) -> pure (Left (hrp, xpub))
174 (_ , Just xprv) -> pure (Right (hrp, xprv))
175 _ -> fail
176 "Couldn't convert bytes into neither extended public or private keys."
177
178 withBuffering :: Handle -> BufferMode -> IO a -> IO a
179 withBuffering h buffering action = bracket aFirst aLast aBetween
180 where
181 aFirst = (hGetBuffering h <* hSetBuffering h buffering)
182 aLast = hSetBuffering h
183 aBetween = const action
184
185 withEcho :: Handle -> Bool -> IO a -> IO a
186 withEcho h echo action = bracket aFirst aLast aBetween
187 where
188 aFirst = (hGetEcho h <* hSetEcho h echo)
189 aLast = hSetEcho h
190 aBetween = const action
191
192 -- | Gather user inputs until a newline is met, hiding what's typed with a
193 -- placeholder character.
194 hGetSensitiveLine
195 :: (Handle, Handle)
196 -> PassphraseInputMode
197 -> String
198 -> IO Text
199 hGetSensitiveLine (hstdin, hstderr) mode prompt =
200 withBuffering hstderr NoBuffering $
201 withBuffering hstdin NoBuffering $
202 withEcho hstdin False $ do
203 hPutString hstderr prompt
204 getLineSensitive '*'
205 where
206 backspace = toEnum 127
207
208 getLineSensitive :: Char -> IO Text
209 getLineSensitive placeholder =
210 getLineSensitive' mempty
211 where
212 getLineSensitive' line = do
213 hGetChar hstdin >>= \case
214 '\n' -> do
215 hPutChar hstderr '\n'
216 return line
217 c | c == backspace ->
218 if T.null line
219 then getLineSensitive' line
220 else do
221 hCursorBackward hstderr 1
222 hPutChar hstderr ' '
223 hCursorBackward hstderr 1
224 getLineSensitive' (T.init line)
225 c -> do
226 case mode of
227 Sensitive ->
228 hPutChar hstderr placeholder
229 Explicit ->
230 hPutChar hstderr c
231 Silent ->
232 pure ()
233 getLineSensitive' (line <> T.singleton c)
234
235 -- | Prompt user and read some English mnemonic words from stdin.
236 hGetSomeMnemonicInteractively
237 :: (Handle, Handle)
238 -> PassphraseInputMode
239 -> String
240 -> IO SomeMnemonic
241 hGetSomeMnemonicInteractively (hstdin, hstderr) mode prompt = do
242 wrds <- T.words . T.filter noNewline <$>
243 hGetSensitiveLine (hstdin, hstderr) mode prompt
244 case mkSomeMnemonic @'[ 9, 12, 15, 18, 21, 24 ] wrds of
245 Left (MkSomeMnemonicError e) -> fail e
246 Right mw -> pure mw
247
248 -- | Read mnemonic passphrase from either file or interactively.
249 hGetPassphraseMnemonic
250 :: (Handle, Handle)
251 -> PassphraseInputMode
252 -> PassphraseInput
253 -> String
254 -> IO SomeMnemonic
255 hGetPassphraseMnemonic (hstdin, hstderr) mode input prompt =
256 case input of
257 Interactive ->
258 hGetPassphraseMnemonicInteractively (hstdin, hstderr) mode prompt
259 FromFile path ->
260 hGetPassphraseMnemonicFromFile path
261
262 -- | Read the mnemonic passphrase (second factor) from file.
263 hGetPassphraseMnemonicFromFile
264 :: FilePath
265 -> IO SomeMnemonic
266 hGetPassphraseMnemonicFromFile path = do
267 wrds <- T.words . T.filter noNewline . T.decodeUtf8 <$> BS.readFile path
268 case mkSomeMnemonic @'[ 9, 12 ] wrds of
269 Left (MkSomeMnemonicError e) -> fail e
270 Right mw -> pure mw
271
272 -- | Prompt user and read the mnemonic passphrase (second factor) interactively.
273 hGetPassphraseMnemonicInteractively
274 :: (Handle, Handle)
275 -> PassphraseInputMode
276 -> String
277 -> IO SomeMnemonic
278 hGetPassphraseMnemonicInteractively (hstdin, hstderr) mode prompt = do
279 wrds <- T.words . T.filter noNewline <$>
280 hGetSensitiveLine (hstdin, hstderr) mode prompt
281 case mkSomeMnemonic @'[ 9, 12 ] wrds of
282 Left (MkSomeMnemonicError e) -> fail e
283 Right mw -> pure mw
284
285 -- | Read passphrase from either file or interactively, and decode them accoring to passphrase info.
286 hGetPassphraseBytes
287 :: (Handle, Handle)
288 -> PassphraseInputMode
289 -> PassphraseInput
290 -> String
291 -> PassphraseInfo
292 -> IO ByteString
293 hGetPassphraseBytes (hstdin, hstderr) mode input prompt info =
294 case input of
295 Interactive ->
296 hGetPassphraseBytesInteractively (hstdin, hstderr) mode prompt info
297 FromFile path ->
298 hGetPassphraseBytesFromFile path info
299
300 -- | Read some bytes from the file, and decode them accoring to passphrase info.
301 hGetPassphraseBytesFromFile
302 :: FilePath
303 -> PassphraseInfo
304 -> IO ByteString
305 hGetPassphraseBytesFromFile path = \case
306 Hex -> do
307 raw <- B8.filter noNewline . T.encodeUtf8 <$> TIO.readFile path
308 decodeBytes fromBase16 raw
309 Base64 -> do
310 raw <- B8.filter noNewline . T.encodeUtf8 <$> TIO.readFile path
311 decodeBytes fromBase64 raw
312 Utf8 -> do
313 B8.filter noNewline . T.encodeUtf8 <$> TIO.readFile path
314 Octets -> do
315 txt <- TIO.readFile path
316 let bytes = read @[Word8] (T.unpack txt)
317 pure $ BS.pack bytes
318 _ -> fail
319 "Data in file must be encoded as hex, base64, utf8 or octet array."
320
321 -- | Read some bytes from the console, and decode them accoring to passphrase info.
322 hGetPassphraseBytesInteractively
323 :: (Handle, Handle)
324 -> PassphraseInputMode
325 -> String
326 -> PassphraseInfo
327 -> IO ByteString
328 hGetPassphraseBytesInteractively (hstdin, hstderr) mode prompt = \case
329 Hex -> do
330 raw <- B8.filter noNewline . T.encodeUtf8 <$> hGetSensitiveLine (hstdin, hstderr) mode prompt
331 decodeBytes fromBase16 raw
332 Base64 -> do
333 raw <- B8.filter noNewline . T.encodeUtf8 <$> hGetSensitiveLine (hstdin, hstderr) mode prompt
334 decodeBytes fromBase64 raw
335 Utf8 -> do
336 txt <- hGetSensitiveLine (hstdin, hstderr) mode prompt
337 pure $ T.encodeUtf8 txt
338 Octets -> do
339 txt <- hGetSensitiveLine (hstdin, hstderr) mode prompt
340 let bytes = read @[Word8] (T.unpack txt)
341 pure $ BS.pack bytes
342 _ -> fail
343 "Data on stdin must be encoded as hex, base64, utf8 or octet array."
344
345 --
346 -- I/O Write
347 --
348
349 -- | Print bytes to the console with the given encoding.
350 hPutBytes :: Handle -> ByteString -> Encoding -> IO ()
351 hPutBytes h bytes =
352 B8.hPutStr h . flip encode bytes
353
354 -- | Print string to the console.
355 hPutString :: Handle -> String -> IO ()
356 hPutString h =
357 B8.hPutStrLn h . T.encodeUtf8 . T.pack
358
359 --
360 -- Helpers
361 --
362
363 noNewline :: Char -> Bool
364 noNewline = (`notElem` ['\n', '\r'])
365
366 -- | Fail with a colored red error message.
367 prettyIOException :: IOException -> IO a
368 prettyIOException e = do
369 B8.hPutStrLn stderr $ T.encodeUtf8 $ T.pack $ show e
370 exitFailure
371
372 -- | Mark all characters from a given string as red (in a console).
373 markCharsRedAtIndices :: Integral i => [i] -> String -> String
374 markCharsRedAtIndices ixs = go 0 (sort $ nub ixs)
375 where
376 go _c [] [] = mempty
377 go c (i:is) (s:ss)
378 | c == i = red ++ s:def ++ go (c + 1) is ss
379 | otherwise = s : go (c + 1) (i:is) ss
380 go _ [] ss = ss
381 go _ _ [] = [] -- NOTE: Really an error case.
382
383 red = setSGRCode [SetColor Foreground Vivid Red]
384 def = setSGRCode [Reset]
385
386 -- | Get program name to avoid hard-coding it in documentation excerpt.
387 progName :: String
388 progName = unsafePerformIO getProgName
389 {-# NOINLINE progName #-}